Definitions.lean

import Verified.Correct
import Verified.Instantiate
import Verified.Reflect.Lemmas
import Verified.Reflect.BoundPass
import Verified.Reflect.Modes
import Verified.Reflect.FoldLemmas
import Verified.Reflect.ListFoldLemmas
import Verified.Reflect.TreeLemmas
import Verified.Reflect.TreeNodeLemmas
import Verified.Reflect.NativeList
import Verified.Reflect.NativeTree
import Verified.Reflect.RecursiveLayout
import Verified.Reflect.TailBoundLemmas
import LeanExe.Encoding.RoundTrip
import LeanExe.Encoding.Completeness.Writes

/-! The reflector.  `verified_compile p := [f, g, …]` reads the listed Lean definitions, writes
each as a source function, and proves its equation `denote (reflect f) = f` from the lemmas of
`Verified.Reflect.Lemmas`, composed term by term.  It adds the program `p.program`, the meanings
`p.funs` of its functions with the proof `p.meaning` that they are, the module
`p.module := compile p.program`, in which the `k`-th definition is function `2 + k`, and for each
definition `f` the source function `p.f.func`, the equation `p.f.denote_eq`, and the theorem
`p.f.implements` that the module computes `f`, at the entry of `f` when its code takes the call
depth.  A recursive definition is reflected from its unfolding equation, and its meaning
`p.f.meaning` is the definition at the inverses of the flattenings.  `p.bytes` states that the
module's bytes decode to the module, which computes every listed definition.

The reflector is meta code and is not trusted: Lean's kernel checks every equation it builds, and
the theorem holds for the parameter modes that `Expr.paramChoice` chooses as for any others.  A
definition's parameters and result are `UInt64`, `Bool`, `Float`, structures with a `Flat` instance
whose tuple is their fields, enumerations with a `Flat` instance to words, arrays of these, and
pairs, and structures whose `Flat` tuple holds arrays, which are represented as that tuple and split
as pairs are.  Its body may also hold arrays of tuples, which have no `Represent` instance.  A
structure's source value is its flattening `φ`, the source value of its `Flat` tuple, an array's is
the array of its elements' flattenings, and each equation states that the source expression means
`φ` of the Lean term, with `φ` the identity for the types without structures.  The theorem follows
from the equation by `ImplementsA.transferAgree`, with proofs that Lean's instances agree with the
source instances along `φ`.  Its body may use literals, its parameters, `let`, the word operations
`+`, `-`, `*`, `/`, `%`, `&&&`, `|||`, `^^^`, `<<<`, and `>>>`, the comparisons `==`, `!=`, `<`,
`≤`, `>`, `≥`, `=`, and `≠` as `Bool` values, `!`, `&&`, and `||`, `if` on a `Bool` or on a
comparison, also as `if h : c` with branches that do not use `h`, pairs built with `(a, b)` and
taken apart with `.1`, `.2`, or `match`, structures built with their constructor or `{ s with … }`
and taken apart with their fields or `match`, enumeration constructors, `Flat.flat` of enumerations,
`match` and comparisons on enumerations, Boolean equality and inequality, `LeanExe.loop`,
`LeanExe.repeatWhile`, whole-array `Array.foldl`, `#[]`, `xs.size.toUInt64`, `xs[i.toNat]!`,
`xs.set! i.toNat v`, `xs.push v`,
`xs ++ ys`, `LeanExe.build`, `LeanExe.insertAt xs i v`, `LeanExe.eraseAt xs i`, safe named
constants whose type holds no array, as their values, `setIfInBounds`, `insertIdxIfInBounds`,
`eraseIdxIfInBounds`, unfolded `@[inline]` helpers, calls of the listed definitions before it,
and, in a recursive definition, calls of itself.  A definition
`f x := g T₁ … Tₖ x` that applies a listed definition `g` to constants `Tᵢ` of type `Array UInt64`
before its own parameters is a wrapper: the module holds the tables `Tᵢ` in data segments and
exports `f` as an entry that passes their addresses to `g`. -/

namespace Verified.Reflect

open Lean Meta Elab Command Term

initialize registerTraceClass `Verified.reflect

def elemOf? (type : Lean.Expr) : MetaM (Option Elem) := do
  let type ← whnfR type
  if type.isConstOf ``UInt64 then return some .word
  if type.isConstOf ``Bool then return some .bool
  if type.isConstOf ``Float then return some .float
  if type.isConstOf ``Float32 then return some .float32
  return none

def elemExpr : Elem → Lean.Expr
  | .word => mkConst ``Elem.word
  | .bool => mkConst ``Elem.bool
  | .float => mkConst ``Elem.float
  | .float32 => mkConst ``Elem.float32
  | .prod a b => mkApp2 (mkConst ``Elem.prod) (elemExpr a) (elemExpr b)

def elemZero : Elem → MetaM Lean.Expr
  | .word => pure (toExpr (0 : UInt64))
  | .bool => pure (mkConst ``Bool.false)
  | .float => mkAppM ``Float.ofBits #[toExpr (0 : UInt64)]
  | .float32 => mkAppM ``Float32.ofBits #[toExpr (0 : UInt32)]
  | .prod a b => do mkAppM ``Prod.mk #[← elemZero a, ← elemZero b]

def boolEqTerm (a b : Lean.Expr) : MetaM Lean.Expr := do
  mkAppM ``ite #[← mkEq a (mkConst ``Bool.true), b, ← mkAppM ``not #[b]]

/-- The path along the steps `steps`, from the outside in, of a component of an element of type
`e`: `false` for the first part and `true` for the second.  Also the component's type. -/
def pathExpr : Elem → List Bool → MetaM (Lean.Expr × Elem)
  | e, [] => return (mkApp (mkConst ``Path.here) (elemExpr e), e)
  | .prod a b, false :: rest => do
    let (p, t) ← pathExpr a rest
    return (mkApp4 (mkConst ``Path.fst) (elemExpr a) (elemExpr t) (elemExpr b) p, t)
  | .prod a b, true :: rest => do
    let (p, t) ← pathExpr b rest
    return (mkApp4 (mkConst ``Path.snd) (elemExpr b) (elemExpr t) (elemExpr a) p, t)
  | _, _ :: _ => throwError "verified_compile: a projection of an element that is not a tuple"

abbrev reflectedTreeShape (ctors : List (List TreeField)) (valid : shapeValid ctors = true) :
    TreeShape :=
  ⟨ctors, valid⟩

/-- Record constructor `i` of a shape, with a proof that the kernel checks by evaluation. -/
abbrev reflectedRecord (shape : TreeShape) (i : Nat) (valid : decide (i < shape.records) = true) :
    Fin shape.records :=
  ⟨i, of_decide_eq_true valid⟩

def trueRefl : Lean.Expr :=
  mkApp2 (mkConst ``Eq.refl [Level.one]) (mkConst ``Bool) (mkConst ``Bool.true)

def treeShapeExpr (shape : TreeShape) : Lean.Expr :=
  if shape = listShape then mkConst ``listShape else
    mkApp2 (mkConst ``reflectedTreeShape) (toExpr shape.ctors) trueRefl

def recordExpr (shape : TreeShape) (r : Fin shape.records) : Lean.Expr :=
  if shape = listShape then mkConst ``listCell else
    mkApp3 (mkConst ``reflectedRecord) (treeShapeExpr shape) (mkNatLit r.val) trueRefl

def tyExpr : Ty → Lean.Expr
  | .word => mkConst ``Ty.word
  | .bool => mkConst ``Ty.bool
  | .pair a b => mkApp2 (mkConst ``Ty.pair) (tyExpr a) (tyExpr b)
  | .float => mkConst ``Ty.float
  | .float32 => mkConst ``Ty.float32
  | .elem e => mkApp (mkConst ``Ty.elem) (elemExpr e)
  | .array e => mkApp (mkConst ``Ty.array) (elemExpr e)
  | .bytes => mkConst ``Ty.bytes
  | .tree shape => mkApp (mkConst ``Ty.tree) (treeShapeExpr shape)
  | .treeHeader shape r => mkApp2 (mkConst ``Ty.treeHeader) (treeShapeExpr shape) (recordExpr shape r)

/-- How a Lean type is flattened into a source type: the source type, and the function `φ` from
the Lean type to the source type's meaning, `none` for the identity.  A structure with a `Flat`
instance is the flattening of its `Flat` tuple, so nested structures are flattened in turn. -/
structure Shape where
  ty : Ty
  flat : Option Lean.Expr

/-- `φ e`, beta-reduced. -/
def Shape.apply (sh : Shape) (e : Lean.Expr) : Lean.Expr :=
  match sh.flat with
  | none => e
  | some f => f.beta #[e]

/-- `φ` as a function from `type` to the source type's meaning, the identity when `flat` is
`none`. -/
def Shape.fn (sh : Shape) (type : Lean.Expr) : MetaM Lean.Expr := do
  let f ← match sh.flat with
    | some f => pure f
    | none => withLocalDeclD `x type fun x => mkLambdaFVars #[x] x
  mkExpectedTypeHint f (← mkArrow type (mkApp (mkConst ``Ty.denote) (tyExpr sh.ty)))

/-- The constructor and field names of a structure type other than `Prod`. -/
def structOf? (type : Lean.Expr) : MetaM (Option (ConstructorVal × Array Name)) := do
  let type ← whnfR type
  let .const n _ := type.getAppFn | return none
  if n == ``Prod then return none
  let env ← getEnv
  unless isStructure env n do return none
  let some (.ctorInfo ctor) := env.find? (getStructureCtor env n).name | return none
  return some (ctor, getStructureFields env n)

/-- The tuple tree of a structure's `Flat` instance: `Flat.flat` of the structure built from fresh
variables, reduced down the tuple's pairs, has those variables at its leaves.  Each leaf is the
index of a field, and a leaf is reached by steps `false` for a pair's first component and `true`
for its second.  The command `command` rejects an instance whose leaves are not distinct fields. -/
partial def flatTree (command : String) (type β inst : Lean.Expr) (ctor : ConstructorVal) :
    MetaM (List (Nat × List Bool)) := do
  let type ← whnfR type
  let ctorApp := mkAppN (mkConst ctor.name type.getAppFn.constLevels!) type.getAppArgs
  forallBoundedTelescope (← inferType ctorApp) ctor.numFields fun ys _ => do
    let t := mkApp4 (mkConst ``LeanExe.Pipeline.Flat.flat) type β inst (mkAppN ctorApp ys)
    let rec descend (t ty : Lean.Expr) (steps : List Bool) : MetaM (List (Nat × List Bool)) := do
      let ty ← whnfR ty
      let t' ← whnf t
      if let some i := ys.findIdx? (· == t') then return [(i, steps.reverse)]
      if let (``Prod, #[a, b]) := ty.getAppFnArgs then
        if let (``Prod.mk, #[_, _, x, y]) := t'.getAppFnArgs then
          return (← descend x a (false :: steps)) ++ (← descend y b (true :: steps))
      throwError "{command}: the `Flat` instance of {type} is not a tuple of its fields"
    let leaves ← descend t β []
    unless (leaves.map (·.1)).eraseDups.length == leaves.length do
      throwError "{command}: the `Flat` instance of {type} repeats a field"
    return leaves

/-- The name of a sum: an inductive type without parameters or indices that is neither recursive,
a structure, nor an enumeration. -/
def sumName? (type : Lean.Expr) : MetaM (Option Name) := do
  let .const name _ ← whnfR type | return none
  let some (.inductInfo info) := (← getEnv).find? name | return none
  unless info.numParams == 0 && info.numIndices == 0 && !info.isRec &&
      !isStructure (← getEnv) name do return none
  if ← isEnumType name then return none
  return some name

partial def shapeOf (type : Lean.Expr) : MetaM Shape := do
  if let some e ← elemOf? type then return ⟨.elem e, none⟩
  let type ← whnfR type
  if type.isConstOf ``LeanExe.Bytes then return ⟨.bytes, none⟩
  if let (``List, #[el]) := type.getAppFnArgs then
    if (← whnfR el).isConstOf ``UInt64 then
      return ⟨.tree listShape, some (mkConst ``Tree.ofList)⟩
  if let some layout ← recursiveLayout? type then
    let flatten := layout.decl `toTree
    if (← getEnv).contains flatten then return ⟨.tree layout.shape, some (mkConst flatten)⟩
  if let (``Prod, #[a, b]) := type.getAppFnArgs then
    let sa ← shapeOf a
    let sb ← shapeOf b
    let ty := match sa.ty, sb.ty with
      | .elem ea, .elem eb => Ty.elem (.prod ea eb)
      | ta, tb => .pair ta tb
    if sa.flat.isNone && sb.flat.isNone then return ⟨ty, none⟩
    let f ← withLocalDeclD `p type fun p => do
      mkLambdaFVars #[p] (← mkAppM ``Prod.mk
        #[sa.apply (← mkAppM ``Prod.fst #[p]), sb.apply (← mkAppM ``Prod.snd #[p])])
    return ⟨ty, some f⟩
  if let (``Array, #[el]) := type.getAppFnArgs then
    let se ← shapeOf el
    let .elem e := se.ty | throwError "verified_compile: an array holds elements, not {el}"
    if se.flat.isNone then return ⟨.array e, none⟩
    let φ ← se.fn el
    let f ← withLocalDeclD `xs type fun xs => do mkLambdaFVars #[xs] (← mkAppM ``Array.map #[φ, xs])
    return ⟨.array e, some f⟩
  if let some (β, inst) ← flatInstance? type then
    let sβ ← shapeOf β
    -- A sum whose tuple holds heap values is represented as its tuple, and `sumLayout` checks
    -- the tuple where a constructor or a match needs it.
    if !(sβ.ty matches .elem _) && (← sumName? type).isNone then
      -- A structure that holds arrays is split as its tuple, which must be a pair of all its
      -- fields.
      let some (ctor, _) ← structOf? type
        | throwError "verified_compile: {type} holds arrays and is not a structure"
      let (``Prod, _) := (← whnfR β).getAppFnArgs
        | throwError "verified_compile: the `Flat` instance of {type} holds arrays and is not a \
            pair"
      unless (← flatTree "verified_compile" type β inst ctor).length == ctor.numFields do
        throwError "verified_compile: the `Flat` instance of {type} does not hold all its fields"
    let f ← withLocalDeclD `x type fun x => do
      mkLambdaFVars #[x] (sβ.apply (mkApp4 (mkConst ``LeanExe.Pipeline.Flat.flat) type β inst x))
    return ⟨sβ.ty, some f⟩
  throwError "verified_compile: the type {type} is not UInt64, Bool, Float, Float32, Bytes, a structure with a \
    `Flat` instance, an array, or a pair"

def tyOf (type : Lean.Expr) : MetaM Ty := return (← shapeOf type).ty

/-- Whether `type` is a sum whose `Flat` tuple holds heap values.  A variable of such a sum stays
whole, since the sum cannot be rebuilt from its tuple, and a match destructures it. -/
def heapSum? (type : Lean.Expr) : MetaM Bool := do
  if (← sumName? type).isNone then return false
  return !((← shapeOf type).ty matches .elem _)

/-- The steps to field `i` of a structure value in its flattening, if the type is a structure
with a `Flat` instance. -/
def fieldPath? (type : Lean.Expr) (i : Nat) : MetaM (Option (List Bool)) := do
  let some (ctor, _) ← structOf? type | return none
  let some (β, inst) ← flatInstance? type | return none
  let tree ← flatTree "verified_compile" type β inst ctor
  return (tree.find? (·.1 == i)).map (·.2)

/-- Field `i` and the structure value `p` of a structure projection `e`. -/
def structProj? (e : Lean.Expr) : MetaM (Option (Nat × Lean.Expr)) := do
  if let .proj _ i p := e then return some (i, p)
  let .const fn _ := e.getAppFn | return none
  let some info ← getProjectionFnInfo? fn | return none
  if info.fromClass then return none
  let args := e.getAppArgs
  unless args.size == info.numParams + 1 do return none
  return some (info.i, args[info.numParams]!)

/-- The source value of a Lean term: its flattening. -/
def flatValue (e : Lean.Expr) : MetaM Lean.Expr := return (← shapeOf (← inferType e)).apply e

def listExpr (α : Lean.Expr) : List Lean.Expr → Lean.Expr
  | [] => mkApp (mkConst ``List.nil [Level.zero]) α
  | x :: xs => mkApp3 (mkConst ``List.cons [Level.zero]) α x (listExpr α xs)

def ctxExpr (Γ : List Ty) : Lean.Expr := listExpr (mkConst ``Ty) (Γ.map tyExpr)

def finiteFn (type : Lean.Expr) (values : List Lean.Expr) : MetaM Lean.Expr :=
  mkAppOptM ``List.get #[some type, some (listExpr type values)]

def finiteIndex (n i : Nat) : MetaM Lean.Expr := do
  mkAppM ``Fin.mk #[mkNatLit i, ← mkDecideProof (← mkLt (mkNatLit i) (mkNatLit n))]

partial def finiteForall (n : Nat) (P : Lean.Expr) (prove : Lean.Expr → MetaM Lean.Expr) :
    MetaM Lean.Expr := do
  if n == 0 then
    withLocalDeclD `i (mkApp (mkConst ``Fin) (mkNatLit 0)) fun i => do
      mkLambdaFVars #[i] (mkApp2 (mkConst ``Fin.elim0 [Level.zero]) (mkApp P i) i)
  else
    let first ← prove (← finiteIndex n 0)
    let rest ← withLocalDeclD `i (mkApp (mkConst ``Fin) (mkNatLit (n - 1))) fun i => do
      let shifted ← mkLambdaFVars #[i] (mkApp P (← mkAppM ``Fin.succ #[i]))
      finiteForall (n - 1) shifted fun j => do prove (← mkAppM ``Fin.succ #[j])
    mkAppOptM ``Fin.cases #[some (mkNatLit (n - 1)), some P, some first, some rest]

/-- The context `t :: Γ` for the expression `Γ` of a context, which it shares. -/
def consCtx (t : Ty) (Γ : Lean.Expr) : Lean.Expr :=
  mkApp3 (mkConst ``List.cons [Level.zero]) (mkConst ``Ty) (tyExpr t) Γ

def modeExpr : Mode → Lean.Expr
  | .borrowed => mkConst ``Mode.borrowed
  | .owned => mkConst ``Mode.owned

def modesExpr (modes : List Mode) : Lean.Expr := listExpr (mkConst ``Mode) (modes.map modeExpr)

def sigExpr (g : Sig) : Lean.Expr :=
  mkApp5 (mkConst ``Sig.mk) (ctxExpr g.params) (tyExpr g.result) (toExpr g.aborts)
    (modesExpr g.modes) (toExpr g.depth)

/-- The allocation bound `p.g.bound` of a listed definition; when its code takes the call depth,
its frames condition `p.g.fits`, both of which then take the frames available before the
arguments; and the name of `p.g.bound_eq` when the equation gives a numeral, which a caller's bound
then shows. -/
structure CalleeBound where
  bound : Name
  fits? : Option Name := none
  numeralEq : Option Name := none
  /-- For a function with a paid parameter, whose entry `bound` is `base.cost`, `base.bound`: the
  credits plus the entry. -/
  credited? : Option Name := none
  deriving Inhabited

/-- A listed definition that a later one may call: its name, its signature, its equation
`∀ args, Func.denote … = name args`, and its bound. -/
structure Callee where
  name : Name
  sig : Sig
  denoteEq : Name
  bound : CalleeBound

/-- The bounds and frames conditions of the functions that a definition's body may call, with
`fuel` frames available to the calls: those of the functions `prog` before the definition, with
signatures `sigs` and meanings `funs`, and, in a recursive definition, the definition's own first,
its signature with its bound and frames condition at `fuel`. -/
structure Tables where
  sigs : Lean.Expr
  prog : Lean.Expr
  funs : Lean.Expr
  fuel : Lean.Expr
  self : Option (Lean.Expr × Lean.Expr × Lean.Expr) := none
  /-- In a recursive definition, the flags of the definition and of the functions before it. -/
  selfFlags : Option Lean.Expr := none

/-- `Prog.boundsAt` or `Prog.fitsAt` of the functions before the definition, at `fuel`. -/
def Tables.rest (t : Tables) (fits : Bool) : Lean.Expr :=
  mkAppN (mkConst (if fits then ``Prog.fitsAt else ``Prog.boundsAt))
    #[t.sigs, t.prog, t.funs, t.fuel]

/-- The flags of the functions that the body may call. -/
def Tables.flags (t : Tables) : Lean.Expr :=
  t.selfFlags.getD (mkApp2 (mkConst ``Prog.flags) t.sigs t.prog)

/-- The bounds, or the frames conditions, of the functions that the body may call. -/
def Tables.table (t : Tables) (fits : Bool) : Lean.Expr :=
  match t.self with
  | none => t.rest fits
  | some (g, b, fi) =>
    mkAppN (mkConst (if fits then ``Fits.cons else ``Bounds.cons))
      #[t.sigs, g, if fits then fi else b, t.rest fits]

/-- The functions an expression may call, the Lean functions they mean, the definitions behind
them, variable 0 of `sigs` first, the variables in scope with their types, variable 0 first, the
environment of their values, and the bounds and frames conditions of the functions. -/
structure Ctx where
  /-- The program's name, under which the reflector adds the theorems it shares between
  definitions. -/
  base : Name
  sigs : Lean.Expr
  funs : Lean.Expr
  callees : List Callee
  vars : List (Lean.Expr × Ty)
  env : Lean.Expr
  ctx : Lean.Expr
  tables : Tables

/-- `Expr.denote funs e env`. -/
def denoteExpr (c : Ctx) (e : Lean.Expr) : MetaM Lean.Expr :=
  mkAppM ``Expr.denote #[c.funs, e, c.env]

/-- The proof by `rfl` that `e` means `lean`. -/
def rflProof (c : Ctx) (e lean : Lean.Expr) : MetaM Lean.Expr := do
  mkExpectedTypeHint (← mkEqRefl lean) (← mkEq (← denoteExpr c e) lean)

def binOp? : Name → Option Lean.Expr
  | ``HAdd.hAdd => some (mkConst ``BinOp.add)
  | ``HSub.hSub => some (mkConst ``BinOp.sub)
  | ``HMul.hMul => some (mkConst ``BinOp.mul)
  | ``HDiv.hDiv => some (mkConst ``BinOp.div)
  | ``HMod.hMod => some (mkConst ``BinOp.rem)
  | ``HAnd.hAnd => some (mkConst ``BinOp.and)
  | ``HOr.hOr => some (mkConst ``BinOp.or)
  | ``HXor.hXor => some (mkConst ``BinOp.xor)
  | ``HShiftLeft.hShiftLeft => some (mkConst ``BinOp.shl)
  | ``HShiftRight.hShiftRight => some (mkConst ``BinOp.shr)
  | _ => none

def fbinOp? : Name → Option Lean.Expr
  | ``HAdd.hAdd => some (mkConst ``FBinOp.add)
  | ``HSub.hSub => some (mkConst ``FBinOp.sub)
  | ``HMul.hMul => some (mkConst ``FBinOp.mul)
  | ``HDiv.hDiv => some (mkConst ``FBinOp.div)
  | _ => none

def isFloat (α : Lean.Expr) : MetaM Bool := do
  let α ← whnfR α
  return α.isConstOf ``Float || α.isConstOf ``Float32

/-- A comparison of floats as a `Prop`: its operation and its operands, with `>` and `≥` as `<`
and `≤` on swapped operands.  `=` and `≠` on floats compare bit patterns, which `==` and `!=` do
not, and the reflector rejects them. -/
def fcomparison? (p : Lean.Expr) : MetaM (Option (FCmpOp × Lean.Expr × Lean.Expr)) := do
  match p.consumeMData.getAppFnArgs with
  | (``LT.lt, #[α, _, a, b]) => if ← isFloat α then return some (.lt, a, b) else return none
  | (``LE.le, #[α, _, a, b]) => if ← isFloat α then return some (.le, a, b) else return none
  | (``GT.gt, #[α, _, a, b]) => if ← isFloat α then return some (.lt, b, a) else return none
  | (``GE.ge, #[α, _, a, b]) => if ← isFloat α then return some (.le, b, a) else return none
  | (``Eq, #[α, _, _]) | (``Ne, #[α, _, _]) =>
    if ← isFloat α then
      throwError "verified_compile: = and ≠ on {α} compare bit patterns; use == and !="
    return none
  | _ => return none

def fcmpExpr : FCmpOp → Lean.Expr
  | .lt => mkConst ``FCmpOp.lt
  | .le => mkConst ``FCmpOp.le
  | .eq => mkConst ``FCmpOp.eq

/-- The value of a word literal. -/
def wordLit? (e : Lean.Expr) : MetaM (Option UInt64) := do
  let (``OfNat.ofNat, #[α, n, _]) := e.consumeMData.getAppFnArgs | return none
  unless (← whnfR α).isConstOf ``UInt64 do return none
  return (natOf (← instantiateMVars n)).map UInt64.ofNat

def bytesLit? (e : Lean.Expr) : MetaM (Option (List UInt8)) := do
  if e.hasFVar || e.hasLooseBVars then return none
  unless (← whnfR (← inferType e)).isConstOf ``LeanExe.Bytes do return none
  let (``LeanExe.Bytes.mk, #[data]) := (← whnfR e).getAppFnArgs | return none
  let (``ByteArray.mk, #[data]) := (← whnfR data).getAppFnArgs | return none
  return (← getArrayLitOf? data getUInt8Value?).map Array.toList

/-- The bit pattern of a float literal: a scientific or natural literal, `Float.ofBits` or
`UInt64.toFloat` of a word literal, or the negation of a float literal.  Lean's model has one
NaN, so `Float.ofBits` and the negation give the canonical NaN for a NaN.  The kernel checks the
bits. -/
partial def floatLit? (e : Lean.Expr) : MetaM (Option UInt64) := do
  let canonical (w : UInt64) := if Wasm.IEEE64.isNaN w then Wasm.IEEE64.canonicalNaN else w
  match e.consumeMData.getAppFnArgs with
  | (``OfScientific.ofScientific, #[_, _, m, sgn, ex]) =>
    let some m := natOf (← instantiateMVars m) | return none
    let some ex := natOf (← instantiateMVars ex) | return none
    if sgn.isConstOf ``Bool.true then return some (Float.ofScientific m true ex).toBits
    if sgn.isConstOf ``Bool.false then return some (Float.ofScientific m false ex).toBits
    return none
  | (``OfNat.ofNat, #[_, n, _]) =>
    let some n := natOf (← instantiateMVars n) | return none
    return some (Float.ofNat n).toBits
  | (``Float.ofBits, #[w]) => return (← wordLit? w).map canonical
  | (``UInt64.toFloat, #[w]) => return (← wordLit? w).map Wasm.IEEE64.convertI64U
  | (``Neg.neg, #[_, _, x]) =>
    return (← floatLit? x).map fun b => canonical (b ^^^ 0x8000000000000000)
  | _ => return none

def word32Lit? (e : Lean.Expr) : MetaM (Option UInt32) := do
  let (``OfNat.ofNat, #[α, n, _]) := e.consumeMData.getAppFnArgs | return none
  unless (← whnfR α).isConstOf ``UInt32 do return none
  return (natOf (← instantiateMVars n)).map UInt32.ofNat

partial def float32Lit? (e : Lean.Expr) : MetaM (Option UInt32) := do
  let canonical (w : UInt32) := if Wasm.IEEE32.isNaN w then Wasm.IEEE32.canonicalNaN else w
  match e.consumeMData.getAppFnArgs with
  | (``OfScientific.ofScientific, #[_, _, m, sgn, ex]) =>
    let some m := natOf (← instantiateMVars m) | return none
    let some ex := natOf (← instantiateMVars ex) | return none
    if sgn.isConstOf ``Bool.true then return some (Float32.ofScientific m true ex).toBits
    if sgn.isConstOf ``Bool.false then return some (Float32.ofScientific m false ex).toBits
    return none
  | (``OfNat.ofNat, #[_, n, _]) =>
    let some n := natOf (← instantiateMVars n) | return none
    return some (Float32.ofNat n).toBits
  | (``Float32.ofBits, #[w]) => return (← word32Lit? w).map canonical
  | (``UInt64.toFloat32, #[w]) => return (← wordLit? w).map Wasm.IEEE32.convertI64U
  | (``Neg.neg, #[_, _, x]) =>
    return (← float32Lit? x).map fun b => canonical (b ^^^ 0x80000000)
  | _ => return none

/-- A comparison of words as a `Prop`: its operation and its operands, with `>` and `≥` as `<`
and `≤` on swapped operands. -/
def comparison? (p : Lean.Expr) : MetaM (Option (CmpOp × Lean.Expr × Lean.Expr)) := do
  let p := p.consumeMData
  let isWord (α : Lean.Expr) : MetaM Bool := return (← whnfR α).isConstOf ``UInt64
  match p.getAppFnArgs with
  | (``LT.lt, #[α, _, a, b]) => if ← isWord α then return some (.lt, a, b) else return none
  | (``LE.le, #[α, _, a, b]) => if ← isWord α then return some (.le, a, b) else return none
  | (``GT.gt, #[α, _, a, b]) => if ← isWord α then return some (.lt, b, a) else return none
  | (``GE.ge, #[α, _, a, b]) => if ← isWord α then return some (.le, b, a) else return none
  | (``Eq, #[α, a, b]) => if ← isWord α then return some (.eq, a, b) else return none
  | (``Ne, #[α, a, b]) => if ← isWord α then return some (.ne, a, b) else return none
  | _ => return none

def cmpExpr : CmpOp → Lean.Expr
  | .eq => mkConst ``CmpOp.eq
  | .ne => mkConst ``CmpOp.ne
  | .lt => mkConst ``CmpOp.lt
  | .le => mkConst ``CmpOp.le

def iteLemma : CmpOp → Name
  | .eq => ``ite_eqP_eq
  | .ne => ``ite_ne_eq
  | .lt => ``ite_lt_eq
  | .le => ``ite_le_eq

/-- The context of the variables `vars` and `Env.cons v₀ (… (Env.cons vₙ Env.nil))`, with each
context built once and shared by the longer ones. -/
def ctxEnvExpr : List (Lean.Expr × Ty) → MetaM (Lean.Expr × Lean.Expr)
  | [] => return (ctxExpr [], mkConst ``Env.nil)
  | (x, t) :: rest => do
    let (ctx, env) ← ctxEnvExpr rest
    return (consCtx t ctx,
      ← mkAppOptM ``Env.cons #[some ctx, some (tyExpr t), some (← flatValue x), some env])

/-- `Env.cons v₀ (… (Env.cons vₙ Env.nil))` for the variables `vars`. -/
def envExpr (vars : List (Lean.Expr × Ty)) : MetaM Lean.Expr :=
  return (← ctxEnvExpr vars).2

/-- The word family of record constructor `r` with the values `values` of their elements: for a
shape whose fields are words and children, the list of the words, and otherwise
`TreeShape.wordsOf`, which states each word's element. -/
def wordFamily (shapeValue : TreeShape) (r : Fin shapeValue.records)
    (values : List (Elem × Lean.Expr)) : MetaM Lean.Expr := do
  let shape := treeShapeExpr shapeValue
  let record := recordExpr shapeValue r
  if shapeValue.allWords then
    return ← mkExpectedTypeHint (← finiteFn (mkConst ``UInt64) (values.map (·.2)))
      (← mkArrow (mkApp (mkConst ``Fin) (← mkAppM ``TreeShape.words #[shape, record]))
        (mkConst ``UInt64))
  let sigma := mkApp2 (mkConst ``Sigma [.zero, .zero]) (mkConst ``Elem) (mkConst ``Elem.denote)
  let entries := values.map fun (e, v) =>
    mkApp4 (mkConst ``Sigma.mk [.zero, .zero]) (mkConst ``Elem) (mkConst ``Elem.denote)
      (toExpr e) v
  return mkApp3 (mkConst ``TreeShape.wordsOf) shape record (listExpr sigma entries)

/-- The family of the word expressions `exprs` of a construction of record constructor `r`, of
the elements of the fields, in the form of `wordFamily`. -/
def exprFamily (c : Ctx) (shapeValue : TreeShape) (r : Fin shapeValue.records)
    (exprs : List (Elem × Lean.Expr)) : MetaM Lean.Expr := do
  let shape := treeShapeExpr shapeValue
  let record := recordExpr shapeValue r
  let sourceType (t : Ty) := mkApp3 (mkConst ``Expr) c.sigs c.ctx (tyExpr t)
  if shapeValue.allWords then
    -- The type that `Expr.treeNode` states, whose word types reduce to `Ty.word`.
    let fin := mkApp (mkConst ``Fin) (← mkAppM ``TreeShape.words #[shape, record])
    let type ← withLocalDeclD `i fin fun i => do
      mkForallFVars #[i] (mkApp3 (mkConst ``Expr) c.sigs c.ctx
        (← mkAppM ``TreeShape.wordTy #[shape, record, i]))
    return ← mkExpectedTypeHint (← finiteFn (sourceType .word) (exprs.map (·.2))) type
  let family ← withLocalDeclD `e (mkConst ``Elem) fun e => do
    mkLambdaFVars #[e] (mkApp3 (mkConst ``Expr) c.sigs c.ctx (mkApp (mkConst ``Ty.elem) e))
  let sigma := mkApp2 (mkConst ``Sigma [.zero, .zero]) (mkConst ``Elem) family
  let entries := exprs.map fun (e, x) =>
    mkApp4 (mkConst ``Sigma.mk [.zero, .zero]) (mkConst ``Elem) family (toExpr e) x
  return mkAppN (mkConst ``TreeShape.exprsOf) #[c.sigs, c.ctx, shape, record,
    listExpr sigma entries]

/-- `noFields` over the index type `Fin count`, which is empty, of the motive `motive`. -/
def emptyFamily (count motive : Lean.Expr) : MetaM Lean.Expr := do
  mkAppOptM ``noFields
    #[some count, some (← mkDecideProof (← mkEq count (mkNatLit 0))), some motive]

/-- The array family of record constructor `r` with the arrays `values` of their elements:
`TreeShape.arraysOf`, or `noFields` for a record constructor without array fields. -/
def arrayFamily (shapeValue : TreeShape) (r : Fin shapeValue.records)
    (values : List (Elem × Lean.Expr)) : MetaM Lean.Expr := do
  let shape := treeShapeExpr shapeValue
  let record := recordExpr shapeValue r
  let arrayOf (e : Lean.Expr) : Lean.Expr :=
    mkApp (mkConst ``Array [.zero]) (mkApp (mkConst ``Elem.denote) e)
  if values.isEmpty then
    let count ← mkAppM ``TreeShape.arrays #[shape, record]
    let motive ← withLocalDeclD `i (mkApp (mkConst ``Fin) count) fun i => do
      mkLambdaFVars #[i] (arrayOf (← mkAppM ``TreeShape.arrayElem #[shape, record, i]))
    return ← emptyFamily count motive
  let family ← withLocalDeclD `e (mkConst ``Elem) fun e => mkLambdaFVars #[e] (arrayOf e)
  let sigma := mkApp2 (mkConst ``Sigma [.zero, .zero]) (mkConst ``Elem) family
  let entries := values.map fun (e, v) =>
    mkApp4 (mkConst ``Sigma.mk [.zero, .zero]) (mkConst ``Elem) family (toExpr e) v
  return mkApp3 (mkConst ``TreeShape.arraysOf) shape record (listExpr sigma entries)

/-- The buffer family of record constructor `r` with the buffers `values`, or `noFields` for a
record constructor without buffer fields. -/
def bufferFamily (shapeValue : TreeShape) (r : Fin shapeValue.records)
    (values : List Lean.Expr) : MetaM Lean.Expr := do
  let count ← mkAppM ``TreeShape.buffers #[treeShapeExpr shapeValue, recordExpr shapeValue r]
  if values.isEmpty then
    return ← emptyFamily count (← withLocalDeclD `i (mkApp (mkConst ``Fin) count) fun i =>
      mkLambdaFVars #[i] (mkConst ``LeanExe.Bytes))
  mkExpectedTypeHint (← finiteFn (mkConst ``LeanExe.Bytes) values)
    (← mkArrow (mkApp (mkConst ``Fin) count) (mkConst ``LeanExe.Bytes))

/-- The family of the array expressions `exprs` of a construction of record constructor `r`, of
the elements of the fields, in the form of `arrayFamily`. -/
def arrayExprFamily (c : Ctx) (shapeValue : TreeShape) (r : Fin shapeValue.records)
    (exprs : List (Elem × Lean.Expr)) : MetaM Lean.Expr := do
  let shape := treeShapeExpr shapeValue
  let record := recordExpr shapeValue r
  if exprs.isEmpty then
    let count ← mkAppM ``TreeShape.arrays #[shape, record]
    let motive ← withLocalDeclD `i (mkApp (mkConst ``Fin) count) fun i => do
      mkLambdaFVars #[i] (mkApp3 (mkConst ``Expr) c.sigs c.ctx
        (← mkAppM ``TreeShape.arrayTy #[shape, record, i]))
    return ← emptyFamily count motive
  let family ← withLocalDeclD `e (mkConst ``Elem) fun e => do
    mkLambdaFVars #[e] (mkApp3 (mkConst ``Expr) c.sigs c.ctx (mkApp (mkConst ``Ty.array) e))
  let sigma := mkApp2 (mkConst ``Sigma [.zero, .zero]) (mkConst ``Elem) family
  let entries := exprs.map fun (e, x) =>
    mkApp4 (mkConst ``Sigma.mk [.zero, .zero]) (mkConst ``Elem) family (toExpr e) x
  return mkAppN (mkConst ``TreeShape.arrayExprsOf) #[c.sigs, c.ctx, shape, record,
    listExpr sigma entries]

/-- The family of the buffer expressions `exprs` of a construction of record constructor `r`, or
`noFields` for a record constructor without buffer fields. -/
def bufferExprFamily (c : Ctx) (shapeValue : TreeShape) (r : Fin shapeValue.records)
    (exprs : List Lean.Expr) : MetaM Lean.Expr := do
  let count ← mkAppM ``TreeShape.buffers #[treeShapeExpr shapeValue, recordExpr shapeValue r]
  let exprType := mkApp3 (mkConst ``Expr) c.sigs c.ctx (mkConst ``Ty.bytes)
  if exprs.isEmpty then
    return ← emptyFamily count (← withLocalDeclD `i (mkApp (mkConst ``Fin) count) fun i =>
      mkLambdaFVars #[i] exprType)
  mkExpectedTypeHint (← finiteFn exprType exprs)
    (← mkArrow (mkApp (mkConst ``Fin) count) exprType)

/-- The words of a field `x` of the kind `kind`, each with its element: the field itself for a
word field, and the leaves of its flattening for a flat field. -/
def nativeWords (x : Lean.Expr) : NativeField → MetaM (List (Elem × Lean.Expr))
  | .child | .array _ | .bytes => pure []
  | .leaf e => pure [(e, x)]
  | .flat _ leaves => leaves.mapM fun (e, segments) => return (e, ← leafTerm x segments)

/-- The component of the flattening of `x` along `steps`: a pair takes a step, and a value of a
type with a `Flat` instance is its tuple, down to a word, a `Bool`, a float, or a pair.  At a leaf
it is the leaf's term. -/
partial def componentTerm (x : Lean.Expr) (steps : List Bool) : MetaM Lean.Expr := do
  let type ← withReducible (whnf (← inferType x))
  if (fieldElem? type).isSome then return x
  if let (``Prod, #[_, _]) := type.getAppFnArgs then
    let step :: rest := steps | return x
    return ← componentTerm (← mkAppM (if step then ``Prod.snd else ``Prod.fst) #[x]) rest
  if (← flatInstance? type).isNone then return x
  componentTerm (← flatTerm x) steps

/-- Runs `k` with the variables of a match's branch on record constructor `r`: the header, then
each word, then each child, then each array, then each buffer.  The fields `natives` are the
constructor's fields with their types.
A flat field is one Lean variable, and the branch holds a variable for each leaf of its tuple,
keyed in the context by the leaf's projection of the field. -/
def withTreeCaseFields {α : Type} (c : Ctx) (shapeValue : TreeShape)
    (r : Fin shapeValue.records) (natives : List (Lean.Expr × NativeField))
    (k : Ctx → Array Lean.Expr → MetaM α) : MetaM α := do
  let shape := treeShapeExpr shapeValue
  let record := recordExpr shapeValue r
  let ctx ← mkAppM ``TreeShape.context #[shape, record, c.ctx]
  let marker ← mkAppOptM ``TreeHeader.unit #[some shape, some record]
  let decls := natives.toArray.mapIdx fun i (type, _) => (Name.mkSimple s!"field{i}", type)
  let rec bindFields (decls : List (Name × Lean.Expr)) (fields : Array Lean.Expr)
      (body : Array Lean.Expr → MetaM α) : MetaM α :=
    match decls with
    | [] => body fields
    | (name, type) :: rest =>
      withLocalDeclD name type fun field => bindFields rest (fields.push field) body
  bindFields decls.toList #[] fun fields => do
    let values := fields.toList.zip (natives.map (·.2))
    let words := (← values.mapM fun (x, kind) => do
      return (← nativeWords x kind).map fun (e, w) => (w, e)).flatten
    let children := values.filterMap fun (x, kind) =>
      if kind matches .child then some x else none
    let wordFn ← wordFamily shapeValue r (← words.mapM fun (w, e) => do
      return (e, ← flatValue w))
    let childFn ← mkExpectedTypeHint
      (← finiteFn (mkApp (mkConst ``Tree) shape) (← children.mapM flatValue))
      (← mkArrow (mkApp (mkConst ``Fin) (← mkAppM ``TreeShape.children #[shape, record]))
        (mkApp (mkConst ``Tree) shape))
    let arrays := values.filterMap fun (x, kind) => match kind with
      | .array e => some (x, e)
      | _ => none
    let arrayFn ← arrayFamily shapeValue r (← arrays.mapM fun (x, e) => do
      return (e, ← flatValue x))
    let buffers := values.filterMap fun (x, kind) =>
      if kind matches .bytes then some x else none
    let bufferFn ← bufferFamily shapeValue r (← buffers.mapM flatValue)
    let env ← mkAppM ``Env.treeFields
      #[shape, record, wordFn, arrayFn, bufferFn, childFn, c.env]
    let vars := [(marker, .treeHeader shapeValue r)] ++
      words.map (fun (w, e) => (w, Ty.elem e)) ++ children.map (·, Ty.tree shapeValue) ++
      arrays.map (fun (x, e) => (x, Ty.array e)) ++ buffers.map (·, Ty.bytes) ++ c.vars
    let inner := { c with ctx, env, vars }
    k inner fields

def withListCaseFields {α : Type} (c : Ctx) (xs : Lean.Expr)
    (k : Ctx → Lean.Expr → Lean.Expr → MetaM α) : MetaM α := do
  withTreeCaseFields c listShape listCell
    [(mkConst ``UInt64, .leaf .word), (← inferType xs, .child)]
    fun inner fields => k inner fields[0]! fields[1]!

def withRecursiveCaseFields {α : Type} (c : Ctx) (layout : RecursiveLayout)
    (r : Fin layout.shape.records) (k : Ctx → Array Lean.Expr → MetaM α) : MetaM α :=
  withTreeCaseFields c layout.shape r ((layout.recordCtor r).2.map fun
    | .child => (mkConst layout.name, .child)
    | .leaf e => (elemType e, .leaf e)
    | .flat type leaves => (type, .flat type leaves)
    | .array e => (mkApp (mkConst ``Array [.zero]) (elemType e), .array e)
    | .bytes => (mkConst ``LeanExe.Bytes, .bytes)) k

/-- `e` with each projection of a pair `(a, b)` or of a structure's constructor at its head
replaced by the component, and each pair `(y.1, y.2)` of the components of `y` replaced by `y`,
from the inside out.  Each step is a reduction or eta for pairs, so the result is equal to `e` by
`rfl`. -/
partial def projReduce (e : Lean.Expr) : MetaM Lean.Expr := do
  let e := e.consumeMData.headBeta
  match e.getAppFnArgs with
  | (``Prod.fst, #[_, _, p]) => match (← projReduce p).getAppFnArgs with
    | (``Prod.mk, #[_, _, a, _]) => projReduce a
    | _ => return e
  | (``Prod.snd, #[_, _, p]) => match (← projReduce p).getAppFnArgs with
    | (``Prod.mk, #[_, _, _, b]) => projReduce b
    | _ => return e
  | (``Prod.mk, #[α, β, a, b]) =>
    let a ← projReduce a
    let b ← projReduce b
    if let (``Prod.fst, #[_, _, y]) := a.getAppFnArgs then
      if let (``Prod.snd, #[_, _, y']) := b.getAppFnArgs then
        if y == y' then return y
    return mkApp4 e.getAppFn α β a b
  | _ =>
    let some (i, p) ← structProj? e | return e
    let p ← projReduce p
    let .const k _ := p.getAppFn | return e
    let some (.ctorInfo ctor) := (← getEnv).find? k | return e
    unless p.getAppNumArgs == ctor.numParams + ctor.numFields do return e
    projReduce (p.getArg! (ctor.numParams + i))

/-- The `Flat` tuple of the fields of `e`, an application of a structure's constructor, built
along the tuple tree of its instance. -/
partial def ctorTuple? (e : Lean.Expr) : MetaM (Option Lean.Expr) := do
  let .const ctorName _ := e.getAppFn | return none
  let some (.ctorInfo ctor) := (← getEnv).find? ctorName | return none
  let type ← inferType e
  let some (ctor', _) ← structOf? type | return none
  unless ctor'.name == ctor.name do return none
  let args := e.getAppArgs
  unless args.size == ctor.numParams + ctor.numFields do return none
  let some (β, inst) ← flatInstance? type | return none
  let tree ← flatTree "verified_compile" type β inst ctor
  let fields := args.extract ctor.numParams args.size
  let rec build (pre : List Bool) (ty : Lean.Expr) : MetaM Lean.Expr := do
    if let some (i, _) := tree.find? (·.2 == pre.reverse) then return fields[i]!
    let ty ← whnfR ty
    let (``Prod, #[a, b]) := ty.getAppFnArgs
      | throwError "verified_compile: the `Flat` instance of {type} is not a tuple of its fields"
    mkAppM ``Prod.mk #[← build (false :: pre) a, ← build (true :: pre) b]
  return some (← build [] β)

/-- The leaf with segments `segments` of a value whose tuple is `tuple`, with the tuple of each
structure's constructor in place of its `Flat.flat`, so that the reflector reads the constructor's
fields. -/
partial def tupleLeaf (tuple : Lean.Expr) : List (List Bool) → MetaM Lean.Expr
  | [] => pure tuple
  | [steps] => do projReduce (← stepsTerm tuple steps)
  | steps :: rest => do
    let t ← projReduce (← stepsTerm tuple steps)
    tupleLeaf (← match ← ctorTuple? t with
      | some u => pure u
      | none => flatTerm t) rest

/-- Whether a Lean term reflects to a place: a variable, a pair of places, or a structure's
constructor whose tuple of fields is a place, as `reflectStruct?` reflects it. -/
partial def isPlace (e : Lean.Expr) : MetaM Bool := do
  let e ← projReduce e
  if e.isFVar then return true
  if let (``Prod.mk, #[_, _, a, b]) := e.getAppFnArgs then
    return (← isPlace a) && (← isPlace b)
  if let some tuple ← ctorTuple? e then return ← isPlace tuple
  return false

/-- `fn args`, with each argument that `bind` marks bound by a `let` around the application, in
order.  The result is equal to `fn args` by `zeta`. -/
def bindArgs (fn : Lean.Expr) : List Lean.Expr → List Bool → Array Lean.Expr → Array Lean.Expr →
    MetaM Lean.Expr
  | [], _, newArgs, fvars => mkLetFVars fvars (mkAppN fn newArgs)
  | a :: as, b :: bs, newArgs, fvars => do
    if b then
      withLetDecl `a (← inferType a) a fun x => bindArgs fn as bs (newArgs.push x) (fvars.push x)
    else bindArgs fn as bs (newArgs.push a) fvars
  | a :: as, [], newArgs, fvars => bindArgs fn as [] (newArgs.push a) fvars

/-- The source variable whose key in the context is `key`, and its type.  The key of a variable
is its Lean variable, or, for a leaf of a flat field of a matched record, the leaf's projection of
the field. -/
def keyVar? (c : Ctx) (key : Lean.Expr) : MetaM (Option (Lean.Expr × Ty)) := do
  let some i := c.vars.findIdx? (·.1 == key) | return none
  let some (_, t) := c.vars[i]? | return none
  let proof ← mkEqRefl (mkApp (mkConst ``Option.some [Level.zero]) (mkConst ``Ty) |>.app
    (tyExpr t))
  return some (← mkAppOptM ``Var.ofIndex
    #[some (tyExpr t), some c.ctx, some (toExpr i), some proof], t)

/-- The source variable for the Lean variable `e` in scope, and its type. -/
def varOf (c : Ctx) (e : Lean.Expr) : MetaM (Lean.Expr × Ty) := do
  let some v ← keyVar? c e | throwError "verified_compile: {e} is not a variable in scope"
  return v

/-- `Eq.trans p q` with the middle term of `p`.  The elaborator does not unify the two middle
terms; the kernel checks that `q`'s left side is the same term, which the reflector arranges up to
beta reduction. -/
def transHint (p q : Lean.Expr) : MetaM Lean.Expr := do
  let some (α, a, b) := (← inferType p).eq? | throwError "verified_compile: the equation {p}"
  let some (_, _, c) := (← inferType q).eq? | throwError "verified_compile: the equation {q}"
  return mkApp6 (mkConst ``Eq.trans [← getLevel α]) α a b c p
    (← mkExpectedTypeHint q (← mkEq b c))

/-- The reference to function `j` of the signatures `sigs`, a list of `Sig` literals, as a chain
of `FVar.there` around `FVar.here`. -/
partial def fvarAt (sigs : Lean.Expr) (j : Nat) : MetaM Lean.Expr := do
  let (``List.cons, #[_, h, rest]) := sigs.getAppFnArgs
    | throwError "verified_compile: no function {j} in {sigs}"
  if j == 0 then return mkApp2 (mkConst ``FVar.here) h rest
  let inner ← fvarAt rest (j - 1)
  let .app (.app _ _) g := (← inferType inner)
    | throwError "verified_compile: the reference {inner}"
  return mkApp4 (mkConst ``FVar.there) rest g h inner

/-- The proof that `funs.get fv env` is `F env` for the meaning `F` of the function that `fv`
names, by `Funs.get_there` and `Funs.get_here`, for `funs` a chain of `Funs.cons`. -/
partial def getChain (funs fv env : Lean.Expr) : MetaM Lean.Expr := do
  let (``Funs.cons, #[S, h, F, rest]) := funs.getAppFnArgs
    | throwError "verified_compile: the meanings {funs}"
  match fv.getAppFnArgs with
  | (``FVar.here, _) => return mkAppN (mkConst ``Funs.get_here) #[S, h, F, rest, env]
  | (``FVar.there, #[_, g, _, v]) =>
    transHint (mkAppN (mkConst ``Funs.get_there) #[S, g, h, F, rest, v, env])
      (← getChain rest v env)
  | _ => throwError "verified_compile: the function reference {fv}"

def addDefinition (name : Name) (type value : Lean.Expr) : CoreM Unit :=
  addAndCompile <| .defnDecl <|
    mkDefinitionValEx name [] type value (.regular 1) .safe [name]

def addTheorem (name : Name) (type value : Lean.Expr) : CoreM Unit :=
  addDecl <| .thmDecl { name, levelParams := [], type, value }

/-- A definition for the kernel only, without compiled code, for the literal bytes of a module. -/
def addLiteral (name : Name) (type value : Lean.Expr) : CoreM Unit :=
  addDecl <| .defnDecl <| mkDefinitionValEx name [] type value (.regular 1) .safe [name]

unsafe def evalModuleUnsafe (env : Environment) (opts : Options) (name : Name) :
    Except String Wasm.Module :=
  env.evalConst Wasm.Module opts name

/-- The module of the constant `name`, from its compiled code. -/
@[implemented_by evalModuleUnsafe]
opaque evalModule (env : Environment) (opts : Options) (name : Name) : Except String Wasm.Module

/-- The component of the tuple `x` along `steps`: `false` for a pair's first component and `true`
for its second. -/
def tuplePath (x : Lean.Expr) : List Bool → MetaM Lean.Expr
  | [] => return x
  | false :: rest => do tuplePath (← mkAppM ``Prod.fst #[x]) rest
  | true :: rest => do tuplePath (← mkAppM ``Prod.snd #[x]) rest

/-- A pair or a record that holds arrays, viewed as a pair for its destructuring: the component
types `α` and `β` of `α × β` or of the record's `Flat` tuple, the value built from components `a`
and `b`, the pair `pair p` of a value `p`, `p` itself or `Flat.flat p`, and the proof `eta B v` of
`B (rebuild (pair v).1 (pair v).2) = B v`. -/
structure PairView where
  α : Lean.Expr
  β : Lean.Expr
  rebuild : Lean.Expr → Lean.Expr → MetaM Lean.Expr
  pair : Lean.Expr → Lean.Expr
  eta : Lean.Expr → Lean.Expr → MetaM Lean.Expr

/-- The view of `type` as a pair.  A pair's eta is `pair_eta`.  A record's is the theorem
`base.flat_eta.R`, added once per program and record type and proved by `rfl` with `B` and `v`
free, so that the kernel unfolds only the `Flat` instance and structure eta, never the terms that
`B` and `v` stand for.  A sum that holds heap values has the components of its tuple, for the costs
of its parts, and neither a rebuild nor an eta law. -/
def pairView (base : Name) (type : Lean.Expr) : MetaM PairView := do
  let type ← whnfR type
  if let (``Prod, #[α, β]) := type.getAppFnArgs then
    return ⟨α, β, fun a b => mkAppM ``Prod.mk #[a, b], id, fun B v => mkAppM ``pair_eta #[B, v]⟩
  if ← heapSum? type then
    -- A sum's components are those of its tuple, and nothing rebuilds the sum from them.
    let some (τ, inst) ← flatInstance? type
      | throwError "verified_compile: the sum {type} has no `Flat` instance"
    let (``Prod, #[α, β]) := (← whnfR τ).getAppFnArgs
      | throwError "verified_compile: the `Flat` instance of {type} is not a pair"
    let missing (what : String) : MetaM Lean.Expr :=
      throwError "verified_compile: the sum {type} has no {what}; its variables stay whole"
    return ⟨α, β, fun _ _ => missing "rebuild from its components",
      fun p => mkApp4 (mkConst ``LeanExe.Pipeline.Flat.flat) type τ inst p,
      fun _ _ => missing "eta law"⟩
  let some (ctor, _) ← structOf? type
    | throwError "verified_compile: {type} is not a pair or a record"
  let some (τ, inst) ← flatInstance? type
    | throwError "verified_compile: the record {type} has no `Flat` instance"
  let (``Prod, #[α, β]) := (← whnfR τ).getAppFnArgs
    | throwError "verified_compile: the `Flat` instance of {type} is not a pair"
  let tree ← flatTree "verified_compile" type τ inst ctor
  let rebuild (a b : Lean.Expr) : MetaM Lean.Expr := do
    let fields ← (List.range ctor.numFields).mapM fun i => do
      match tree.find? (·.1 == i) with
      | some (_, false :: rest) => tuplePath a rest
      | some (_, true :: rest) => tuplePath b rest
      | _ => throwError "verified_compile: the `Flat` instance of {type} does not hold field {i}"
    return mkAppN (mkConst ctor.name type.getAppFn.constLevels!) (type.getAppArgs ++ fields.toArray)
  let pair (p : Lean.Expr) := mkApp4 (mkConst ``LeanExe.Pipeline.Flat.flat) type τ inst p
  let .const n _ := type.getAppFn | throwError "verified_compile: the record {type}"
  let name := base ++ `flat_eta ++ n
  unless (← getEnv).contains name do
    let (stmt, proof) ← withLocalDeclD `γ (mkSort Level.one) fun γ => do
      withLocalDeclD `B (← mkArrow type γ) fun B => withLocalDeclD `v type fun v => do
        let P := pair v
        let lhs := mkApp B (← rebuild (← mkAppM ``Prod.fst #[P]) (← mkAppM ``Prod.snd #[P]))
        let rhs := mkApp B v
        let proof ← mkExpectedTypeHint (← mkEqRefl rhs) (← mkEq lhs rhs)
        return (← mkForallFVars #[γ, B, v] (← mkEq lhs rhs), ← mkLambdaFVars #[γ, B, v] proof)
    addTheorem name stmt proof
  let eta (B v : Lean.Expr) : MetaM Lean.Expr := do
    return mkApp3 (mkConst name) (← inferType (mkApp B v)) B v
  return ⟨α, β, rebuild, pair, eta⟩

/-- Whether the kernel finds `a` and `b` definitionally equal, in the current local context. -/
def kernelDefEq (a b : Lean.Expr) : MetaM Bool := do
  match Kernel.isDefEq (← getEnv) (← getLCtx) a b with
  | .ok r => return r
  | .error ex => throwKernelException ex

/-- The proof of `T = e` by `rfl`, for a term `T` that the reflector reflects in place of `e`:
the two differ by a `let` that `T` substitutes, a beta reduction, or a match on a constructor,
which the kernel reduces without evaluating either term's parts. -/
def bareEq (T e : Lean.Expr) : MetaM Lean.Expr := do
  mkExpectedTypeHint (← mkEqRefl e) (← mkEq T e)

/-- The enumeration and its `Flat` instance, for a type other than `Bool` whose values are
enumeration constants with a `Flat` instance to words. -/
def enumFlat? (type : Lean.Expr) : MetaM (Option (Name × Lean.Expr)) := do
  if (← elemOf? type).isSome then return none
  let .const n _ ← whnfR type | return none
  unless ← isEnumType n do return none
  let some (β, inst) ← flatInstance? (mkConst n) | return none
  unless (← whnfR β).isConstOf ``UInt64 do return none
  return some (n, inst)

/-- `Flat.flat` of the enumeration `n` with the instance `inst`. -/
def enumFlat (n : Name) (inst : Lean.Expr) : Lean.Expr :=
  mkApp3 (mkConst ``LeanExe.Pipeline.Flat.flat) (mkConst n) (mkConst ``UInt64) inst

/-- The theorem that the flattening of the enumeration `n` is injective, added once per program
under `base`.  It follows from the decoder `fun w => bif w == flat K₁ then K₁ else …` and its
value at each constructor, which the kernel evaluates.  The reflector checks each constructor
first, so that a flattening that maps two constructors to one word is reported by name. -/
def flatInjective (base n : Name) (inst : Lean.Expr) : MetaM Lean.Expr := do
  let name := base ++ `flat_injective ++ n
  if (← getEnv).contains name then return mkConst name
  let .inductInfo info ← getConstInfo n | throwError "verified_compile: {n} is not an enumeration"
  let E := Lean.mkConst n
  let flat := enumFlat n inst
  let ctors := info.ctors.map Lean.mkConst
  let g ← withLocalDeclD `w (mkConst ``UInt64) fun w => do
    let rec chain : List Lean.Expr → MetaM Lean.Expr
      | [] => throwError "verified_compile: {n} has no constructors"
      | [k] => return k
      | k :: ks => do mkAppM ``cond #[← mkAppM ``BEq.beq #[w, mkApp flat k], k, ← chain ks]
    mkLambdaFVars #[w] (← chain ctors)
  let hgTy ← withLocalDeclD `x E fun x => do
    mkForallFVars #[x] (← mkEq (mkApp g (mkApp flat x)) x)
  let hg ← withLocalDeclD `x E fun x => do
    let motive ← withLocalDeclD `y E fun y => do
      mkLambdaFVars #[y] (← mkEq (mkApp g (mkApp flat y)) y)
    let minors ← ctors.mapM fun k => do
      let lhs := mkApp g (mkApp flat k)
      unless ← kernelDefEq lhs k do
        throwError "verified_compile: the flattening of {n} gives {k} the same word as an earlier \
          constructor"
      mkExpectedTypeHint (← mkEqRefl k) (← mkEq lhs k)
    mkLambdaFVars #[x] (mkAppN (mkConst (n ++ `casesOn) [Level.zero]) (#[motive, x] ++ minors))
  let hg ← mkExpectedTypeHint hg hgTy
  let proof ← withLocalDeclD `a E fun a => withLocalDeclD `b E fun b => do
    withLocalDeclD `h (← mkEq (mkApp flat a) (mkApp flat b)) fun h => do
      mkLambdaFVars #[a, b, h] (← mkEqTrans (← mkEqSymm (mkApp hg a))
        (← mkEqTrans (← mkCongrArg g h) (mkApp hg b)))
  addTheorem name (← mkAppM ``Function.Injective #[flat]) proof
  return mkConst name

/-- The word of an enumeration constant `e`, as a literal. -/
def enumWord? (e : Lean.Expr) : MetaM (Option Lean.Expr) := do
  let .const k _ := e | return none
  let some (.ctorInfo info) := (← getEnv).find? k | return none
  let some (n, inst) ← enumFlat? (mkConst info.induct) | return none
  let w ← match Kernel.whnf (← getEnv) (← getLCtx)
      (mkApp (mkConst ``UInt64.toNat) (mkApp (enumFlat n inst) e)) with
    | .ok w => pure w
    | .error ex => throwKernelException ex
  let some v := natOf w | throwError "verified_compile: the word of {e} is not a literal: {w}"
  return some (← mkAppOptM ``OfNat.ofNat #[some (mkConst ``UInt64), some (mkRawNatLit v), none])

/-- `d` expanded along its product type into the pairs of its projections. -/
partial def expandPairs (d : Lean.Expr) : MetaM Lean.Expr := do
  let (``Prod, _) := (← whnfR (← inferType d)).getAppFnArgs | return d
  mkAppM ``Prod.mk
    #[← expandPairs (← mkAppM ``Prod.fst #[d]), ← expandPairs (← mkAppM ``Prod.snd #[d])]

/-- The arguments that the one alternative of the match `app` receives for the discriminant `d`,
a tuple, along the alternative's pattern, which may take nested pairs apart: the match on `d`
expanded into pairs reduces to the alternative applied to them. -/
def matchFields (app : MatcherApp) (d : Lean.Expr) : MetaM (Array Lean.Expr) := do
  withLocalDeclD `h (← inferType app.alts[0]!) fun h => do
    let .reduced v ← reduceMatcher? { app with discrs := #[← expandPairs d], alts := #[h] }.toExpr
      | throwError "verified_compile: cannot reduce the match {app.toExpr}"
    unless v.getAppFn == h do
      throwError "verified_compile: the match {app.toExpr} gives {v}"
    v.getAppArgs.mapM projReduce

/-- For a match `app` with one discriminant `d` of a structure type, `Prod` included, and one
alternative `alt`, the proof of `alt (fields d) = app`.  It is proved by `rfl` for a variable for
`d` and a variable for the alternative, since structure eta lets the match reduce on a variable,
also when the pattern takes nested pairs apart, and then applied to both, so that the kernel
evaluates neither the value nor the alternative's body. -/
def casesEq (app : MatcherApp) (fields : Lean.Expr → MetaM (Array Lean.Expr)) :
    MetaM Lean.Expr := do
  let alt := app.alts[0]!
  let d := app.discrs[0]!
  let .lam _ _ motiveBody _ := app.motive
    | throwError "verified_compile: the match {app.toExpr} has an unexpected motive"
  if motiveBody.hasLooseBVars then
    throwError "verified_compile: the type of the match {app.toExpr} depends on its value"
  let altTy ← inferType alt
  let dTy ← inferType d
  let gen ← withLocalDeclD `h altTy fun h => withLocalDeclD `s dTy fun s => do
    let lhs := mkAppN h (← fields s)
    let rhs := { app with discrs := #[s], alts := #[h] }.toExpr
    -- `refl` proves the goal by `Eq.refl lhs`, whose type omits the match, so a hint states it.
    let eq ← mkEq lhs rhs
    let goal ← mkFreshExprMVar eq
    goal.mvarId!.refl
    mkLambdaFVars #[h, s] (← mkExpectedTypeHint (← instantiateMVars goal) eq)
  return mkApp2 gen alt d

/-- From `proof : X = flatValue a` and `eq : a = e`, the proof of `X = flatValue e`. -/
def restate (proof eq : Lean.Expr) : MetaM Lean.Expr := do
  let some (_, _, e) := (← inferType eq).eq? | throwError "verified_compile: the equation {eq}"
  match (← shapeOf (← inferType e)).flat with
  | none => transHint proof eq
  | some f => transHint proof (← mkCongrArg f eq)

/-- A reflected Lean term: the source expression `src`, the proof that it means the flattening of
the Lean term `lean`, the source type, and the builders of its allocation bound and its frames
condition.  For an `if`, a `let`, or a destructuring, `buys` builds the credits that `Expr.buys`
charges in the result of a loop's body; for any other form those credits are 0. -/
structure Reflection where
  src : Lean.Expr
  proof : Lean.Expr
  ty : Ty
  lean : Lean.Expr
  bound : BoundBuilder
  fits : FitsBuilder
  buys : Option BoundBuilder

instance : Inhabited Reflection :=
  ⟨⟨default, default, .word, default, fun _ _ _ => pure default, pure default, none⟩⟩

/-- `r` as the reflection of the Lean term `e`, with the proof `proof` that its source means it. -/
def Reflection.as (r : Reflection) (proof e : Lean.Expr) : Reflection :=
  { r with proof, lean := e }

/-- `r` as the reflection of the Lean term `e`, whose flattening its proof already states up to
the kernel's reduction. -/
def Reflection.as' (r : Reflection) (e : Lean.Expr) : Reflection :=
  { r with lean := e }

/-- The proof that the source of `r` means the flattening of its Lean term, stated with that
term.  The meaning lemmas state an operation as `BinOp.apply` and a variable through the
environment, which the kernel reduces to the term. -/
def userProof (c : Ctx) (r : Reflection) : MetaM Lean.Expr := do
  mkExpectedTypeHint r.proof (← mkEq (← denoteExpr c r.src) (← flatValue r.lean))

/-- The arguments that the bound lemmas take from the context. -/
def boundArgs (c : Ctx) (bounds modes paid live : Lean.Expr) : List (Name × Lean.Expr) :=
  [(`S, c.sigs), (`Γ, c.ctx), (`funs, c.funs), (`flags, c.tables.flags), (`bounds, bounds),
    (`modes, modes), (`paid, paid), (`live, live), (`env, c.env)]

/-- The arguments that the frames lemmas take from the context. -/
def fitsArgs (c : Ctx) : List (Name × Lean.Expr) :=
  [(`S, c.sigs), (`Γ, c.ctx), (`funs, c.funs), (`fits, c.tables.table true), (`env, c.env)]

/-- The proof of the frames hypothesis `ty`, `∀ xs, e.fits funs fits env = R`, by
`Expr.fits_of_depthCalls` when `e` calls no function whose code takes the call depth. -/
def noDepthFits? (ty : Lean.Expr) : MetaM (Option Lean.Expr) :=
  forallTelescope ty fun xs eq => do
    let some (_, lhs, _) := eq.eq?
      | throwError "verified_compile: the frames hypothesis {ty} is not an equation"
    let (``Expr.fits, #[S, funs, fits, Γ, t, e, env]) := lhs.getAppFnArgs
      | throwError "verified_compile: the frames hypothesis {ty}"
    let calls := mkAppN (mkConst ``Expr.depthCalls) #[S, Γ, t, e]
    if ← evalBool m!"whether {e} calls a function that takes the call depth" calls then
      return none
    let h ← evalEq calls (boolConst false)
    return some (← mkLambdaFVars xs
      (mkAppN (mkConst ``Expr.fits_of_depthCalls) #[S, funs, fits, Γ, t, e, h, env]))

/-- Assigns the frames hypothesis `name`: by `noDepthFits?`, or from the builder `b` of the part
that it states. -/
def LemmaApp.childFits (a : LemmaApp) (name : Name) (b : FitsBuilder) : MetaM Unit := do
  match ← noDepthFits? (← a.hypType name) with
  | some h => a.assign name h
  | none => a.assign name (← b).proof

/-- Assigns the frames hypothesis `name` by `noDepthFits?`, for a part that calls no function
whose code takes the call depth. -/
def LemmaApp.noDepth (a : LemmaApp) (name : Name) : MetaM Unit := do
  let some h ← noDepthFits? (← a.hypType name)
    | throwError "verified_compile: the part {name} of {a.name} calls a function that takes the \
        call depth"
  a.assign name h

/-- The builder of an expression `src` that calls no function whose code takes the call depth. -/
def leafFits (c : Ctx) (src : Lean.Expr) : FitsBuilder := do
  let h ← evalEq (← mkAppM ``Expr.depthCalls #[src]) (boolConst false)
  return ⟨boolConst true,
    ← mkAppM ``Expr.fits_of_depthCalls #[c.funs, c.tables.table true, src, h, c.env]⟩

/-- `e = e'` for `e` a cost that the bound lemmas build from sums, `if`s, and terms that charge
blocks, and `e'` the cost without its summands `0`, with `0` for an `if` whose branches are `0`,
for `sumBelow` of `0` and `loopCost` of a loop whose condition and body cost `0`, and with
`blockCost a` for `blockCost (a * 1)`.  It descends only through `+` and `if` on `Nat`, so it never
changes a Lean term of the user's, which appear only inside the charges.  `none` when nothing
changes. -/
partial def normCost (e : Lean.Expr) : MetaM (Lean.Expr × Option Lean.Expr) := do
  match e.getAppFnArgs with
  | (``HAdd.hAdd, #[_, _, _, _, a, b]) =>
    let op := e.appFn!.appFn!
    unless op == natAdd do return (e, none)
    let (a', ha?) ← normCost a
    let (b', hb?) ← normCost b
    let step? ← if ha?.isNone && hb?.isNone then pure none
      else some <$> congr2 op a a' b b' ha? hb?
    let drop? : Option (Lean.Expr × Lean.Expr) ←
      if isNatZero b' then pure (some (a', ← mkAppM ``Nat.add_zero #[a']))
      else if isNatZero a' then pure (some (b', ← mkAppM ``Nat.zero_add #[b']))
      else pure none
    match step?, drop? with
    | none, none => return (e, none)
    | some s, none => return (mkApp2 op a' b', some s)
    | none, some (r, d) => return (r, some d)
    | some s, some (r, d) => return (r, some (← mkEqTrans s d))
  | (``ite, #[α, cond, inst, a, b]) =>
    unless α.isConstOf ``Nat do return (e, none)
    let iteFn := e.appFn!.appFn!
    let (a', ha?) ← normCost a
    let (b', hb?) ← normCost b
    let step? ← if ha?.isNone && hb?.isNone then pure none
      else some <$> congr2 iteFn a a' b b' ha? hb?
    if isNatZero a' && isNatZero b' then
      let self ← mkAppOptM ``ite_self #[some α, some cond, some inst, some natZero]
      match step? with
      | none => return (natZero, some self)
      | some s => return (natZero, some (← mkEqTrans s self))
    match step? with
    | none => return (e, none)
    | some s => return (mkApp2 iteFn a' b', some s)
  | (``sumBelow, #[f, n]) =>
    unless f.isLambda && isNatZero f.bindingBody! do return (e, none)
    let h ← withLocalDeclD `k (mkConst ``Nat) fun k => do
      mkLambdaFVars #[k] (← mkEqRefl natZero)
    return (natZero, some (← mkAppOptM ``sumBelow_zero #[some f, some h, some n]))
  | (``loopCost, #[α, CA, C, BA, F, n, i, s]) =>
    unless CA.isLambda && isNatZero CA.bindingBody! && BA.isLambda && BA.bindingBody!.isLambda &&
        isNatZero BA.bindingBody!.bindingBody! do return (e, none)
    let hCA ← withLocalDeclD `s α fun x => do mkLambdaFVars #[x] (← mkEqRefl natZero)
    let hBA ← withLocalDeclD `i (mkConst ``UInt64) fun j => withLocalDeclD `s α fun x => do
      mkLambdaFVars #[j, x] (← mkEqRefl natZero)
    return (natZero, some (← mkAppOptM ``loopCost_eq_zero
      #[some α, some CA, some C, some BA, some F, some hCA, some hBA, some n, some i, some s]))
  | (``blockCost, #[x]) =>
    let some (a, h) ← mulOne? x | return (e, none)
    let f := e.getAppFn
    return (mkApp f a, some (← congrArgOn f x a h))
  | (``foldCost, #[_, _, xs, init, step, cost]) =>
    unless ← lambdaTelescope cost (fun _ body => pure (isNatZero body)) do return (e, none)
    return (natZero, some (← mkAppM ``foldCost_zero #[xs, init, step]))
  | (``ListFold.nativeCost, #[_, step, cost, xs, init]) =>
    unless ← lambdaTelescope cost (fun _ body => pure (isNatZero body)) do return (e, none)
    return (natZero, some (← mkAppM ``ListFold.nativeCost_zero #[step, xs, init]))
  | _ => return (e, none)

/-- `e` with its head reduced once when it projects an application of a structure's constructor,
or, for a pair `(y.1, y.2)` of the projections of one term `y`, `y`. -/
def projStep? (e : Lean.Expr) : MetaM (Option Lean.Expr) := do
  if let some (i, p) ← structProj? e then
    let .const k _ := p.getAppFn | return none
    let some (.ctorInfo ctor) := (← getEnv).find? k | return none
    unless p.getAppNumArgs == ctor.numParams + ctor.numFields do return none
    return some (p.getArg! (ctor.numParams + i))
  let (``Prod.mk, #[_, _, a, b]) := e.getAppFnArgs | return none
  let (``Prod.fst, #[_, _, y]) := a.getAppFnArgs | return none
  let (``Prod.snd, #[_, _, y']) := b.getAppFnArgs | return none
  return if y == y' then some y else none

/-- The fields of `e`, an application of the constructor of a structure, or `none`. -/
def ctorFields? (e : Lean.Expr) : MetaM (Option (Array Lean.Expr)) := do
  let .const k _ := e.getAppFn | return none
  let some (.ctorInfo ctor) := (← getEnv).find? k | return none
  unless isStructure (← getEnv) ctor.induct do return none
  unless e.getAppNumArgs == ctor.numParams + ctor.numFields do return none
  return some (e.getAppArgs.extract ctor.numParams e.getAppNumArgs)

/-- The maximal parts of `e` that are not applications of a structure's constructor. -/
partial def ctorLeaves (e : Lean.Expr) : MetaM (Array Lean.Expr) := do
  match ← ctorFields? e with
  | some fs => fs.foldlM (fun acc f => return acc ++ (← ctorLeaves f)) #[]
  | none => return #[e]

/-- `e` with its leaves, from position `i` on, replaced by the terms `ys`, and the next position. -/
partial def ctorRebuild (e : Lean.Expr) (ys : Array Lean.Expr) (i : Nat) :
    MetaM (Lean.Expr × Nat) := do
  let some fs ← ctorFields? e | return (ys[i]!, i + 1)
  let mut j := i
  let mut fs' := #[]
  for f in fs do
    let (f', j') ← ctorRebuild f ys j
    fs' := fs'.push f'
    j := j'
  return (mkAppN e.getAppFn (e.getAppArgs.extract 0 (e.getAppNumArgs - fs.size) ++ fs'), j)

/-- `e` with each projection of an application of a structure's constructor reduced, and each pair
`(y.1, y.2)` replaced by `y`, where the term holds a variable of the current context.  The kernel
checks the reduction, behind a hint at this context, by comparing pairs of terms of which one holds
that variable, and it evaluates the operands of `Nat` operations only in pairs of closed terms.  A
variable that a lambda inside `e` binds is bound at the hint, so it does not count. -/
def reduceOpenProjs (e : Lean.Expr) : MetaM Lean.Expr := do
  let lctx ← getLCtx
  Meta.transform e (post := fun x => do
    unless x.hasAnyFVar lctx.contains do return .done x
    return .done ((← projStep? x).getD x))

/-- `b`, abstracted over variables, at the values `vs`: its proof applied to them, and its term
instantiated with them, with the projections reduced that a value built in place leaves in it.
The reduction runs with the values' leaves as new variables, as `reduceOpenProjs` requires, and the
proof, abstracted over the variables, is applied to the leaves, which the kernel instantiates
without comparing anything. -/
def Bound.at (b : Bound) (vs : Array Lean.Expr) : MetaM Bound := do
  let plain : Bound := ⟨b.term.beta vs, mkAppN b.proof vs⟩
  unless ← vs.anyM fun v => return (← ctorFields? v).isSome do return plain
  let leaves ← vs.foldlM (fun acc v => return acc ++ (← ctorLeaves v)) #[]
  let decls ← leaves.mapIdxM fun i l => do
    return ((`y).appendIndexAfter i, fun _ => inferType l)
  withLocalDeclsD decls fun ys => do
    let mut j := 0
    let mut vs' := #[]
    for v in vs do
      let (v', j') ← ctorRebuild v ys j
      vs' := vs'.push v'
      j := j'
    let cost := b.term.beta vs'
    let reduced ← reduceOpenProjs cost
    if reduced == cost then return plain
    let p := mkAppN b.proof vs'
    let (lhs, _) ← eqSides p
    let h ← mkExpectedTypeHint p (← mkEq lhs reduced)
    return ⟨(← mkLambdaFVars ys reduced).beta leaves, mkAppN (← mkLambdaFVars ys h) leaves⟩

/-- The bound that `p : allocs = rhs` gives, with `rhs` normalized by `normCost` and its projections
of values built in place reduced by `reduceOpenProjs`. -/
def boundOf (p : Lean.Expr) : MetaM Bound := do
  let (lhs, rhs) ← eqSides p
  let (rhs', h?) ← normCost rhs
  let p ← match h? with | some h => mkEqTrans p h | none => pure p
  let reduced ← reduceOpenProjs rhs'
  if reduced == rhs' then return ⟨rhs', p⟩
  return ⟨reduced, ← mkExpectedTypeHint p (← mkEq lhs reduced)⟩

/-- `e = e'` for `e` a frames condition that the frames lemmas build from `&&` and `if`s, and `e'`
the condition without its operands `true` of `&&`, with `true` for an `if` whose branches are
`true`, and with `true` for `allBelow` and `loopFits` whose parts are `true`.  `none` when nothing
changes. -/
partial def normFits (e : Lean.Expr) : MetaM (Lean.Expr × Option Lean.Expr) := do
  match e.getAppFnArgs with
  | (``and, #[a, b]) =>
    let op := e.appFn!.appFn!
    let (a', ha?) ← normFits a
    let (b', hb?) ← normFits b
    let step? ← if ha?.isNone && hb?.isNone then pure none
      else some <$> congr2 op a a' b b' ha? hb?
    let drop? : Option (Lean.Expr × Lean.Expr) ←
      if a'.isConstOf ``Bool.true then pure (some (b', ← mkAppM ``Bool.true_and #[b']))
      else if b'.isConstOf ``Bool.true then pure (some (a', ← mkAppM ``Bool.and_true #[a']))
      else pure none
    match step?, drop? with
    | none, none => return (e, none)
    | some s, none => return (mkApp2 op a' b', some s)
    | none, some (r, d) => return (r, some d)
    | some s, some (r, d) => return (r, some (← mkEqTrans s d))
  | (``ite, #[α, cond, inst, a, b]) =>
    unless α.isConstOf ``Bool do return (e, none)
    let iteFn := e.appFn!.appFn!
    let (a', ha?) ← normFits a
    let (b', hb?) ← normFits b
    let step? ← if ha?.isNone && hb?.isNone then pure none
      else some <$> congr2 iteFn a a' b b' ha? hb?
    if a'.isConstOf ``Bool.true && b'.isConstOf ``Bool.true then
      let self ← mkAppOptM ``ite_self #[some α, some cond, some inst, some a']
      match step? with
      | none => return (a', some self)
      | some s => return (a', some (← mkEqTrans s self))
    match step? with
    | none => return (e, none)
    | some s => return (mkApp2 iteFn a' b', some s)
  | (``allBelow, #[f, n]) =>
    unless f.isLambda && f.bindingBody!.isConstOf ``Bool.true do return (e, none)
    let h ← withLocalDeclD `k (mkConst ``Nat) fun k => do
      mkLambdaFVars #[k] (← mkEqRefl (mkConst ``Bool.true))
    return (mkConst ``Bool.true, some (← mkAppOptM ``allBelow_true #[some f, some h, some n]))
  | (``loopFits, #[α, cf, C, bf, F, n, i, s]) =>
    unless cf.isLambda && cf.bindingBody!.isConstOf ``Bool.true && bf.isLambda &&
        bf.bindingBody!.isLambda && bf.bindingBody!.bindingBody!.isConstOf ``Bool.true do
      return (e, none)
    let hc ← withLocalDeclD `s α fun x => do mkLambdaFVars #[x] (← mkEqRefl (mkConst ``Bool.true))
    let hb ← withLocalDeclD `i (mkConst ``UInt64) fun j => withLocalDeclD `s α fun x => do
      mkLambdaFVars #[j, x] (← mkEqRefl (mkConst ``Bool.true))
    return (mkConst ``Bool.true, some (← mkAppOptM ``loopFits_true
      #[some α, some cf, some C, some bf, some F, some hc, some hb, some n, some i, some s]))
  | (``Verified.foldFits, #[_, _, xs, init, step, fits]) =>
    unless ← lambdaTelescope fits (fun _ body => pure (body.isConstOf ``Bool.true)) do
      return (e, none)
    return (mkConst ``Bool.true, some (← mkAppM ``foldFits_true #[xs, init, step]))
  | (``ListFold.nativeFits, #[_, step, fits, xs, init]) =>
    unless ← lambdaTelescope fits (fun _ body => pure (body.isConstOf ``Bool.true)) do
      return (e, none)
    return (mkConst ``Bool.true, some (← mkAppM ``ListFold.nativeFits_true #[step, xs, init]))
  | _ => return (e, none)

/-- The frames condition that `p : fits = rhs` gives, with `rhs` normalized by `normFits` and its
projections of values built in place reduced by `reduceOpenProjs`. -/
def fitsOf (p : Lean.Expr) : MetaM Bound := do
  let (lhs, rhs) ← eqSides p
  let (rhs', h?) ← normFits rhs
  let p ← match h? with | some h => mkEqTrans p h | none => pure p
  let reduced ← reduceOpenProjs rhs'
  if reduced == rhs' then return ⟨rhs', p⟩
  return ⟨reduced, ← mkExpectedTypeHint p (← mkEq lhs reduced)⟩

/-- The size of the Lean array `u`, whose flattening is the source value `v` of an array of
elements `e`, with the proof of `v.size = u.size`. -/
def arraySizeEq (e : Elem) (v u : Lean.Expr) : MetaM (Lean.Expr × Lean.Expr) := do
  let (``Array, #[α]) := (← whnfR (← inferType u)).getAppFnArgs
    | throwError "verified_compile: the size of {u}, which is not an array"
  let n ← mkAppM ``Array.size #[u]
  let sizeV := mkApp2 (mkConst ``Array.size [Level.zero]) (mkApp (mkConst ``Elem.denote)
    (elemExpr e)) v
  match (← shapeOf α).flat with
  | none => return (n, ← mkExpectedTypeHint (← mkEqRefl n) (← mkEq sizeV n))
  | some φ => do
    let h ← mkAppOptM ``Array.size_map #[none, none, some φ, some u]
    return (n, ← mkExpectedTypeHint h (← mkEq sizeV n))

/-- A cost of a value that sums a charge over its arrays: the function, `Ty.copyCost` or
`Ty.credit`, and the lemmas that state it for an array, as a charge of the array's words, and for a
pair. -/
structure ValueCost where
  fn : Name
  array : Name
  pair : Name

def ValueCost.copy : ValueCost := ⟨``Ty.copyCost, ``copyCost_array, ``copyCost_pair⟩

def ValueCost.credit : ValueCost := ⟨``Ty.credit, ``credit_array, ``credit_pair⟩

/-- The proof of `k.fn t v = C` for the source value `v` of the Lean term `u`, with `C` written
with the charge of `k.array`, such as `blockCost`, of the sizes of `u`'s arrays. -/
partial def ValueCost.eq (k : ValueCost) (base : Name) (t : Ty) (v u : Lean.Expr) :
    MetaM (Lean.Expr × Lean.Expr) := do
  let lhs := mkApp2 (mkConst k.fn) (tyExpr t) v
  match t with
  | .elem _ => return (natZero, ← evalEq lhs natZero)
  | .tree _ | .treeHeader _ _ | .bytes => return (lhs, ← mkEqRefl lhs)
  | .array e =>
    let width := mkApp (mkConst ``Elem.width) (elemExpr e)
    let w ← evalNat width
    let hw ← evalEq width w
    let (_, hn) ← arraySizeEq e v u
    let p ← (← LemmaApp.start k.array
      [(`e, elemExpr e), (`xs, v), (`hn, hn), (`hw, hw)]).finish
    let (_, cost) ← eqSides p
    let some (a, h) ← mulOne? cost.appArg! | return (cost, p)
    return (mkApp cost.appFn! a, ← mkEqTrans p (← congrArgOn cost.appFn! cost.appArg! a h))
  | .pair a b =>
    let view ← pairView base (← inferType u)
    let P := view.pair u
    let u1 ← projReduce (← mkAppM ``Prod.fst #[P])
    let u2 ← projReduce (← mkAppM ``Prod.snd #[P])
    let (_, ha) ← k.eq base a (← mkAppM ``Prod.fst #[v]) u1
    let (_, hb) ← k.eq base b (← mkAppM ``Prod.snd #[v]) u2
    let b ← boundOf (← (← LemmaApp.start k.pair
      [(`a, tyExpr a), (`b, tyExpr b), (`v, v), (`ha, ha), (`hb, hb)]).finish)
    return (b.term, b.proof)

/-- The proof of `t.copyCost v = C` for the source value `v` of the Lean term `u`, with `C` written
with `blockCost` of the sizes of `u`'s arrays. -/
def copyCostEq (base : Name) (t : Ty) (v u : Lean.Expr) : MetaM (Lean.Expr × Lean.Expr) :=
  ValueCost.copy.eq base t v u

/-- The proof of `coerceCost t s M v = K` for the source value `v` of the Lean term `u`, where the
modes `s` and `M` are closed terms: a copy when `s` is borrowed and `M` owned. -/
def coerceEq (base : Name) (t : Ty) (s M v u : Lean.Expr) : MetaM (Lean.Expr × Lean.Expr) := do
  let common := [(`t, tyExpr t), (`s, s), (`m, M), (`v, v)]
  if let .elem e := t then
    return (natZero, ← (← LemmaApp.start ``coerce_elem
      [(`e, elemExpr e), (`s, s), (`m, M), (`v, v)]).finish)
  if ← evalOwned m!"the mode of {u}" s then
    return (natZero, ← (← LemmaApp.start ``coerce_owned
      (common ++ [(`hs, ← evalEq s (modeConst true))])).finish)
  unless ← evalOwned m!"the mode that {u} takes" M do
    return (natZero, ← (← LemmaApp.start ``coerce_borrowed
      (common ++ [(`hm, ← evalEq M (modeConst false))])).finish)
  let (C, hc) ← copyCostEq base t v u
  return (C, ← (← LemmaApp.start ``coerce_copy (common ++
    [(`hs, ← evalEq s (modeConst false)), (`hm, ← evalEq M (modeConst true)),
      (`hc, hc)])).finish)

/-- Assigns the mode argument `name` of `app`, which equation `hName` determines from a closed
mode term, the value that the kernel computes. -/
def assignMode (app : LemmaApp) (name hName : Name) : MetaM Lean.Expr := do
  let ty ← app.hypType hName
  let some (_, mode, _) := ty.eq?
    | throwError "verified_compile: the argument {hName} of {app.name} is not an equation"
  let m := modeConst (← evalOwned m!"a mode in {app.name}" mode)
  app.assign name m
  app.assign hName (← evalEq mode m)
  return m

/-- Assigns the flag `p` of a `let` slot, which equation `hp` determines from the value's
`Expr.paid`, the Boolean that the kernel computes. -/
def assignPaid (app : LemmaApp) : MetaM Lean.Expr := do
  let some (_, flag, _) := (← app.hypType `hp).eq?
    | throwError "verified_compile: the argument hp of {app.name} is not an equation"
  let p := boolConst (← evalBool m!"the flag of a let in {app.name}" flag)
  app.assign `p p
  app.assign `hp (← evalEq flag p)
  return p

/-- Assigns the charge argument `value` of `app` and its equation `proof`,
`t.buyCost want held v = K`, for the branch whose Lean term `u` flattens to `v`: the credit of the
branch's value when the kernel evaluates `want && !held` to `true`, and 0 otherwise. -/
def assignBuy (base : Name) (app : LemmaApp) (value proof : Name) (t : Ty) (u : Lean.Expr) :
    MetaM Unit := do
  let some (_, lhs, _) := (← app.hypType proof).eq?
    | throwError "verified_compile: the argument {proof} of {app.name} is not an equation"
  let (``Ty.buyCost, #[tE, want, held, v]) := lhs.getAppFnArgs
    | throwError "verified_compile: the argument {proof} of {app.name} is not a branch charge"
  let flag ← mkAppM ``and #[want, ← mkAppM ``not #[held]]
  if ← evalBool m!"whether a branch of {app.name} is charged its credit" flag then
    let (CR, hx) ← ValueCost.credit.eq base t v u
    app.assign value CR
    app.assign proof (← mkAppM ``buy_some #[← evalEq flag (boolConst true), hx])
  else
    app.assign value natZero
    app.assign proof (← mkAppOptM ``buy_none
      #[some tE, some want, some held, some v, some (← evalEq flag (boolConst false))])

/-- The arguments that the lemmas on `Expr.buys` take from the context. -/
def buysArgs (c : Ctx) (modes paid live : Lean.Expr) : List (Name × Lean.Expr) :=
  [(`S, c.sigs), (`Γ, c.ctx), (`funs, c.funs), (`flags, c.tables.flags), (`modes, modes),
    (`paid, paid), (`live, live), (`env, c.env)]

/-- Runs the builder `b` of the credits that argument `name` of `a`, `e.buys … = Y`, states, at
the modes, paid flags, and live set of its left side, and assigns its proof. -/
def LemmaApp.childBuys (a : LemmaApp) (name : Name) (b : BoundBuilder) : MetaM Bound := do
  let ty ← a.hypType name
  let some (_, lhs, rhs) := ty.eq?
    | throwError "verified_compile: the argument {name} of {a.name} is not an equation"
  let (``Expr.buys, #[_, _, _, modes, paid, live, _, _, _, _]) := lhs.consumeMData.getAppFnArgs
    | throwError "verified_compile: the argument {name} of {a.name} is not a credit:{indentExpr lhs}"
  let r ← b modes paid live
  unless ← withReducible (isDefEq rhs r.term) do
    throwError "verified_compile: the credit for {name} of {a.name} differs from {r.term}"
  a.assign name (← mkExpectedTypeHint r.proof (← a.hypType name))
  return r

/-- The credits of the source expression `src` in the context `c`, a form at which the result of
a loop's body charges none, by `Expr.buyFree`, which the kernel evaluates. -/
def zeroBuys (c : Ctx) (src : Lean.Expr) : BoundBuilder := fun modes paid live => do
  let app ← LemmaApp.start ``buys_zero (buysArgs c modes paid live ++ [(`e, src)])
  let some (_, free, _) := (← app.hypType `h).eq?
    | throwError "verified_compile: the argument h of buys_zero is not an equation"
  unless ← evalBool m!"whether a form charges no credit" free do
    throwError "verified_compile: the result of a loop's body charges a credit at a form that the \
      reflector does not support:{indentExpr src}"
  app.assign `h (← evalEq free (boolConst true))
  boundOf (← app.finish)

/-- The proof that the credits `credits`, `if ps = true then e.buys … else 0`, are 0: by the
flag `false`, or by `Expr.buyFree`, which the kernel evaluates.  None when the credits are not 0
by these. -/
def zeroCredits (credits : Lean.Expr) : MetaM (Option Lean.Expr) := do
  let (``ite, #[_, cnd, _, buys, _]) := credits.getAppFnArgs
    | throwError "verified_compile: the credits {credits}"
  let (``Eq, #[_, ps, _]) := cnd.getAppFnArgs
    | throwError "verified_compile: the credits {credits}"
  if ps.isConstOf ``Bool.false then
    return some (← mkExpectedTypeHint (← mkEqRefl natZero) (← mkEq credits natZero))
  let (``Expr.buys, #[S, funs, flags, modes, paid, live, Γ, _, e, env]) := buys.getAppFnArgs
    | throwError "verified_compile: the credits {buys}"
  let app ← LemmaApp.start ``buys_free [(`S, S), (`Γ, Γ), (`funs, funs), (`flags, flags),
    (`modes, modes), (`paid, paid), (`live, live), (`env, env), (`ps, ps), (`e, e)]
  let some (_, free, _) := (← app.hypType `h).eq?
    | throwError "verified_compile: the argument h of buys_free is not an equation"
  unless ← evalBool m!"whether a loop's body charges no credit" free do return none
  app.assign `h (← evalEq free (boolConst true))
  return some (← app.finish)

/-- The proof of the hypothesis `ty`, `∀ i s, (if ps = true then body.buys … else 0) = 0`, of a
loop's pass, by `zeroCredits` under the binders. -/
def zeroBuysAll (ty : Lean.Expr) : MetaM (Option Lean.Expr) :=
  forallTelescope ty fun xs eq => do
    let some (_, lhs, _) := eq.eq? | throwError "verified_compile: the credits {ty}"
    let some p ← zeroCredits lhs | return none
    return some (← mkLambdaFVars xs p)

/-- Assigns the argument `name` of `app`, an equation between a closed Boolean term and `true` or
`false`, its proof by the kernel's evaluation. -/
def assignFlag (app : LemmaApp) (name : Name) : MetaM Unit := do
  let some (_, lhs, rhs) := (← app.hypType name).eq?
    | throwError "verified_compile: the argument {name} of {app.name} is not an equation"
  let value ← evalBool m!"the argument {name} of {app.name}" lhs
  unless boolConst value == rhs do
    throwError "verified_compile: the argument {name} of {app.name} does not hold"
  app.assign name (← evalEq lhs rhs)

/-- The builder of the credits of `r`, a reflection in the context `c`. -/
def buysOf (c : Ctx) (r : Reflection) : BoundBuilder :=
  r.buys.getD (zeroBuys c r.src)

/-- Assigns the coercion argument `name` of `app`, `coerceCost t s M v = K`, for the Lean term `u`
whose flattening is `v`. -/
def assignCoerce (base : Name) (app : LemmaApp) (name : Name) (t : Ty) (u : Lean.Expr) :
    MetaM Bound := do
  let ty ← app.hypType name
  let some (_, lhs, _) := ty.eq?
    | throwError "verified_compile: the argument {name} of {app.name} is not an equation"
  let (``coerceCost, #[_, s, M, v]) := lhs.getAppFnArgs
    | throwError "verified_compile: the argument {name} of {app.name} is not a coercion"
  let (K, hk) ← coerceEq base t s M v u
  app.assign name hk
  return ⟨K, hk⟩

/-- The branch bound from an allocation equation and its result coercion. -/
def branchBound (base : Name) (ty : Lean.Expr) (t : Ty) (r : Reflection) :
    MetaM Bound := do
  let some (_, lhs, _) := ty.eq?
    | throwError "verified_compile: the branch bound is not an equation: {ty}"
  let (``HAdd.hAdd, #[_, _, _, _, allocs, coerce]) := lhs.getAppFnArgs
    | throwError "verified_compile: the branch bound has no result coercion: {ty}"
  let (``Expr.allocs, #[_, _, _, _, modes, paid, live, _, _, _, _]) := allocs.getAppFnArgs
    | throwError "verified_compile: the branch bound has no allocation term: {ty}"
  let b ← r.bound modes paid live
  let (``coerceCost, #[_, s, M, v]) := coerce.getAppFnArgs
    | throwError "verified_compile: the branch bound has an invalid coercion: {ty}"
  let (K, hk) ← coerceEq base t s M v r.lean
  boundOf
    (← congr2 lhs.appFn!.appFn! allocs b.term coerce K (some b.proof) (some hk))

/-- Assigns the family `valueName` of `app` to `family`, and its equation `proofName`, which
states each entry, from the proofs of `values`. -/
def assignFamilyEquation (app : LemmaApp) (valueName proofName : Name)
    (family : Lean.Expr) (values : List Bound) : MetaM Lean.Expr := do
  app.assign valueName (← mkExpectedTypeHint family (← app.hypType valueName))
  let expected ← app.hypType proofName
  let .forallE name domain body _ := expected
    | throwError "verified_compile: a finite field equation must quantify its index"
  let P := Lean.mkLambda name .default domain body
  let proof ← finiteForall values.length P fun i => do
    let some j := natOf (← kernelWhnf (← mkAppM ``Fin.val #[i]))
      | throwError "verified_compile: a finite field index is not a numeral"
    let some value := values[j]?
      | throwError "verified_compile: finite field index {j} is out of range"
    mkExpectedTypeHint value.proof (P.beta #[i])
  app.assign proofName (← mkExpectedTypeHint proof expected)
  return family

def assignFiniteEquation (app : LemmaApp) (valueName proofName : Name)
    (type : Lean.Expr) (values : List Bound) : MetaM Lean.Expr := do
  assignFamilyEquation app valueName proofName (← finiteFn type (values.map (·.term))) values

def finiteFieldBounds (app : LemmaApp) (name : Name) (fields : List Reflection) :
    MetaM (List Bound) :=
  fields.zipIdx.mapM fun (field, i) => do
    let expected ← instantiateForall (← app.hypType name) #[← finiteIndex fields.length i]
    let some (_, lhs, _) := expected.eq?
      | throwError "verified_compile: finite allocation field is not an equation"
    let (``Expr.allocs, #[_, _, _, _, modes, paid, live, _, _, _, _]) := lhs.getAppFnArgs
      | throwError "verified_compile: finite allocation field has no allocation expression"
    field.bound modes paid live

def finiteSumBound (values : List Bound) : MetaM Bound := do
  let family ← finiteFn (mkConst ``Nat) (values.map (·.term))
  let sum ← mkAppM ``argsSum #[family]
  let term := values.foldr (fun value acc => mkApp2 natAdd value.term acc) natZero
  boundOf (← evalEq sum term)

def finiteAllFits (values : List Bound) : MetaM Bound := do
  let family ← finiteFn (mkConst ``Bool) (values.map (·.term))
  let all ← mkAppM ``argsAll #[family]
  let term := values.foldr (fun value acc => mkApp2 (mkConst ``Bool.and) value.term acc)
    (mkConst ``Bool.true)
  fitsOf (← evalEq all term)

/-- Assigns a branch's allocation bound, including its result coercion. -/
def assignBranch (base : Name) (app : LemmaApp) (name : Name) (t : Ty) (r : Reflection) :
    MetaM Bound := do
  let b ← branchBound base (← app.hypType name) t r
  app.assign name b.proof
  return b

/-- The proof of `x.ownedCost modes live (env.get x) = C` for the array variable `x` whose Lean
variable is `u`: nothing when `x` is owned and dies, and a copy otherwise. -/
def varOwnedEq (c : Ctx) (modes live x : Lean.Expr) (t : Ty) (u : Lean.Expr) :
    MetaM Lean.Expr := do
  let v ← mkAppM ``Env.get #[c.env, x]
  let args := [(`Γ, c.ctx), (`modes, modes), (`live, live), (`t, tyExpr t), (`x, x), (`v, v)]
  let index ← mkAppM ``Var.index #[x]
  let mode ← mkAppM ``modeAt #[modes, index]
  if ← evalOwned m!"the mode of {u}" mode then
    let isLive := (mkApp live index).headBeta
    if ← evalBool m!"whether {u} is live" isLive then
      let (_, hc) ← copyCostEq c.base t v u
      return ← (← LemmaApp.start ``varOwned_copyLive (args ++
        [(`hm, ← evalEq mode (modeConst true)), (`hl, ← evalEq isLive (boolConst true)),
          (`hc, hc)])).finish
    return ← (← LemmaApp.start ``varOwned_move (args ++
      [(`hm, ← evalEq mode (modeConst true)),
        (`hl, ← evalEq isLive (boolConst false))])).finish
  let (_, hc) ← copyCostEq c.base t v u
  (← LemmaApp.start ``varOwned_copyBorrowed (args ++
    [(`hm, ← evalEq mode (modeConst false)), (`hc, hc)])).finish

/-- The proof of `x.roomCost modes paid live (env.get x) ext = C` for the array variable `x` of
elements `e` whose Lean variable is `u`: for an owned array that dies, the growth of a paid one or
of one that is not paid, and a copy at the new length otherwise.  The new length is `n + ext` for
elements of one word and `n * w + ext` otherwise, with `n` the array's size. -/
def roomEq (c : Ctx) (modes paid live x : Lean.Expr) (e : Elem) (u ext : Lean.Expr) :
    MetaM Bound := do
  let v ← mkAppM ``Env.get #[c.env, x]
  let index ← mkAppM ``Var.index #[x]
  let mode ← mkAppM ``modeAt #[modes, index]
  let isLive := (mkApp live index).headBeta
  let owned ← evalOwned m!"the mode of {u}" mode
  let dies ← if owned then pure !(← evalBool m!"whether {u} is live" isLive) else pure false
  let base := [(`Γ, c.ctx), (`modes, modes), (`paid, paid), (`live, live), (`e, elemExpr e),
    (`x, x), (`xs, v), (`ext, ext)]
  let paidAt ← mkAppM ``paidAt #[paid, index]
  if dies then
    if ← evalBool m!"whether {u} is paid" paidAt then
      let p ← (← LemmaApp.start ``room_growPaid (base ++
        [(`hm, ← evalEq mode (modeConst true)), (`hl, ← evalEq isLive (boolConst false)),
          (`hp, ← evalEq paidAt (boolConst true))])).finish
      return ⟨(← eqSides p).2, p⟩
  let (n, hn) ← arraySizeEq e v u
  let width := mkApp (mkConst ``Elem.width) (elemExpr e)
  let w ← evalNat width
  let nw := mkApp2 natMul n w
  let (len, hlen) ← match ← mulOne? nw with
    | some (a, h) => pure (a, h)
    | none => pure (nw, ← mkEqRefl nw)
  let args := base ++ [(`n, n), (`w, w), (`len, len), (`hn, hn), (`hw, ← evalEq width w),
    (`hlen, hlen)]
  let p ← if dies then
      (← LemmaApp.start ``room_grow (args ++
        [(`hm, ← evalEq mode (modeConst true)), (`hl, ← evalEq isLive (boolConst false)),
          (`hp, ← evalEq paidAt (boolConst false))])).finish
    else if owned then
      (← LemmaApp.start ``room_copyLive (args ++
        [(`hm, ← evalEq mode (modeConst true)), (`hl, ← evalEq isLive (boolConst true))])).finish
    else
      (← LemmaApp.start ``room_copyBorrowed (args ++
        [(`hm, ← evalEq mode (modeConst false))])).finish
  return ⟨(← eqSides p).2, p⟩

/-- Assigns the extension `k` of a push or an insertion of an element `e`, with its proof
`(wordCount e.width).toNat = k`, the literal that the kernel computes. -/
def assignExtension (app : LemmaApp) (e : Elem) : MetaM Lean.Expr := do
  let ext ← mkAppM ``UInt64.toNat #[← mkAppM ``wordCount #[mkApp (mkConst ``Elem.width)
    (elemExpr e)]]
  let k ← evalNat ext
  app.assign `k k
  app.assign `hk (← evalEq ext k)
  return k

/-- The builder of a binary form with the lemma `n` over the parts `l` and `r`. -/
def binBound (c : Ctx) (n : Name) (args : List (Name × Lean.Expr)) (l r : Reflection) :
    BoundBuilder := fun modes paid live => do
  let bounds := c.tables.table false
  let app ← LemmaApp.start n
      (boundArgs c bounds modes paid live ++ args ++ [(`l, l.src), (`r, r.src)])
  let _ ← app.child `hl l.bound
  let _ ← app.child `hr r.bound
  boundOf (← app.finish)

/-- The builder of a unary form with the lemma `n` over the part `x`. -/
def unBound (c : Ctx) (n : Name) (args : List (Name × Lean.Expr)) (x : Reflection) :
    BoundBuilder := fun modes paid live => do
  let bounds := c.tables.table false
  let app ← LemmaApp.start n (boundArgs c bounds modes paid live ++ args ++ [(`e, x.src)])
  let _ ← app.child `h x.bound
  boundOf (← app.finish)

/-- The builder of a leaf with the allocation-bound equation supplied by `n`. -/
def leafBound (c : Ctx) (n : Name) (args : List (Name × Lean.Expr)) : BoundBuilder :=
  fun modes paid live => do
    let bounds := c.tables.table false
    let app ← LemmaApp.start n (boundArgs c bounds modes paid live ++ args)
    boundOf (← app.finish)

/-- The builder of the frames condition of a form by the lemma `n`, with the arguments `args` and
the hypotheses `parts` on the frames of its parts. -/
def formFits (c : Ctx) (n : Name) (args : List (Name × Lean.Expr))
    (parts : List (Name × Reflection)) : FitsBuilder := do
  let app ← LemmaApp.start n (fitsArgs c ++ args)
  for (h, r) in parts do app.childFits h r.fits
  fitsOf (← app.finish)

/-- The builder of a binary form with the frames lemma `n` over the parts `l` and `r`. -/
def binFits (c : Ctx) (n : Name) (args : List (Name × Lean.Expr)) (l r : Reflection) :
    FitsBuilder :=
  formFits c n (args ++ [(`l, l.src), (`r, r.src)]) [(`hl, l), (`hr, r)]

/-- The builder of a unary form with the frames lemma `n` over the part `x`. -/
def unFits (c : Ctx) (n : Name) (args : List (Name × Lean.Expr)) (x : Reflection) :
    FitsBuilder :=
  formFits c n (args ++ [(`e, x.src)]) [(`h, x)]

/-- The builder of the variable `x` of type `t`, whose Lean variable is `u`: a copy when it is
owned and live after the use. -/
def varBound (c : Ctx) (x : Lean.Expr) (t : Ty) (u : Lean.Expr) : BoundBuilder :=
  fun modes paid live => do
    let bounds := c.tables.table false
    let args := boundArgs c bounds modes paid live ++ [(`x, x)]
    if let .elem _ := t then
      return ⟨natZero, ← (← LemmaApp.start ``var_elem_bound args).finish⟩
    let index ← mkAppM ``Var.index #[x]
    let mode ← mkAppM ``modeAt #[modes, index]
    unless ← evalOwned m!"the mode of {u}" mode do
      return ⟨natZero, ← (← LemmaApp.start ``var_borrowed_bound
        (args ++ [(`hm, ← evalEq mode (modeConst false))])).finish⟩
    let isLive := (mkApp live index).headBeta
    unless ← evalBool m!"whether {u} is live" isLive do
      return ⟨natZero, ← (← LemmaApp.start ``var_dead_bound
        (args ++ [(`hl, ← evalEq isLive (boolConst false))])).finish⟩
    let (C, hc) ← copyCostEq c.base t (← mkAppM ``Env.get #[c.env, x]) u
    return ⟨C, ← (← LemmaApp.start ``var_copy_bound (args ++
      [(`hm, ← evalEq mode (modeConst true)), (`hl, ← evalEq isLive (boolConst true)),
        (`hc, hc)])).finish⟩

/-- The component along `steps` of the `Flat` tuple of `base`, a flat field of a matched record
whose leaves the context holds as variables keyed by their projections of the field: the leaf's
variable, or the tuple of the variables of the leaves under the component. -/
partial def keyedComponent? (c : Ctx) (base : Lean.Expr) (steps : List Bool) :
    MetaM (Option Reflection) := do
  if c.vars.any (·.1 == base) then return none
  if (← flatInstance? (← inferType base)).isNone then return none
  let key ← componentTerm base steps
  if let some (x, t) ← keyVar? c key then
    let src ← mkAppOptM ``Expr.var #[some c.sigs, some c.ctx, some (tyExpr t), some x]
    return some ⟨src, ← rflProof c src key, t, key, varBound c x t key, leafFits c src, none⟩
  let (``Prod, #[_, _]) := (← whnfR (← inferType key)).getAppFnArgs | return none
  let some ra ← keyedComponent? c base (steps ++ [false]) | return none
  let some rb ← keyedComponent? c base (steps ++ [true]) | return none
  let (.elem ea, .elem eb) := (ra.ty, rb.ty) | return none
  return some ⟨← mkAppM ``Expr.mk #[ra.src, rb.src], ← mkAppM ``mk_eq #[ra.proof, rb.proof],
    .elem (.prod ea eb), ← mkAppM ``Prod.mk #[ra.lean, rb.lean], binBound c ``mk_bound [] ra rb,
    binFits c ``mk_fits [] ra rb, none⟩

/-- The type `shape.hasNull = true`. -/
def hasNullType (shape : TreeShape) : MetaM Lean.Expr :=
  mkEq (mkApp (mkConst ``TreeShape.hasNull) (treeShapeExpr shape)) (mkConst ``Bool.true)

/-- The proof `rfl` of `shape.hasNull = true`, at that type. -/
def hasNullProof (shape : TreeShape) : MetaM Lean.Expr := do
  mkExpectedTypeHint trueRefl (← hasNullType shape)

/-- `fun _ => e`, the empty branch of a match on a shape with a null constructor. -/
def emptyBranchFn (shape : TreeShape) (e : Lean.Expr) : MetaM Lean.Expr := do
  withLocalDeclD `h (← hasNullType shape) fun h => mkLambdaFVars #[h] e

/-- The empty branch of a match on a shape without a null constructor, at the type `type`. -/
def absurdBranchFn (shape : TreeShape) (type : Lean.Expr) : MetaM Lean.Expr := do
  let ty ← hasNullType shape
  let falseRefl := mkApp2 (mkConst ``Eq.refl [Level.one]) (mkConst ``Bool) (mkConst ``Bool.false)
  let notNull ← mkAppOptM ``of_decide_eq_false #[some ty, none, some falseRefl]
  withLocalDeclD `h ty fun h => do
    mkLambdaFVars #[h] (← mkAppOptM ``absurd #[some ty, some type, some h, some notNull])

/-- The family of `motive` over `Fin n` whose entry `i` is `branches[i]`, as a chain of
`Fin.cases`. -/
partial def finCasesChain (motive : Lean.Expr) : Nat → List Lean.Expr → MetaM Lean.Expr
  | 0, _ => withLocalDeclD `i (mkApp (mkConst ``Fin) (mkNatLit 0)) fun i => do
    mkLambdaFVars #[i] (← mkAppOptM ``Fin.elim0 #[some (motive.beta #[i]), some i])
  | k + 1, b :: rest => do
    let motive' ← withLocalDeclD `i (mkApp (mkConst ``Fin) (mkNatLit k)) fun i => do
      mkLambdaFVars #[i] (motive.beta #[← mkAppM ``Fin.succ #[i]])
    let restFn ← finCasesChain motive' k rest
    mkAppOptM ``Fin.cases #[some (mkNatLit k), some motive, some b, some restFn]
  | _ + 1, [] => throwError "verified_compile: a match has fewer branches than records"

/-- The family of the record branches `branches` of a match on `shape` in the context `ctx`, whose
branch in a record's context `Γ` has type `type Γ`. -/
def recordFamily (shape : TreeShape) (ctx : Lean.Expr) (type : Lean.Expr → Lean.Expr)
    (branches : List Lean.Expr) : MetaM Lean.Expr := do
  let shapeE := treeShapeExpr shape
  let motive ← withLocalDeclD `r (mkApp (mkConst ``Fin) (← mkAppM ``TreeShape.records #[shapeE]))
    fun r => do mkLambdaFVars #[r] (type (← mkAppM ``TreeShape.context #[shapeE, r, ctx]))
  if shape = listShape then
    let some b := branches.head? | throwError "verified_compile: a list match has no node branch"
    return ← mkAppOptM ``listBranch #[some motive, some b]
  let type ← withLocalDeclD `r (mkApp (mkConst ``Fin) (← mkAppM ``TreeShape.records #[shapeE]))
    fun r => do mkForallFVars #[r] (motive.beta #[r])
  mkExpectedTypeHint (← finCasesChain motive shape.records branches) type

/-- A reflection under binders: the body's reflection, with its proof abstracted over the
binders and its bound not, and the binders with their declarations, which a bound restores. -/
structure Under where
  r : Reflection
  xs : Array Lean.Expr
  decls : List LocalDecl

/-- The bound of `u`'s body, abstracted over its binders. -/
def Under.bound (u : Under) : BoundBuilder := fun modes paid live =>
    withExistingLocalDecls u.decls do
  let b ← u.r.bound modes paid live
  return ⟨← mkLambdaFVars u.xs b.term, ← mkLambdaFVars u.xs b.proof⟩

/-- The frames condition of `u`'s body, abstracted over its binders. -/
def Under.fits (u : Under) : FitsBuilder := withExistingLocalDecls u.decls do
  let b ← u.r.fits
  return ⟨← mkLambdaFVars u.xs b.term, ← mkLambdaFVars u.xs b.proof⟩

/-- The credits of `u`'s body, abstracted over its binders, from the builder that the body's
reflection holds. -/
def Under.buys (u : Under) : BoundBuilder := fun modes paid live =>
    withExistingLocalDecls u.decls do
  let some b := u.r.buys
    | throwError "verified_compile: the credits of a body under binders are not available"
  let b ← b modes paid live
  return ⟨← mkLambdaFVars u.xs b.term, ← mkLambdaFVars u.xs b.proof⟩

/-- The `∀` hypothesis `ty` over `u`'s binders, instantiated at them. -/
def Under.instantiate (u : Under) (ty : Lean.Expr) : MetaM Lean.Expr :=
  instantiateForall ty u.xs

/-- Checks the hint between `own`, the chain's entry of a callee, such as
`Func.bound S g fs (rest.boundsAt fs 0) env`, and `target`, the callee's bound or frames condition,
such as `p.g.bound tuple`.  The kernel unfolds `p.g.bound`, the higher definition, to the entry at
`Env.ofArgs` and compares the two applications argument by argument, which needs every argument but
the environment identical: a difference in another would make it unfold the entry on both sides
and evaluate it. -/
def checkEntryTarget (what : MessageData) (own target : Lean.Expr) : MetaM Unit := do
  let unfolded := (← unfoldDefinition target).headBeta
  let a := own.getAppArgs
  let b := unfolded.getAppArgs
  unless own.getAppFn == unfolded.getAppFn && a.size == b.size && a.pop == b.pop do
    throwError "verified_compile: the table's entry of {what} does not match {target}"
  unless ← isDefEq a.back! b.back! do
    throwError "verified_compile: the arguments of {what} do not match {target}"

/-- The right-nested tuple of `xs`, `()` for none, with each owned array as `Moved`. -/
def argsTuple : List (Lean.Expr × Bool) → MetaM Lean.Expr
  | [] => return mkConst ``Unit.unit
  | [(x, owned)] => if owned then mkAppM ``LeanExe.Pipeline.Moved.mk #[x] else return x
  | (x, owned) :: rest => do
    let x ← if owned then mkAppM ``LeanExe.Pipeline.Moved.mk #[x] else pure x
    mkAppM ``Prod.mk #[x, ← argsTuple rest]

/-- The proof that the bounds `Prog.boundsAt prog funs k`, or the frames conditions
`Prog.fitsAt prog funs k` when `fits`, give the function that `fv` names its own entry: for a
function whose code takes no call depth, `f.bound fs (rest.boundsAt fs 0) env`, and for one whose
code does, `f.boundAt fs (rest.boundsAt fs) k env` or `f.fitsAt fs (rest.fitsAt fs) k env`.  The
chains `prog` hold `Prog.cons` and `Prog.consRec`, and `funs` holds `Funs.cons`. -/
partial def tableChain (fits : Bool) (prog funs fv env k : Lean.Expr) : MetaM Lean.Expr := do
  let (``Funs.cons, #[S, _, F, fs]) := funs.getAppFnArgs
    | throwError "verified_compile: the meanings {funs}"
  let pick (b f : Name) : Lean.Expr := mkConst (if fits then f else b)
  match fv.getAppFnArgs, prog.getAppFnArgs with
  | (``FVar.here, _), (``Prog.cons, #[_, f, rest]) =>
    let d := mkApp2 (mkConst ``Func.depth) S f
    let depth ← evalBool m!"whether the code of {f} takes the call depth" d
    let hd ← evalEq d (boolConst depth)
    if depth then
      return mkAppN (pick ``bounds_get_hereDepth ``fits_get_hereDepth)
        #[S, f, rest, F, fs, k, hd, env]
    if fits then
      throwError "verified_compile: the frames condition of {f}, whose code takes no call depth"
    return mkAppN (mkConst ``bounds_get_here) #[S, f, rest, F, fs, k, hd, env]
  | (``FVar.here, _), (``Prog.consRec, #[_, f, rest]) =>
    return mkAppN (pick ``bounds_get_hereRec ``fits_get_hereRec) #[S, f, rest, F, fs, k, env]
  | (``FVar.here, _), (``Prog.consTail, #[_, f, rest]) =>
    let d := mkApp2 (mkConst ``TailFunc.depth) S f
    let depth ← evalBool m!"whether the tail function {f} takes the call depth" d
    let hd ← evalEq d (boolConst depth)
    if depth then
      return mkAppN (pick ``bounds_get_hereTailDepth ``fits_get_hereTailDepth)
        #[S, f, rest, F, fs, k, hd, env]
    if fits then
      throwError "verified_compile: the frames condition of tail function {f}, whose code takes no call depth"
    return mkAppN (mkConst ``bounds_get_hereTail) #[S, f, rest, F, fs, k, hd, env]
  | (``FVar.there, #[_, g, _, v]), (``Prog.cons, #[_, f, rest]) =>
    transHint (mkAppN (pick ``bounds_get_there ``fits_get_there) #[S, g, f, rest, F, fs, k, v, env])
      (← tableChain fits rest fs v env k)
  | (``FVar.there, #[_, g, _, v]), (``Prog.consRec, #[_, f, rest]) =>
    transHint
      (mkAppN (pick ``bounds_get_thereRec ``fits_get_thereRec) #[S, g, f, rest, F, fs, k, v, env])
      (← tableChain fits rest fs v env k)
  | (``FVar.there, #[_, g, _, v]), (``Prog.consTail, #[_, f, rest]) =>
    transHint
      (mkAppN (pick ``bounds_get_thereTail ``fits_get_thereTail) #[S, g, f, rest, F, fs, k, v, env])
      (← tableChain fits rest fs v env k)
  | _, _ => throwError "verified_compile: the function reference {fv} in {prog}"

/-- The proof that the tables `t` give the function that `fv` names its own entry at `env`, as
`tableChain` states, with a recursive definition's own entry first. -/
def Tables.get (t : Tables) (fits : Bool) (fv env : Lean.Expr) : MetaM Lean.Expr := do
  let some (h, b, fi) := t.self | tableChain fits t.prog t.funs fv env t.fuel
  let own := if fits then fi else b
  match fv.getAppFnArgs with
  | (``FVar.here, _) =>
    return mkAppN (mkConst (if fits then ``fits_get_cons_here else ``bounds_get_cons_here))
      #[t.sigs, h, own, t.rest fits, env]
  | (``FVar.there, #[_, g, _, v]) =>
    transHint (mkAppN (mkConst (if fits then ``fits_get_cons_there else ``bounds_get_cons_there))
      #[t.sigs, g, h, own, t.rest fits, v, env]) (← tableChain fits t.prog t.funs v env t.fuel)
  | _ => throwError "verified_compile: the function reference {fv}"

structure SumCtorLayout where
  name : Name
  tag : UInt64
  fields : Array (List Bool)

structure SumLayout where
  name : Name
  flatType : Lean.Expr
  inst : Lean.Expr
  tagPath : List Bool
  ctors : Array SumCtorLayout

def projectTuple (value : Lean.Expr) : List Bool → MetaM Lean.Expr
  | [] => pure value
  | false :: rest => do projectTuple (← mkAppM ``Prod.fst #[value]) rest
  | true :: rest => do projectTuple (← mkAppM ``Prod.snd #[value]) rest

partial def firstTuplePath (type : Lean.Expr) : MetaM (List Bool) := do
  if let (``Prod, #[a, _]) := (← whnfR type).getAppFnArgs then
    return false :: (← firstTuplePath a)
  unless (← whnfR type).isConstOf ``UInt64 do
    throwError "verified_compile: a sum's Flat tuple must start with a UInt64 tag"
  return []

partial def sumLayout (type : Lean.Expr) (name : Name) : MetaM SumLayout := do
  let some (β, inst) ← flatInstance? type
    | throwError "verified_compile: {type} needs a Flat instance"
  let tagPath ← firstTuplePath β
  let info ← getConstInfoInduct name
  let ctors ← info.ctors.toArray.mapM fun ctorName => do
    let ctor ← getConstInfoCtor ctorName
    forallTelescope ctor.type fun fields _ => do
      let value := mkAppN (mkConst ctorName) fields
      let flat := mkApp4 (mkConst ``LeanExe.Pipeline.Flat.flat) type β inst value
      let tagTerm ← projectTuple flat tagPath
      let tagNat ← kernelWhnf (← mkAppM ``UInt64.toNat #[tagTerm])
      let some tag := natOf tagNat
        | throwError "verified_compile: the tag of {ctorName} is not a constant UInt64"
      let rec paths (value ty : Lean.Expr) (path : List Bool) :
          MetaM (List (Nat × List Bool)) := do
        let value ← whnf value
        if let some i := fields.findIdx? (· == value) then return [(i, path)]
        if let (``Prod, #[a, b]) := (← whnfR ty).getAppFnArgs then
          return (← paths (← mkAppM ``Prod.fst #[value]) a (path ++ [false])) ++
            (← paths (← mkAppM ``Prod.snd #[value]) b (path ++ [true]))
        return []
      let found ← paths flat β []
      let slots ← fields.mapIdxM fun i field => do
        let occurrences := found.filter (·.1 == i)
        let [(_, path)] := occurrences
          | throwError "verified_compile: the Flat instance of {type} must keep each field of \
              {ctorName} exactly once"
        if path == tagPath then
          throwError "verified_compile: the Flat instance of {type} uses a field as its tag"
        match (← shapeOf (← inferType field)).ty with
        | .elem _ | .bytes | .array _ | .tree _ => pure ()
        | _ => throwError "verified_compile: a sum field must be a scalar, `Bytes`, an array, or \
            a recursive type: {field}"
        return path
      return ({ name := ctorName, tag := UInt64.ofNat tag, fields := slots } : SumCtorLayout)
  unless (ctors.toList.map (·.tag)).eraseDups.length == ctors.size do
    throwError "verified_compile: the Flat instance of {type} repeats a constructor tag"
  return ⟨name, β, inst, tagPath, ctors⟩

partial def reduceTuple (value type : Lean.Expr) : MetaM Lean.Expr := do
  if let (``Prod, #[a, b]) := (← whnfR type).getAppFnArgs then
    let value ← whnf value
    return ← mkAppM ``Prod.mk
      #[← reduceTuple (← mkAppM ``Prod.fst #[value]) a,
        ← reduceTuple (← mkAppM ``Prod.snd #[value]) b]
  return ← projReduce value


/-- The source expression for the Lean term `e`, with the proof that it means `e`, its type, and
the builder of its bound.  An array that a reader reads and an argument with arrays that is not a
place are bound with `let` first.  A `let` of a place is replaced by its body with the place for
the variable, and every variable of a pair type is split into variables for its components, so
that a projection reads a component and a use of the whole is the pair of the components. -/
partial def reflect (c : Ctx) (e : Lean.Expr) : MetaM Reflection := do
  let e ← projReduce e
  if e.isFVar then
    if let some r ← keyedComponent? c e [] then return r.as' e
    let (x, t) ← varOf c e
    let src ← mkAppOptM ``Expr.var #[some c.sigs, some c.ctx, some (tyExpr t), some x]
    return ⟨src, ← rflProof c src (← flatValue e), t, e, varBound c x t e, leafFits c src, none⟩
  if let some r := ← reflectCall? e then return r
  if e.isConstOf ``LeanExe.Bytes.empty then
    let src ← mkAppOptM ``Expr.bytesEmpty #[some c.sigs, some c.ctx]
    return ⟨src, ← rflProof c src e, .bytes, e,
      leafBound c ``bytesEmpty_bound [], leafFits c src, none⟩
  if let some bytes ← bytesLit? e then
    let literal := toExpr bytes
    let src ← mkAppOptM ``Expr.bytesLiteral #[some c.sigs, some c.ctx, some literal]
    return ⟨src, ← rflProof c src e, .bytes, e,
      leafBound c ``bytesLiteral_bound [(`bytes, literal)], leafFits c src, none⟩
  if let some r := ← reflectRecursiveConstructor? e then return r
  if let some r := ← reflectSumConstructor? e then return r
  if let some r := ← reflectStruct? e then return r
  let shape ← shapeOf (← inferType e)
  if let some w ← enumWord? e then
    let src ← mkAppOptM ``Expr.word #[some c.sigs, some c.ctx, some w]
    return ⟨src, ← rflProof c src (← flatValue e), .word, e,
      leafBound c ``word_bound [(`v, w)], leafFits c src, none⟩
  if !e.hasFVar && !e.hasLooseBVars && shape.flat.isNone then
    match shape.ty with
    | .word =>
      if (← wordLit? e).isSome then
        let src ← mkAppOptM ``Expr.word #[some c.sigs, some c.ctx, some e]
        return ⟨src, ← rflProof c src e, .word, e, leafBound c ``word_bound [(`v, e)],
          leafFits c src, none⟩
    | .bool =>
      if e.isConstOf ``Bool.true || e.isConstOf ``Bool.false then
        let src ← mkAppOptM ``Expr.bool #[some c.sigs, some c.ctx, some e]
        return ⟨src, ← rflProof c src e, .bool, e, leafBound c ``bool_bound [(`v, e)],
          leafFits c src, none⟩
    | .float =>
      if let some bits ← floatLit? e then
        let src ← mkAppOptM ``Expr.float #[some c.sigs, some c.ctx, some (toExpr bits)]
        let prop ← mkEq (← mkAppM ``Float.toBits #[e]) (toExpr bits)
        let dec ← mkDecide prop
        let h := mkApp3 (mkConst ``of_decide_eq_true) prop dec.appArg!
          (mkApp2 (mkConst ``Eq.refl [Level.one]) (mkConst ``Bool) (mkConst ``Bool.true))
        let proof ← mkAppOptM ``float_eq #[some c.sigs, some c.ctx, some c.funs, some c.env,
          some (toExpr bits), some e, some h]
        return ⟨src, proof, .float, e, leafBound c ``float_bound [(`bits, toExpr bits)],
          leafFits c src, none⟩
    | .float32 =>
      if let some bits ← float32Lit? e then
        let src ← mkAppOptM ``Expr.float32 #[some c.sigs, some c.ctx, some (toExpr bits)]
        let prop ← mkEq (← mkAppM ``Float32.toBits #[e]) (toExpr bits)
        let dec ← mkDecide prop
        let h := mkApp3 (mkConst ``of_decide_eq_true) prop dec.appArg!
          (mkApp2 (mkConst ``Eq.refl [Level.one]) (mkConst ``Bool) (mkConst ``Bool.true))
        let proof ← mkAppOptM ``float32_eq #[some c.sigs, some c.ctx, some c.funs, some c.env,
          some (toExpr bits), some e, some h]
        return ⟨src, proof, .float32, e, leafBound c ``float32_bound [(`bits, toExpr bits)],
          leafFits c src, none⟩
    | .elem (.prod _ _) | .pair _ _ | .array _ | .tree _ | .treeHeader _ _ | .bytes => pure ()
  -- A named constant that holds no array is its value, which the kernel unfolds to it.
  if let .const name lvls := e then
    if let .defnInfo info ← getConstInfo name then
      if info.safety == .safe && shape.ty.scalar then
        try
          return ← reflectAs (info.value.instantiateLevelParams info.levelParams lvls) e
        catch
          | .error ref msg =>
            throw (.error ref m!"verified_compile: in the value of the constant {name}: {msg}")
          | ex => throw ex
  if let .letE n type value body _ := e then
    if ← isPlace value then return ← reflectAs (body.instantiate1 value) e
    let s ← tyOf type
    if (s matches .pair _ _) && !(← heapSum? type) then
      let view ← pairView c.base type
      let r ← destructure c [] value fun a b => do
        return body.instantiate1 (← view.rebuild a b)
      -- The body at the value built from the value's components is the `let`, by the view's eta.
      let lam := Lean.mkLambda n .default type body
      let eta ← view.eta lam value
      let some (_, lhs, _) := (← inferType eta).eq? | throwError "verified_compile: {eta}"
      return r.as (← restate r.proof (← mkExpectedTypeHint eta (← mkEq lhs e))) e
    let rv ← reflect c value
    -- The value's equation states the value itself, so that the body's equation substitutes it.
    let hv ← mkExpectedTypeHint rv.proof
      (← mkEq (← denoteExpr c rv.src) (← flatValue value))
    let sv ← shapeOf type
    return ← withLocalDeclD `x type fun x => do
      let env' ← mkAppOptM ``Env.cons #[some c.ctx, some (tyExpr s), some (sv.apply x), some c.env]
      let c' : Ctx := { c with vars := (x, s) :: c.vars, env := env', ctx := consCtx s c.ctx }
      let rb ← reflect c' (body.instantiate1 x)
      let ub : Under := ⟨{ rb with buys := some (buysOf c' rb) }, #[x], [← x.fvarId!.getDecl]⟩
      let hb ← mkLambdaFVars #[x] rb.proof
      let src ← mkAppM ``Expr.letE #[rv.src, rb.src]
      let proof ← if sv.flat.isNone then mkAppM ``letE_eq #[hv, hb]
        else mkAppM ``letE_flat_eq #[← sv.fn type, value, hv, hb]
      let bound : BoundBuilder := fun modes paid live => do
        let bounds := c.tables.table false
        let flatArgs ← match sv.flat with
          | none => pure []
          | some φ => pure [(`φ, φ), (`X, value)]
        let app ← LemmaApp.start (if sv.flat.isNone then ``letE_bound else ``letE_flat_bound)
          (boundArgs c bounds modes paid live ++ [(`v, rv.src), (`b, rb.src)] ++ flatArgs)
        let m ← assignMode app `m `hm
        let p ← assignPaid app
        app.assign `hv hv
        let _ ← app.child `hva rv.bound
        let bb ← ub.bound (← mkAppM ``List.cons #[m, modes]) (← mkAppM ``List.cons #[p, paid])
          (← mkAppM ``shift #[mkNatLit 1, live])
        app.assign `hba (← bb.at #[value]).proof
        boundOf (← app.finish)
      let fits : FitsBuilder := do
        let flatArgs ← match sv.flat with
          | none => pure []
          | some φ => pure [(`φ, φ), (`X, value)]
        let app ← LemmaApp.start (if sv.flat.isNone then ``letE_fits else ``letE_flat_fits)
          (fitsArgs c ++ [(`v, rv.src), (`b, rb.src)] ++ flatArgs)
        app.assign `hv hv
        app.childFits `hvf rv.fits
        app.childFits `hbf (do (← ub.fits).at #[value])
        fitsOf (← app.finish)
      let buys : BoundBuilder := fun modes paid live => do
        let flatArgs ← match sv.flat with
          | none => pure []
          | some φ => pure [(`φ, φ), (`X, value)]
        let app ← LemmaApp.start (if sv.flat.isNone then ``letE_buys else ``letE_flat_buys)
          (buysArgs c modes paid live ++ [(`v, rv.src), (`b, rb.src)] ++ flatArgs)
        let m ← assignMode app `m `hm
        let p ← assignPaid app
        app.assign `hv hv
        let bb ← ub.buys (← mkAppM ``List.cons #[m, modes]) (← mkAppM ``List.cons #[p, paid])
          (← mkAppM ``shift #[mkNatLit 1, live])
        app.assign `hy (← bb.at #[value]).proof
        boundOf (← app.finish)
      return ⟨src, ← restate proof (← bareEq (body.instantiate1 value) e), rb.ty, e, bound, fits,
        some buys⟩
  if let some app ← matchMatcherApp? e then
    if app.discrs.size != 1 then
      throwError "verified_compile: a match on several values is not supported, in {e}"
    if app.discrInfos.any (·.hName?.isSome) then
      throwError "verified_compile: `match h : …` is not supported, in {e}"
    if let (``List, #[el]) := (← whnfR (← inferType app.discrs[0]!)).getAppFnArgs then
      if (← whnfR el).isConstOf ``UInt64 then return ← reflectTreeMatch app none
    if let some layout ← recursiveLayout? (← inferType app.discrs[0]!) then
      return ← reflectTreeMatch app (some layout)
    if let some (n, _) ← enumFlat? (← inferType app.discrs[0]!) then
      return ← reflectDataMatch app n
    if let some name ← sumName? (← inferType app.discrs[0]!) then
      return ← reflectDataMatch app name
    if app.alts.size == 1 then
      let alt := app.alts[0]!
      let d := app.discrs[0]!
      -- A pair built in place whose pattern binds its two components becomes `let` bindings of
      -- the components.  A pattern that takes a component further apart binds the pair first, as
      -- for any other value.
      if (← projReduce d).isAppOf ``Prod.mk && app.altNumParams[0]! == 2 then
        let fs ← matchFields app d
        let lets ← withLetDecl `a (← inferType fs[0]!) fs[0]! fun a => do
          withLetDecl `b (← inferType fs[1]!) fs[1]! fun b => mkLetFVars #[a, b] (alt.beta #[a, b])
        return ← reflectAs lets e
      if let some (_, fields) ← structOf? (← inferType d) then
        -- The fields of a structure are its projections, of a variable bound to it first.
        let fieldsOf (y : Lean.Expr) : MetaM (Array Lean.Expr) := fields.mapM (mkProjection y)
        let r ← if ← isPlace d then reflect c (alt.beta (← fieldsOf d))
          else reflect c (← withLetDecl `t (← inferType d) d fun y => do
            mkLetFVars #[y] (alt.beta (← fieldsOf y)))
        return r.as (← restate r.proof (← casesEq app fieldsOf)) e
      if let .elem _ ← tyOf (← inferType d) then
        -- The components of a tuple are its projections, of a variable bound to it first.
        let r ←
          if (← projReduce d).isFVar then reflect c (alt.beta (← matchFields app d))
          else reflect c (← withLetDecl `t (← inferType d) d fun y => do
            mkLetFVars #[y] (alt.beta (← matchFields app y)))
        return r.as (← restate r.proof (← casesEq app (matchFields app))) e
      let r ← destructure c [] d fun a b => do
        return alt.beta (← matchFields app (← mkAppM ``Prod.mk #[a, b]))
      return r.as (← restate r.proof (← casesEq app (matchFields app))) e
  if let some (_, p) ← structProj? e then
    if (← structOf? (← inferType p)).isSome then return ← reflectProj e
  let (fn, args) := e.getAppFnArgs
  if let some op := binOp? fn then
    if args.size == 6 && (← isFloat args[0]!) then
      let some fop := fbinOp? fn
        | throwError "verified_compile: unsupported operation {fn} on {args[0]!}"
      let rl ← reflect c args[4]!
      let rr ← reflect c args[5]!
      let fp32 := rl.ty == .float32
      return ⟨← mkAppM (if fp32 then ``Expr.fbin32 else ``Expr.fbin) #[fop, rl.src, rr.src],
        ← mkAppM (if fp32 then ``fbin32_eq else ``fbin_eq) #[fop, rl.proof, rr.proof],
        (if fp32 then .float32 else .float), e,
        binBound c (if fp32 then ``fbin32_bound else ``fbin_bound) [(`op, fop)] rl rr,
        binFits c (if fp32 then ``fbin32_fits else ``fbin_fits) [(`op, fop)] rl rr, none⟩
    if args.size == 6 then
      let rl ← reflect c args[4]!
      let rr ← reflect c args[5]!
      return ⟨← mkAppM ``Expr.bin #[op, rl.src, rr.src],
        ← mkAppM ``bin_eq #[op, rl.proof, rr.proof], .word, e,
        binBound c ``bin_bound [(`op, op)] rl rr, binFits c ``bin_fits [(`op, op)] rl rr, none⟩
  match fn, args with
  | ``Decidable.decide, #[p, inst] =>
    if let (``Ne, #[_, a, b]) := p.consumeMData.getAppFnArgs then
      -- `decide (a ≠ b)` is `!decide (a = b)`.
      let notEq ← mkAppOptM ``decide_not #[some (← mkEq a b), none, some inst]
      let T ← mkAppM ``not #[← mkDecide (← mkEq a b)]
      return ← reflectVia T (← mkExpectedTypeHint (← mkEqSymm notEq) (← mkEq T e))
    if let (``Eq, #[α, a, b]) := p.consumeMData.getAppFnArgs then
      if (← whnfR α).isConstOf ``Bool then
        return ← reflectVia (← boolEqTerm a b)
          (← mkAppOptM ``bool_decide_eq #[some a, some b, some inst])
    if let some r ← enumDecide? p inst then return r
    if let some (op, a, b) ← fcomparison? p then return (← reflectFCmp op a b).as' e
    let some (op, a, b) ← comparison? p
      | throwError "verified_compile: unsupported decision {p}"
    return (← reflectCmp op a b).as' e
  | ``BEq.beq, #[α, inst, a, b] =>
    if (← whnfR α).isConstOf ``Bool then
      let lawful ← enumLawful α inst
      return ← reflectVia (← boolEqTerm a b)
        (← mkAppOptM ``bool_beq_eq #[some inst, some lawful, some a, some b])
    if let some r ← enumBEq? ``BEq.beq ``flat_beq α inst a b then return r
    let r ← if ← isFloat α then reflectFCmp .eq a b else reflectCmp .eq a b
    return r.as' e
  | ``bne, #[α, inst, a, b] =>
    if (← whnfR α).isConstOf ``Bool then
      return ← reflectAs (← mkAppM ``not #[← mkAppOptM ``BEq.beq
        #[some α, some inst, some a, some b]]) e
    if let some r ← enumBEq? ``bne ``flat_bne α inst a b then return r
    if ← isFloat α then
      let r ← reflectFCmp .eq a b
      return ⟨← mkAppM ``Expr.not #[r.src], ← mkAppM ``not_eq #[r.proof], .bool, e,
        unBound c ``not_bound [] r, unFits c ``not_fits [] r, none⟩
    return (← reflectCmp .ne a b).as' e
  | ``Neg.neg, #[α, _, x] =>
    unless ← isFloat α do throwError "verified_compile: unsupported negation {e}"
    let op := if (← whnfR α).isConstOf ``Float32 then ``F32UnOp.neg else ``FUnOp.neg
    return (← reflectFUnary (mkConst op) x).as' e
  | ``Float.sqrt, #[x] => return (← reflectFUnary (mkConst ``FUnOp.sqrt) x).as' e
  | ``Float32.sqrt, #[x] => return (← reflectFUnary (mkConst ``F32UnOp.sqrt) x).as' e
  | ``Float32.abs, #[x] => return (← reflectFUnary (mkConst ``F32UnOp.abs) x).as' e
  | ``LeanExe.Float32.nearest, #[x] =>
    return (← reflectFUnary (mkConst ``F32UnOp.nearest) x).as' e
  | ``UInt64.toFloat32, #[x] =>
    return (← reflectConv ``Expr.toFloat32 ``toFloat32_eq ``toFloat32_bound ``toFloat32_fits
      (mkConst ``ToFloat32.convert) x .float32).as' e
  | ``Float32.ofBits, #[bits] =>
    let (``UInt64.toUInt32, #[x]) := bits.consumeMData.getAppFnArgs
      | throwError "verified_compile: Float32.ofBits expects a UInt64 converted to UInt32"
    return (← reflectConv ``Expr.toFloat32 ``toFloat32_eq ``toFloat32_bound ``toFloat32_fits
      (mkConst ``ToFloat32.ofBits) x .float32).as' e
  | ``Int32.toFloat32, #[value] =>
    let (``Int32.ofUInt32, #[bits]) := value.consumeMData.getAppFnArgs
      | throwError "verified_compile: Int32.toFloat32 expects the low bits of a UInt64"
    let (``UInt64.toUInt32, #[x]) := bits.consumeMData.getAppFnArgs
      | throwError "verified_compile: Int32.toFloat32 expects a UInt64 converted to UInt32"
    return (← reflectConv ``Expr.toFloat32 ``toFloat32_eq ``toFloat32_bound ``toFloat32_fits
      (mkConst ``ToFloat32.signed32) x .float32).as' e
  | ``Float32.toUInt64, #[x] =>
    return (← reflectConv ``Expr.toWord32 ``toWord32_eq ``toWord32_bound ``toWord32_fits
      (mkConst ``ToWord32.truncate) x .word).as' e
  | ``UInt32.toUInt64, #[bits] =>
    match bits.consumeMData.getAppFnArgs with
    | (``Float32.toBits, #[x]) =>
      return (← reflectConv ``Expr.toWord32 ``toWord32_eq ``toWord32_bound ``toWord32_fits
        (mkConst ``ToWord32.toBits) x .word).as' e
    | (``Int32.toUInt32, #[value]) =>
      let (``Float32.toInt32, #[x]) := value.consumeMData.getAppFnArgs
        | throwError "verified_compile: unsupported UInt32 conversion {e}"
      return (← reflectConv ``Expr.toWord32 ``toWord32_eq ``toWord32_bound ``toWord32_fits
        (mkConst ``ToWord32.signed32) x .word).as' e
    | _ => throwError "verified_compile: unsupported UInt32 conversion {e}"
  | ``UInt64.toFloat, #[x] =>
    return (← reflectConv ``Expr.toFloat ``toFloat_eq ``toFloat_bound ``toFloat_fits
      (mkConst ``ToFloat.convert) x .float).as' e
  | ``Float.ofBits, #[x] =>
    return (← reflectConv ``Expr.toFloat ``toFloat_eq ``toFloat_bound ``toFloat_fits
      (mkConst ``ToFloat.ofBits) x .float).as' e
  | ``Float.toUInt64, #[x] =>
    return (← reflectConv ``Expr.toWord ``toWord_eq ``toWord_bound ``toWord_fits
      (mkConst ``ToWord.truncate) x .word).as' e
  | ``Float.toBits, #[x] =>
    return (← reflectConv ``Expr.toWord ``toWord_eq ``toWord_bound ``toWord_fits
      (mkConst ``ToWord.toBits) x .word).as' e
  | ``Float.abs, #[x] => return (← reflectFUnary (mkConst ``FUnOp.abs) x).as' e
  | ``Min.min, #[α, inst, a, b] | ``Max.max, #[α, inst, a, b] =>
    unless (← isFloat α) || (← whnfR α).isConstOf ``UInt64 do
      throwError "verified_compile: unsupported {fn} on {α}"
    -- `min` and `max` on floats and words are `if a ≤ b`, with operands that are not variables
    -- bound first.
    let bind := [false, false, !(← projReduce a).isFVar, !(← projReduce b).isFVar]
    if bind.any id then
      return ← reflectAs (← bindArgs e.getAppFn [α, inst, a, b] bind #[] #[]) e
    let cond ← mkAppM ``LE.le #[a, b]
    let t ← if fn == ``Min.min then mkAppM ``ite #[cond, a, b] else mkAppM ``ite #[cond, b, a]
    let r ← reflect c t
    return r.as (← mkExpectedTypeHint r.proof (← mkEq (← denoteExpr c r.src) e)) e
  | ``not, #[a] =>
    let r ← reflect c a
    return ⟨← mkAppM ``Expr.not #[r.src], ← mkAppM ``not_eq #[r.proof], .bool, e,
      unBound c ``not_bound [] r, unFits c ``not_fits [] r, none⟩
  | ``and, #[a, b] =>
    let rl ← reflect c a
    let rr ← reflect c b
    return ⟨← mkAppM ``Expr.and #[rl.src, rr.src], ← mkAppM ``and_eq #[rl.proof, rr.proof],
      .bool, e, binBound c ``and_bound [] rl rr, binFits c ``and_fits [] rl rr, none⟩
  | ``or, #[a, b] =>
    let rl ← reflect c a
    let rr ← reflect c b
    return ⟨← mkAppM ``Expr.or #[rl.src, rr.src], ← mkAppM ``or_eq #[rl.proof, rr.proof],
      .bool, e, binBound c ``or_bound [] rl rr, binFits c ``or_fits [] rl rr, none⟩
  | ``List.nil, #[α] =>
    unless (← whnfR α).isConstOf ``UInt64 do
      throwError "verified_compile: lists require UInt64 elements, in {e}"
    let h ← hasNullProof listShape
    let src ← mkAppOptM ``Expr.treeNil
      #[some c.sigs, some c.ctx, some (treeShapeExpr listShape), some h]
    return ⟨src, ← rflProof c src (← flatValue e), .tree listShape, e,
      leafBound c ``treeNil_bound [(`shape, treeShapeExpr listShape), (`h, h)],
      leafFits c src, none⟩
  | ``List.cons, #[α, a, b] =>
    unless (← whnfR α).isConstOf ``UInt64 do
      throwError "verified_compile: lists require UInt64 elements, in {e}"
    let ra ← reflect c a
    let rb ← reflect c b
    let header := mkApp2 (mkConst ``Var) c.ctx (tyExpr (.treeHeader listShape listCell))
    let reuse ← match c.vars.find? (fun (_, ty) => ty == .treeHeader listShape listCell) with
      | none => mkAppOptM ``Option.none #[some header]
      | some (value, _) => do
        let (x, _) ← varOf c value
        mkAppOptM ``Option.some #[some header, some x]
    let family (r : Reflection) : MetaM Lean.Expr :=
      withLocalDeclD `i (mkApp (mkConst ``Fin) (mkNatLit 1)) fun i =>
        mkLambdaFVars #[i] r.src
    let src ← mkAppM ``Expr.treeNode #[mkConst ``listCell, reuse, ← family ra,
      ← arrayExprFamily c listShape listCell [], ← bufferExprFamily c listShape listCell [],
      ← family rb]
    let parts := [(`reuse, reuse), (`head, ra.src), (`tail, rb.src)]
    let proof ← (← LemmaApp.start ``listCons_eq
      ([(`S, c.sigs), (`Γ, c.ctx), (`funs, c.funs), (`env, c.env)] ++ parts ++
        [(`hh, ra.proof), (`ht, rb.proof)])).finish
    let bound : BoundBuilder := fun modes paid live => do
      let app ← LemmaApp.start ``listCons_bound
        (boundArgs c (c.tables.table false) modes paid live ++ parts)
      let _ ← app.child `hh ra.bound
      let _ ← app.child `ht rb.bound
      let _ ← assignCoerce c.base app `hk (.tree listShape) b
      let some (_, parent, _) := (← app.hypType `hp).eq?
        | throwError "verified_compile: malformed parent allocation equation"
      app.assign `hp (← evalEq parent (← evalNat parent))
      boundOf (← app.finish)
    return ⟨src, proof, .tree listShape, e, bound,
      formFits c ``listCons_fits parts [(`hh, ra), (`ht, rb)], none⟩
  | ``Prod.mk, #[_, _, a, b] =>
    let ra ← reflect c a
    let rb ← reflect c b
    if let (.elem ea, .elem eb) := (ra.ty, rb.ty) then
      return ⟨← mkAppM ``Expr.mk #[ra.src, rb.src], ← mkAppM ``mk_eq #[ra.proof, rb.proof],
        .elem (.prod ea eb), e, binBound c ``mk_bound [] ra rb, binFits c ``mk_fits [] ra rb, none⟩
    return ⟨← mkAppM ``Expr.pair #[ra.src, rb.src], ← mkAppM ``pair_eq #[ra.proof, rb.proof],
      .pair ra.ty rb.ty, e, pairBound ra rb,
      formFits c ``pair_fits [(`a, ra.src), (`b, rb.src)] [(`ha, ra), (`hb, rb)], none⟩
  | ``LeanExe.Pipeline.Flat.flat, #[α, _, inst, a] =>
    let some (_, flatInst) ← flatInstance? α | throwError "verified_compile: unsupported term {e}"
    unless ← kernelDefEq inst flatInst do
      throwError "verified_compile: {e} uses a `Flat` instance other than {flatInst}"
    return (← reflect c a).as' e
  | ``Prod.fst, #[_, _, p] =>
    if let .elem _ ← tyOf (← inferType p) then reflectProj e
    else return (← destructure c [] p fun a _ => return a).as' e
  | ``Prod.snd, #[_, _, p] =>
    if let .elem _ ← tyOf (← inferType p) then reflectProj e
    else return (← destructure c [] p fun _ b => return b).as' e
  | ``dite, #[α, p, inst, a, b] =>
    -- `if h : p then a else b` whose branches do not use `h` is `if p then a else b`.
    let .lam _ _ ta _ := a.consumeMData | throwError "verified_compile: unsupported term {e}"
    let .lam _ _ tb _ := b.consumeMData | throwError "verified_compile: unsupported term {e}"
    if ta.hasLooseBVars || tb.hasLooseBVars then
      throwError "verified_compile: the branches of {e} use the hypothesis of the `if`"
    reflectAs (← mkAppOptM ``ite #[some α, some p, some inst, some ta, some tb]) e
  | ``ite, #[α, p, inst, a, b] =>
    if let some r ← enumIte? α p inst a b then return r
    let r ← reflectIte p inst a b
    let some φ := (← shapeOf α).flat | return r.as' e
    -- The `if` of the flattenings is the flattening of the `if`.
    let comm ← mkAppOptM ``apply_ite #[none, none, some φ, some p, some inst, some a, some b]
    return r.as (← mkEqTrans r.proof (← mkEqSymm comm)) e
  | ``LeanExe.loop, #[α, n, init, f] =>
    let rn ← reflect c n
    let ri ← reflect c init
    let u ← reflectUnder c [] (mkConst ``UInt64) α .word ri.ty fun i acc =>
      return f.beta #[i, acc]
    let rb := u.r
    let cs ← mkAppOptM ``Expr.bool
      #[some c.sigs, some (consCtx ri.ty c.ctx), some (mkConst ``Bool.true)]
    let sa ← shapeOf α
    let src ← mkAppM ``Expr.loop #[rn.src, ri.src, cs, rb.src]
    let proof ← if sa.flat.isNone then mkAppM ``loop_eq #[rn.proof, ri.proof, rb.proof]
      else mkAppM ``loop_flat_eq #[← sa.fn α, init, f, rn.proof, ri.proof, rb.proof]
    -- The condition `true` costs nothing at every state, and means `true`.
    let condTrue ← withLocalDeclD `s α fun s => mkLambdaFVars #[s] (mkConst ``Bool.true)
    let hc (cTy : Lean.Expr) : MetaM Lean.Expr := withLocalDeclD `s α fun s => do
      mkExpectedTypeHint (← mkLambdaFVars #[s] (← mkEqRefl (mkConst ``Bool.true))) cTy
    let bound := loopBound rn ri u cs α init condTrue hc f (fun hcaTy bounds => do
        forallTelescope hcaTy fun xs eq => do
          let some (_, lhs, _) := eq.eq? | throwError "verified_compile: the condition of {e}"
          let args := lhs.getAppArgs
          let proof ← (← LemmaApp.start ``bool_bound [(`S, c.sigs), (`Γ, args[7]!),
            (`funs, c.funs), (`flags, args[2]!), (`bounds, bounds), (`modes, args[4]!),
            (`paid, args[5]!), (`live, args[6]!), (`env, args[10]!),
            (`v, mkConst ``Bool.true)]).finish
          return (← mkLambdaFVars xs natZero, ← mkLambdaFVars xs proof))
    return ⟨src, ← mkExpectedTypeHint proof (← mkEq (← denoteExpr c src) (← flatValue e)),
      ri.ty, e, bound, loopFits rn ri u cs α init condTrue hc f none, none⟩
  | ``List.foldl, foldArgs@#[α, β, f, init, xs] =>
    unless β.isConstOf ``UInt64 do
      throwError "verified_compile: List.foldl requires List UInt64, in {e}"
    let xs ← projReduce xs
    unless xs.isFVar do
      return ← reflectAs (← withLetDecl `xs (← inferType xs) xs fun value =>
        mkLetFVars #[value] (mkAppN e.getAppFn (foldArgs.set! 4 value))) e
    let shape ← shapeOf α
    let .elem el := shape.ty
      | throwError "verified_compile: List.foldl requires a scalar accumulator, in {e}"
    let ri ← reflect c init
    let captured := c.vars.filter fun (value, _) =>
      (value.find? fun part => part.isFVar && f.containsFVar part.fvarId!).isSome
    let captureTypes := ctxExpr (captured.map (·.2))
    let capturedEnv ← envExpr captured
    let reflections ← (xs :: init :: captured.map (·.1)).mapM (reflect c)
    let nilArgs ← mkAppOptM ``Args.nil #[some c.sigs, some c.ctx]
    let argList ← reflections.foldrM (fun r rest => mkAppM ``Args.cons #[r.src, rest]) nilArgs
    let args ← mkAppM ``Args.get #[argList]
    let nilEq ← mkAppOptM ``ofFn_nil_eq #[some c.sigs, some c.ctx, some c.funs, some c.env]
    let hargs ← reflections.foldrM (fun r rest => mkAppM ``ofFn_cons_eq #[r.proof, rest]) nilEq
    let u ← withLocalDeclD `current (← inferType xs) fun current =>
      withLocalDeclD `acc α fun acc => do
        let vars := [(current, .tree listShape), (acc, .elem el)] ++ captured
        let (ctx, env) ← ctxEnvExpr vars
        withListCaseFields { c with vars, ctx, env } current fun inner head tail => do
          let r ← reflect inner (f.beta #[acc, head])
          let binders := #[current, acc, head, tail]
          pure (⟨{ r with proof := ← userProof inner r }, binders,
            ← binders.toList.mapM fun value => value.fvarId!.getDecl⟩ : Under)
    let specialize (term : Lean.Expr) : MetaM Lean.Expr := withExistingLocalDecls u.decls do
      let current ← mkAppM ``List.cons #[u.xs[2]!, u.xs[3]!]
      mkLambdaFVars #[u.xs[2]!, u.xs[3]!, u.xs[1]!]
        (term.replaceFVars #[u.xs[0]!] #[current])
    let hstep ← specialize u.r.proof
    let common := [(`S, c.sigs), (`Γ, c.ctx), (`funs, c.funs), (`env, c.env),
      (`flatten, ← shape.fn α), (`args, args), (`argList, argList), (`body, u.r.src),
      (`xs, xs), (`init, init), (`step, f), (`captured, capturedEnv)]
    let rule (name : Name) (extra : List (Name × Lean.Expr)) : MetaM LemmaApp := do
      let app ← LemmaApp.start name (extra ++ common)
      app.assign `hargs (← mkExpectedTypeHint hargs (← app.hypType `hargs))
      app.assign `hstep (← mkExpectedTypeHint hstep (← app.hypType `hstep))
      return app
    let src ← mkAppM ``Expr.listFold #[args, u.r.src]
    let proof ← (← rule ``listFold_eq []).finish
    let bound : BoundBuilder := fun modes paid live => do
      let app ← rule ``listFold_bound (boundArgs c (c.tables.table false) modes paid live)
      let some (_, lhs, _) := (← app.hypType `hI).eq?
        | throwError "verified_compile: the list fold's argument bound"
      let parts := lhs.getAppArgs
      let hI ← argsCostBound (c.tables.table false) modes paid
        parts[parts.size - 6]! parts[parts.size - 5]! parts[parts.size - 3]!
        (reflections.map fun r => (r, r.ty)) argList
      app.assign `I (← boundOf hI).term
      app.assign `hI (← boundOf hI).proof
      let bodyModes := modesExpr
        (List.replicate (listShape.bindCount listCell + 2 + captured.length) .borrowed)
      let bodyPaid := listExpr (mkConst ``Bool)
        (List.replicate (listShape.bindCount listCell + 2 + captured.length) (boolConst false))
      let bodyLive := mkApp2 (mkConst ``ListFold.bodyLive) (elemExpr el) captureTypes
      let b ← withExistingLocalDecls u.decls do u.r.bound bodyModes bodyPaid bodyLive
      app.assign `B (← specialize b.term)
      app.assign `hB (← mkExpectedTypeHint (← specialize b.proof) (← app.hypType `hB))
      boundOf (← app.finish)
    let fits : FitsBuilder := do
      let app ← rule ``listFold_fits (fitsArgs c)
      let initial ← fitsOf (← argsFits reflections argList)
      app.assign `I initial.term
      app.assign `hI initial.proof
      let b ← withExistingLocalDecls u.decls do u.r.fits
      app.assign `B (← specialize b.term)
      app.assign `hB (← mkExpectedTypeHint (← specialize b.proof) (← app.hypType `hB))
      fitsOf (← app.finish)
    return ⟨src, ← mkExpectedTypeHint proof (← mkEq (← denoteExpr c src) (← flatValue e)),
      ri.ty, e, bound, fits, none⟩
  | ``Array.foldl, foldArgs@#[α, β, f, init, xs, start, stop] =>
    unless ← kernelDefEq start natZero do
      throwError "verified_compile: Array.foldl requires start = 0, in {e}"
    unless ← kernelDefEq stop (← mkAppM ``Array.size #[xs]) do
      throwError "verified_compile: Array.foldl requires stop = xs.size, in {e}"
    let se ← shapeOf α
    let .elem el := se.ty | throwError "verified_compile: unsupported array {e}"
    let xs ← projReduce xs
    unless xs.isFVar do
      return ← reflectAs (← withLetDecl `a (← inferType xs) xs fun a => do
        let args := (foldArgs.set! 4 a).set! 6 (← mkAppM ``Array.size #[a])
        mkLetFVars #[a] (mkAppN e.getAppFn args)) e
    let (x, t) ← varOf c xs
    unless t == .array el do throwError "verified_compile: {xs} is not an array variable"
    let ri ← reflect c init
    let u ← reflectUnder3 c (mkConst ``UInt64) β α .word ri.ty (.elem el)
      fun _ acc value => return f.beta #[acc, value]
    let src ← mkAppM ``Expr.fold #[x, ri.src, u.r.src]
    let vx ← mkAppOptM ``Expr.var
      #[some c.sigs, some c.ctx, some (tyExpr (.array el)), some x]
    let hx ← rflProof c vx (← flatValue xs)
    let hx ← if se.flat.isNone then
        mkEqTrans hx (← mkEqSymm (← mkAppM ``Array.map_id #[xs]))
      else pure hx
    let hx ← mkExpectedTypeHint hx
      (← mkEq (← mkAppM ``Env.get #[c.env, x]) (← mkAppM ``Array.map #[← se.fn α, xs]))
    let sb ← shapeOf β
    let proof ← mkAppM ``fold_flat_eq
      #[← sb.fn β, ← se.fn α, xs, init, f, hx, ri.proof, u.r.proof]
    return ⟨src, ← mkExpectedTypeHint proof (← mkEq (← denoteExpr c src) (← flatValue e)),
      ri.ty, e, foldBound ri u α β xs init f x hx, foldFits ri u α β xs init f x hx, none⟩
  | ``LeanExe.repeatWhile, #[α, n, init, cnd, step] =>
    let rn ← reflect c n
    let ri ← reflect c init
    let uc ← reflectUnder1 c α ri.ty fun acc => return cnd.beta #[acc]
    let rc := uc.r
    let u ← reflectUnder c [] (mkConst ``UInt64) α .word ri.ty fun _ acc =>
      return step.beta #[acc]
    let rb := u.r
    let sa ← shapeOf α
    let src ← mkAppM ``Expr.loop #[rn.src, ri.src, rc.src, rb.src]
    let proof ← if sa.flat.isNone then
        mkAppM ``repeatWhile_eq #[rn.proof, ri.proof, cnd, step, rc.proof, rb.proof]
      else mkAppM ``repeatWhile_flat_eq #[← sa.fn α, init, cnd, step, rn.proof, ri.proof,
        rc.proof, rb.proof]
    let F ← withLocalDeclD `i (mkConst ``UInt64) fun i => withLocalDeclD `s α fun s => do
      mkLambdaFVars #[i, s] (step.beta #[s])
    let hc (cTy : Lean.Expr) : MetaM Lean.Expr := mkExpectedTypeHint rc.proof cTy
    let bound := loopBound rn ri u rc.src α init cnd hc F
      (fun hcaTy _ => withExistingLocalDecls uc.decls do
        let ty ← uc.instantiate hcaTy
        let some (_, lhs, _) := ty.eq? | throwError "verified_compile: the condition of {e}"
        let args := lhs.getAppArgs
        let b ← rc.bound args[4]! args[5]! args[6]!
        return (← mkLambdaFVars uc.xs b.term, ← mkLambdaFVars uc.xs b.proof))
    return ⟨src, ← mkExpectedTypeHint proof (← mkEq (← denoteExpr c src) (← flatValue e)),
      ri.ty, e, bound, loopFits rn ri u rc.src α init cnd hc F (some uc.fits), none⟩
  | ``Array.mk, #[α, xs] =>
    unless xs.consumeMData.isAppOfArity ``List.nil 1 do
      throwError "verified_compile: unsupported term {e}"
    let .elem el := (← shapeOf α).ty | throwError "verified_compile: unsupported array {e}"
    let value ← elemZero el
    let f ← withLocalDeclD `i (mkConst ``UInt64) fun i => mkLambdaFVars #[i] value
    let r ← reflect c (← mkAppM ``LeanExe.build #[toExpr (0 : UInt64), f])
    return r.as (← mkExpectedTypeHint r.proof
      (← mkEq (← denoteExpr c r.src) (← flatValue e))) e
  | ``Array.setIfInBounds, #[α, xs, k, v] =>
    reflectAs (← mkAppOptM ``Array.set! #[some α, some xs, some k, some v]) e
  | ``Array.insertIdxIfInBounds, #[α, xs, k, v] =>
    let (``UInt64.toNat, #[i]) := k.consumeMData.getAppFnArgs
      | throwError "verified_compile: a position must be `i.toNat` for a word `i`, in {e}"
    reflectAs (← mkAppOptM ``LeanExe.insertAt #[some α, some xs, some i, some v]) e
  | ``Array.insertIdx!, insertArgs@#[α, xs, k, v] =>
    let (``UInt64.toNat, #[i]) := k.consumeMData.getAppFnArgs
      | throwError "verified_compile: a position must be `i.toNat` for a word `i`, in {e}"
    let xs ← projReduce xs
    unless xs.isFVar do
      return ← reflectAs (← withLetDecl `a (← inferType xs) xs fun a =>
        mkLetFVars #[a] (mkAppN e.getAppFn (insertArgs.set! 1 a))) e
    let i ← projReduce i
    unless i.isFVar do
      return ← reflectAs (← withLetDecl `index (mkConst ``UInt64) i fun index => do
        let k ← mkAppM ``UInt64.toNat #[index]
        mkLetFVars #[index] (mkAppN e.getAppFn (insertArgs.set! 2 k))) e
    let term ← mkAppM ``arrayInsertIdx #[xs, i, v]
    let some expanded ← unfoldDefinition? term
      | throwError "verified_compile: cannot unfold {term}"
    return ← reflectVia expanded.headBeta
      (← mkExpectedTypeHint (← mkAppM ``arrayInsertIdx_eq #[xs, i, v]) (← mkEq expanded.headBeta e))
  | ``arrayIndexLeSize, #[α, xs, index] =>
    let (x, t) ← varOf c xs
    let .array el := t | throwError "verified_compile: {xs} is not an array variable"
    let (i, ti) ← varOf c index
    unless ti == .word do throwError "verified_compile: {index} is not a word variable"
    let src ← mkAppOptM ``Expr.leSize #[some c.sigs, some c.ctx, none, some x, some i]
    let se ← shapeOf α
    let hx ← arrayEq x xs
    let hx ← if se.flat.isNone then
        mkEqTrans hx (← mkEqSymm (← mkAppM ``Array.map_id #[xs]))
      else pure hx
    let proof ← mkAppOptM ``leSize_map_eq
      #[some c.sigs, some c.ctx, some c.funs, some c.env, some (elemExpr el), some α,
        some (← se.fn α), some x, some i, some xs, some index, some hx, some (← rflProof c
          (← mkAppOptM ``Expr.var #[some c.sigs, some c.ctx, some (tyExpr .word), some i]) index)]
    return ⟨src, proof, .bool, e, leafBound c ``leSize_bound [(`x, x), (`i, i)],
      leafFits c src, none⟩
  | ``Array.eraseIdxIfInBounds, #[α, xs, k] =>
    let (``UInt64.toNat, #[i]) := k.consumeMData.getAppFnArgs
      | throwError "verified_compile: a position must be `i.toNat` for a word `i`, in {e}"
    reflectAs (← mkAppOptM ``LeanExe.eraseAt #[some α, some xs, some i]) e
  | ``Array.set!, setArgs@#[α, xs, k, v] =>
    let se ← shapeOf α
    let .elem el := se.ty | throwError "verified_compile: unsupported array {e}"
    let (``UInt64.toNat, #[i]) := k.consumeMData.getAppFnArgs
      | throwError "verified_compile: a position must be `i.toNat` for a word `i`, in {e}"
    let xs ← projReduce xs
    unless xs.isFVar do
      return ← reflectAs (← withLetDecl `a (← inferType xs) xs fun a =>
        mkLetFVars #[a] (mkAppN e.getAppFn (setArgs.set! 1 a))) e
    let (x, t) ← varOf c xs
    unless t == .array el do throwError "verified_compile: {xs} is not an array variable"
    let ri ← reflect c i
    let rv ← reflect c v
    let src ← mkAppOptM ``Expr.set
      #[some c.sigs, some c.ctx, none, some x, some ri.src, some rv.src]
    let bound : BoundBuilder := fun modes paid live => do
      let bounds := c.tables.table false
      let app ← LemmaApp.start ``set_bound (boundArgs c bounds modes paid live ++
        [(`e, elemExpr el), (`x, x), (`i, ri.src), (`v, rv.src)])
      let _ ← app.child `hi ri.bound
      let _ ← app.child `hv rv.bound
      app.assign `hx (← varOwnedEq c modes live x (.array el) xs)
      boundOf (← app.finish)
    let fits := formFits c ``set_fits [(`e, elemExpr el), (`x, x), (`i, ri.src), (`v, rv.src)]
      [(`hi, ri), (`hv, rv)]
    if se.flat.isNone then
      return ⟨src, ← mkAppM ``set_eq #[x, ri.proof, rv.proof], .array el, e, bound, fits, none⟩
    return ⟨src,
      ← mkAppM ``set_map_eq #[← se.fn α, x, xs, v, ← arrayEq x xs, ri.proof, rv.proof],
      .array el, e, bound, fits, none⟩
  | ``Array.push, pushArgs@#[α, xs, v] =>
    let se ← shapeOf α
    let .elem el := se.ty | throwError "verified_compile: unsupported array {e}"
    let xs ← projReduce xs
    unless xs.isFVar do
      return ← reflectAs (← withLetDecl `a (← inferType xs) xs fun a =>
        mkLetFVars #[a] (mkAppN e.getAppFn (pushArgs.set! 1 a))) e
    let (x, t) ← varOf c xs
    unless t == .array el do throwError "verified_compile: {xs} is not an array variable"
    let rv ← reflect c v
    let src ← mkAppOptM ``Expr.push #[some c.sigs, some c.ctx, none, some x, some rv.src]
    let bound : BoundBuilder := fun modes paid live => do
      let bounds := c.tables.table false
      let app ← LemmaApp.start ``push_bound (boundArgs c bounds modes paid live ++
        [(`e, elemExpr el), (`x, x), (`v, rv.src)])
      let k ← assignExtension app el
      let _ ← app.child `hv rv.bound
      app.assign `hx (← roomEq c modes paid live x el xs k).proof
      boundOf (← app.finish)
    let fits := formFits c ``push_fits [(`e, elemExpr el), (`x, x), (`v, rv.src)] [(`hv, rv)]
    if se.flat.isNone then
      return ⟨src, ← mkAppM ``push_eq #[x, rv.proof], .array el, e, bound, fits, none⟩
    return ⟨src, ← mkAppM ``push_map_eq #[← se.fn α, x, xs, v, ← arrayEq x xs, rv.proof],
      .array el, e, bound, fits, none⟩
  | ``LeanExe.insertAt, insertArgs@#[α, xs, k, v] =>
    let se ← shapeOf α
    let .elem el := se.ty | throwError "verified_compile: unsupported array {e}"
    let xs ← projReduce xs
    unless xs.isFVar do
      return ← reflectAs (← withLetDecl `a (← inferType xs) xs fun a =>
        mkLetFVars #[a] (mkAppN e.getAppFn (insertArgs.set! 1 a))) e
    let (x, t) ← varOf c xs
    unless t == .array el do throwError "verified_compile: {xs} is not an array variable"
    let ri ← reflect c k
    let rv ← reflect c v
    let src ← mkAppOptM ``Expr.insertAt
      #[some c.sigs, some c.ctx, none, some x, some ri.src, some rv.src]
    let bound : BoundBuilder := fun modes paid live => do
      let bounds := c.tables.table false
      let app ← LemmaApp.start ``insertAt_bound (boundArgs c bounds modes paid live ++
        [(`e, elemExpr el), (`x, x), (`i, ri.src), (`v, rv.src)])
      let k ← assignExtension app el
      let _ ← app.child `hi ri.bound
      let _ ← app.child `hv rv.bound
      app.assign `hx (← roomEq c modes paid live x el xs k).proof
      boundOf (← app.finish)
    let fits := formFits c ``insertAt_fits
      [(`e, elemExpr el), (`x, x), (`i, ri.src), (`v, rv.src)] [(`hi, ri), (`hv, rv)]
    if se.flat.isNone then
      return ⟨src, ← mkAppM ``insertAt_eq #[x, ri.proof, rv.proof], .array el, e, bound, fits, none⟩
    return ⟨src, ← mkAppM ``insertAt_map_eq
      #[← se.fn α, x, xs, v, ← arrayEq x xs, ri.proof, rv.proof], .array el, e, bound, fits, none⟩
  | ``LeanExe.eraseAt, eraseArgs@#[α, xs, k] =>
    let se ← shapeOf α
    let .elem el := se.ty | throwError "verified_compile: unsupported array {e}"
    let xs ← projReduce xs
    unless xs.isFVar do
      return ← reflectAs (← withLetDecl `a (← inferType xs) xs fun a =>
        mkLetFVars #[a] (mkAppN e.getAppFn (eraseArgs.set! 1 a))) e
    let (x, t) ← varOf c xs
    unless t == .array el do throwError "verified_compile: {xs} is not an array variable"
    let ri ← reflect c k
    let src ← mkAppOptM ``Expr.eraseAt #[some c.sigs, some c.ctx, none, some x, some ri.src]
    let bound : BoundBuilder := fun modes paid live => do
      let bounds := c.tables.table false
      let app ← LemmaApp.start ``eraseAt_bound (boundArgs c bounds modes paid live ++
        [(`e, elemExpr el), (`x, x), (`i, ri.src)])
      let _ ← app.child `hi ri.bound
      app.assign `hx (← varOwnedEq c modes live x (.array el) xs)
      boundOf (← app.finish)
    let fits := formFits c ``eraseAt_fits [(`e, elemExpr el), (`x, x), (`i, ri.src)] [(`hi, ri)]
    if se.flat.isNone then
      return ⟨src, ← mkAppM ``eraseAt_eq #[x, ri.proof], .array el, e, bound, fits, none⟩
    return ⟨src, ← mkAppM ``eraseAt_map_eq #[← se.fn α, x, xs, ← arrayEq x xs, ri.proof],
      .array el, e, bound, fits, none⟩
  | ``HAppend.hAppend, appendArgs@#[α, _, _, _, xs, ys] =>
    let .array el ← tyOf α | throwError "verified_compile: unsupported term {e}"
    let xs ← projReduce xs
    let ys ← projReduce ys
    unless xs.isFVar do
      return ← reflectAs (← withLetDecl `a (← inferType xs) xs fun a =>
        mkLetFVars #[a] (mkAppN e.getAppFn (appendArgs.set! 4 a))) e
    unless ys.isFVar do
      return ← reflectAs (← withLetDecl `a (← inferType ys) ys fun a =>
        mkLetFVars #[a] (mkAppN e.getAppFn (appendArgs.set! 5 a))) e
    let (x, _) ← varOf c xs
    let (y, _) ← varOf c ys
    let src ← mkAppOptM ``Expr.append #[some c.sigs, some c.ctx, none, some x, some y]
    let (``Array, #[β]) := (← whnfR α).getAppFnArgs
      | throwError "verified_compile: unsupported term {e}"
    let se ← shapeOf β
    let bound : BoundBuilder := fun modes paid live => do
      let bounds := c.tables.table false
      let app ← LemmaApp.start ``append_bound (boundArgs c bounds modes paid live ++
        [(`e, elemExpr el), (`x, x), (`y, y)])
      let (ny, hny) ← arraySizeEq el (← mkAppM ``Env.get #[c.env, y]) ys
      let width := mkApp (mkConst ``Elem.width) (elemExpr el)
      let w ← evalNat width
      let some (_, prod, _) := (← app.hypType `hk).eq?
        | throwError "verified_compile: the extension of {e}"
      let (``HMul.hMul, #[_, _, _, _, size, _]) := prod.getAppFnArgs
        | throwError "verified_compile: the extension of {e}"
      let mul := prod.appFn!.appFn!
      let hk ← congr2 mul size ny width w (some hny) (some (← evalEq width w))
      let (k, hk) ← match ← mulOne? (mkApp2 mul ny w) with
        | some (a, h) => pure (a, ← mkEqTrans hk h)
        | none => pure (mkApp2 mul ny w, hk)
      app.assign `k k
      app.assign `hk hk
      let some (_, room, _) := (← app.hypType `hx).eq?
        | throwError "verified_compile: the room of {e}"
      let roomArgs := room.getAppArgs
      app.assign `hx (← roomEq c roomArgs[0]! roomArgs[1]! roomArgs[2]! x el xs k).proof
      boundOf (← app.finish)
    if se.flat.isNone then return ⟨src, ← rflProof c src e, .array el, e, bound, leafFits c src, none⟩
    return ⟨src, ← mkAppOptM ``append_map_eq #[some c.sigs, some c.ctx, some c.funs, some c.env,
      none, none, some (← se.fn β), some x, some y, some xs, some ys, some (← arrayEq x xs),
      some (← arrayEq y ys)], .array el, e, bound, leafFits c src, none⟩
  | ``LeanExe.build, #[α, n, f] =>
    let se ← shapeOf α
    let .elem el := se.ty | throwError "verified_compile: unsupported array {e}"
    let rn ← reflect c n
    let (fs, hf, ue) ← withLocalDeclD `i (mkConst ``UInt64) fun i => do
      let env' ← mkAppOptM ``Env.cons #[some c.ctx, some (mkConst ``Ty.word), some i, some c.env]
      let c' : Ctx := { c with vars := (i, .word) :: c.vars, env := env', ctx := consCtx .word c.ctx }
      let rf ← reflect c' (f.beta #[i])
      unless rf.ty == .elem el do throwError "verified_compile: an element of {e} is not a {α}"
      return (rf.src, ← mkLambdaFVars #[i] rf.proof,
        (⟨rf, #[i], [← i.fvarId!.getDecl]⟩ : Under))
    let src ← mkAppM ``Expr.build #[rn.src, fs]
    let bound : BoundBuilder := fun modes paid live => do
      let bounds := c.tables.table false
      let app ← LemmaApp.start ``build_bound
        (boundArgs c bounds modes paid live ++ [(`count, rn.src), (`elem, fs)])
      let some (_, _, allRhs) := (← app.hypType `hall).eq?
        | throwError "verified_compile: the build {e}"
      app.assign `all allRhs
      app.assign `hall (← mkEqRefl allRhs)
      let width := mkApp (mkConst ``Elem.width) (elemExpr el)
      let w ← evalNat width
      app.assign `w w
      app.assign `hw (← evalEq width w)
      app.assign `hn (← userProof c rn)
      let _ ← app.child `hna rn.bound
      let eb ← ue.bound (← mkAppM ``List.cons #[mkConst ``Mode.borrowed, modes])
        (← mkAppM ``List.cons #[boolConst false, paid]) (← mkAppM ``shift #[mkNatLit 1, allRhs])
      -- The element's bound at the index `UInt64.ofNat k` of the sum.
      let (EA, hea) ← withLocalDeclD `k (mkConst ``Nat) fun k => do
        let b ← eb.at #[← mkAppM ``UInt64.ofNat #[k]]
        return (← mkLambdaFVars #[k] b.term, ← mkLambdaFVars #[k] b.proof)
      app.assign `EA EA
      app.assign `hea hea
      boundOf (← app.finish)
    let fits : FitsBuilder := do
      let app ← LemmaApp.start ``build_fits (fitsArgs c ++ [(`count, rn.src), (`elem, fs)])
      app.assign `hn (← userProof c rn)
      app.childFits `hnf rn.fits
      app.childFits `hef do
        let eb ← ue.fits
        withLocalDeclD `k (mkConst ``Nat) fun k => do
          let b ← eb.at #[← mkAppM ``UInt64.ofNat #[k]]
          return ⟨← mkLambdaFVars #[k] b.term, ← mkLambdaFVars #[k] b.proof⟩
      fitsOf (← app.finish)
    if se.flat.isNone then
      return ⟨src, ← mkAppM ``build_eq #[rn.proof, hf], .array el, e, bound, fits, none⟩
    return ⟨src, ← mkAppM ``build_map_eq #[← se.fn α, f, rn.proof, hf], .array el, e,
      bound, fits, none⟩
  | ``LeanExe.Bytes.build, #[n, f] =>
    let rn ← reflect c n
    let (fs, hf, ue) ← withLocalDeclD `i (mkConst ``UInt64) fun i => do
      let env' ← mkAppOptM ``Env.cons #[some c.ctx, some (mkConst ``Ty.word), some i, some c.env]
      let c' : Ctx := { c with vars := (i, .word) :: c.vars, env := env', ctx := consCtx .word c.ctx }
      let rf ← reflect c' (f.beta #[i])
      unless rf.ty == .word do throwError "verified_compile: a byte builder must return UInt64"
      return (rf.src, ← mkLambdaFVars #[i] rf.proof,
        (⟨rf, #[i], [← i.fvarId!.getDecl]⟩ : Under))
    let src ← mkAppM ``Expr.bytesBuild #[rn.src, fs]
    let bound : BoundBuilder := fun modes paid live => do
      let bounds := c.tables.table false
      let app ← LemmaApp.start ``bytesBuild_bound
        (boundArgs c bounds modes paid live ++ [(`count, rn.src), (`elem, fs)])
      let some (_, _, allRhs) := (← app.hypType `hall).eq?
        | throwError "verified_compile: the byte build {e}"
      app.assign `all allRhs
      app.assign `hall (← mkEqRefl allRhs)
      app.assign `hn (← userProof c rn)
      let _ ← app.child `hna rn.bound
      let eb ← ue.bound (← mkAppM ``List.cons #[mkConst ``Mode.borrowed, modes])
        (← mkAppM ``List.cons #[boolConst false, paid]) (← mkAppM ``shift #[mkNatLit 1, allRhs])
      let (EA, hea) ← withLocalDeclD `k (mkConst ``Nat) fun k => do
        let b ← eb.at #[← mkAppM ``UInt64.ofNat #[k]]
        return (← mkLambdaFVars #[k] b.term, ← mkLambdaFVars #[k] b.proof)
      app.assign `EA EA
      app.assign `hea hea
      boundOf (← app.finish)
    let fits : FitsBuilder := do
      let app ← LemmaApp.start ``bytesBuild_fits (fitsArgs c ++ [(`count, rn.src), (`elem, fs)])
      app.assign `hn (← userProof c rn)
      app.childFits `hnf rn.fits
      app.childFits `hef do
        let eb ← ue.fits
        withLocalDeclD `k (mkConst ``Nat) fun k => do
          let b ← eb.at #[← mkAppM ``UInt64.ofNat #[k]]
          return ⟨← mkLambdaFVars #[k] b.term, ← mkLambdaFVars #[k] b.proof⟩
      fitsOf (← app.finish)
    return ⟨src, ← mkAppM ``bytesBuild_eq #[rn.proof, hf], .bytes, e, bound, fits, none⟩
  | ``LeanExe.Bytes.size, #[bytes] =>
    let bytes ← projReduce bytes
    unless bytes.isFVar do
      return ← reflectAs (← withLetDecl `bytes (← inferType bytes) bytes fun value =>
        mkLetFVars #[value] (mkApp e.getAppFn value)) e
    let (x, .bytes) ← varOf c bytes
      | throwError "verified_compile: {bytes} is not a byte variable"
    let src ← mkAppOptM ``Expr.bytesSize #[some c.sigs, some c.ctx, some x]
    return ⟨src, ← rflProof c src e, .word, e,
      leafBound c ``bytesSize_bound [(`x, x)], leafFits c src, none⟩
  | ``LeanExe.Bytes.get, #[bytes, index] =>
    let bytes ← projReduce bytes
    unless bytes.isFVar do
      return ← reflectAs (← withLetDecl `bytes (← inferType bytes) bytes fun value =>
        mkLetFVars #[value] (mkApp2 e.getAppFn value index)) e
    let (x, .bytes) ← varOf c bytes
      | throwError "verified_compile: {bytes} is not a byte variable"
    let ri ← reflect c index
    let src ← mkAppOptM ``Expr.bytesGet #[some c.sigs, some c.ctx, some x, some ri.src]
    let bound : BoundBuilder := fun modes paid live => do
      let bounds := c.tables.table false
      let app ← LemmaApp.start ``bytesGet_bound
        (boundArgs c bounds modes paid live ++ [(`x, x), (`i, ri.src)])
      let _ ← app.child `hi ri.bound
      boundOf (← app.finish)
    let fits := formFits c ``bytesGet_fits [(`x, x), (`i, ri.src)] [(`hi, ri)]
    return ⟨src, ← mkAppM ``bytesGet_eq #[x, ri.proof], .word, e, bound, fits, none⟩
  | ``Nat.toUInt64, #[n] =>
    let (``Array.size, sizeArgs@#[_, xs]) := n.consumeMData.getAppFnArgs
      | throwError "verified_compile: unsupported term {e}"
    let xs ← projReduce xs
    unless xs.isFVar do
      return ← reflectAs (← withLetDecl `a (← inferType xs) xs fun a =>
        mkLetFVars #[a] (mkAppN e.getAppFn #[mkAppN n.consumeMData.getAppFn (sizeArgs.set! 1 a)])) e
    let (x, t) ← varOf c xs
    let .array _ := t | throwError "verified_compile: {xs} is not an array variable"
    let src ← mkAppOptM ``Expr.size #[some c.sigs, some c.ctx, none, some x]
    let (``Array, #[β]) := (← whnfR (← inferType xs)).getAppFnArgs
      | throwError "verified_compile: {xs} is not an array"
    let se ← shapeOf β
    let bound := leafBound c ``size_bound [(`x, x)]
    if se.flat.isNone then return ⟨src, ← rflProof c src e, .word, e, bound, leafFits c src, none⟩
    return ⟨src, ← mkAppOptM ``size_map_eq #[some c.sigs, some c.ctx, some c.funs, some c.env,
      none, none, some (← se.fn β), some x, some xs, some (← arrayEq x xs)], .word, e, bound,
      leafFits c src, none⟩
  | ``getElem!, getArgs@#[_, _, β, _, _, inh, xs, k] =>
    let (``UInt64.toNat, #[i]) := k.consumeMData.getAppFnArgs
      | throwError "verified_compile: an index must be `i.toNat` for a word `i`, in {e}"
    let xs ← projReduce xs
    unless xs.isFVar do
      return ← reflectAs (← withLetDecl `a (← inferType xs) xs fun a =>
        mkLetFVars #[a] (mkAppN e.getAppFn (getArgs.set! 6 a))) e
    let (x, t) ← varOf c xs
    let .array el := t | throwError "verified_compile: {xs} is not an array variable"
    let ri ← reflect c i
    let src ← mkAppOptM ``Expr.get #[some c.sigs, some c.ctx, none, some x, some ri.src]
    let bound : BoundBuilder := fun modes paid live => do
      let bounds := c.tables.table false
      let app ← LemmaApp.start ``get_bound
        (boundArgs c bounds modes paid live ++ [(`x, x), (`i, ri.src)])
      let _ ← app.child `hi ri.bound
      boundOf (← app.finish)
    let se ← shapeOf β
    let fits := formFits c ``get_fits [(`x, x), (`i, ri.src)] [(`hi, ri)]
    if se.flat.isNone then
      return ⟨src, ← mkAppM ``get_eq #[x, ri.proof], .elem el, e, bound, fits, none⟩
    -- A read past the end gives the flattening of Lean's default element, which must be the
    -- element type's default.
    let lhs := se.apply (mkApp2 (mkConst ``Inhabited.default [Level.one]) β inh)
    let rhs := mkApp2 (mkConst ``Inhabited.default [Level.one])
      (mkApp (mkConst ``Elem.denote) (elemExpr el))
      (mkApp (mkConst ``Elem.instInhabited) (elemExpr el))
    unless ← kernelDefEq lhs rhs do
      throwError "verified_compile: the flattening of the default {β} is not the default element; \
        the default must take each field's default, and an enumeration's default must have the \
        word 0"
    let hd ← mkExpectedTypeHint (← mkEqRefl lhs) (← mkEq lhs rhs)
    let proof ← mkAppOptM ``get_map_eq #[none, none, none, none, none, some β, some inh,
      some (← se.fn β), some hd, some x, some xs, none, none, some (← arrayEq x xs),
      some ri.proof]
    return ⟨src, proof, .elem el, e, bound, fits, none⟩
  | _, _ =>
    if let .const fn _ := e.getAppFn then
      if Lean.Compiler.hasInlineAttribute (← getEnv) fn then
        if let some unfolded ← unfoldDefinition? e then
          return ← reflectAs unfolded.headBeta e
    throwError "verified_compile: unsupported term {e}"
where
  /-- The proof by `rfl` that the source value of the array variable `xs` is its flattening. -/
  arrayEq (x xs : Lean.Expr) : MetaM Lean.Expr := do
    let v ← flatValue xs
    mkExpectedTypeHint (← mkEqRefl v) (← mkEq (← mkAppM ``Env.get #[c.env, x]) v)
  /-- The builder of a loop over the count `rn` from the initial state `ri`, with the condition
`cond` and the body `u` under its index and state, for the Lean state type `α`, initial state
`init`, condition `C`, and step `F`.  `hc` proves the condition's meaning hypothesis, and
`condBound` gives its cost as a function of the state with the proof of its bound hypothesis. -/
  loopBound (rn ri : Reflection) (u : Under) (cond α init C : Lean.Expr)
      (hc : Lean.Expr → MetaM Lean.Expr) (F : Lean.Expr)
      (condBound : Lean.Expr → Lean.Expr → MetaM (Lean.Expr × Lean.Expr)) :
      BoundBuilder := fun modes paid live => do
    let bounds := c.tables.table false
    let sa ← shapeOf α
    let flatArgs ← match sa.flat with
      | none => pure []
      | some φ => pure [(`φ, φ), (`I, init)]
    -- Every argument but the passes and their credits.
    let fill (thm : Name) : MetaM LemmaApp := do
      let app ← LemmaApp.start thm (boundArgs c bounds modes paid live ++
        [(`count, rn.src), (`init, ri.src), (`cond, cond), (`body, u.r.src), (`C, C), (`F, F)] ++
        flatArgs)
      let some (_, _, allRhs) := (← app.hypType `hall).eq?
        | throwError "verified_compile: the loop's live variables"
      app.assign `all allRhs
      app.assign `hall (← mkEqRefl allRhs)
      let _ ← assignMode app `M `hM
      if app.names.contains `ps then
        let some (_, statePaid, _) := (← app.hypType `hps).eq?
          | throwError "verified_compile: the loop's state flag"
        let ps := boolConst (← evalBool m!"whether the state of a loop is paid" statePaid)
        app.assign `ps ps
        app.assign `hps (← evalEq statePaid ps)
      else
        assignFlag app `hps
      assignFlag app `hpair
      app.assign `hn (← userProof c rn)
      app.assign `hi (← userProof c ri)
      app.assign `hc (← hc (← app.hypType `hc))
      app.assign `hb (← mkExpectedTypeHint u.r.proof (← app.hypType `hb))
      let _ ← app.child `hna rn.bound
      let _ ← app.child `hia ri.bound
      let _ ← assignCoerce c.base app `hka ri.ty init
      -- The credit of a paid state whose initial value is not paid.
      let some (_, credit, _) := (← app.hypType `hcr).eq?
        | throwError "verified_compile: the loop's credit"
      let (``ite, #[_, charged, _, creditTerm, _]) := credit.getAppFnArgs
        | throwError "verified_compile: the loop's credit {credit}"
      let (``Eq, #[_, chargedFlag, _]) := charged.getAppFnArgs
        | throwError "verified_compile: the loop's credit {credit}"
      if ← evalBool m!"whether a loop is charged a credit" chargedFlag then
        let (``Ty.credit, #[_, v]) := creditTerm.getAppFnArgs
          | throwError "verified_compile: the loop's credit {creditTerm}"
        let (CR, hx) ← ValueCost.credit.eq c.base ri.ty v init
        app.assign `CR CR
        app.assign `hcr (← mkAppM ``credit_some #[← evalEq chargedFlag (boolConst true), hx])
      else
        app.assign `CR natZero
        app.assign `hcr (← mkAppOptM ``credit_none
          #[some chargedFlag, some creditTerm, some (← evalEq chargedFlag (boolConst false))])
      let (CA, hca) ← condBound (← app.hypType `hca) bounds
      app.assign `CA CA
      app.assign `hca hca
      return app
    -- The bound of a pass, `allocs + coerce`, under the binders, from the body's bound and the
    -- coercion of its value.
    let pass (sum : Lean.Expr) : MetaM Bound := do
      let (``HAdd.hAdd, #[_, _, _, _, allocs, coerce]) := sum.getAppFnArgs
        | throwError "verified_compile: the loop's body"
      let args := allocs.getAppArgs
      let b ← u.r.bound args[4]! args[5]! args[6]!
      let (``coerceCost, #[_, s, M', v]) := coerce.getAppFnArgs
        | throwError "verified_compile: the loop's body"
      let value ← projReduce (F.beta u.xs)
      let (K, hk) ← coerceEq c.base ri.ty s M' v value
      boundOf (← congr2 sum.appFn!.appFn! allocs b.term coerce K (some b.proof) (some hk))
    -- The bound of a pass with its credits, `allocs + coerce + credits`.
    let passBuys (lhs : Lean.Expr) : MetaM Bound := do
      let (``HAdd.hAdd, #[_, _, _, _, sum, credits]) := lhs.getAppFnArgs
        | throwError "verified_compile: the loop's body"
      let b ← pass sum
      if let some zero ← zeroCredits credits then
        return ⟨b.term, ← mkAppM ``add_zero_eq #[b.proof, zero]⟩
      let (``ite, #[_, _, _, buys, _]) := credits.getAppFnArgs
        | throwError "verified_compile: the loop's credits {credits}"
      let (``Expr.buys, args) := buys.getAppFnArgs
        | throwError "verified_compile: the loop's credits {buys}"
      let some bb := u.r.buys
        | throwError "verified_compile: the credits of a loop's body are not available"
      let y ← bb args[3]! args[4]! args[5]!
      let hy ← mkAppM ``buys_on #[y.proof]
      boundOf (← congr2 lhs.appFn!.appFn! sum b.term credits y.term (some b.proof) (some hy))
    -- The function of the index and the state that a pass hypothesis `name` states, built by `f`.
    let passes (app : LemmaApp) (cost proof : Name) (f : Lean.Expr → MetaM Bound) : MetaM Unit := do
      let ty ← app.hypType proof
      let (term, prf) ← withExistingLocalDecls u.decls do
        let ty ← u.instantiate ty
        let some (_, lhs, _) := ty.eq? | throwError "verified_compile: the loop's body"
        let b ← f lhs
        return (← mkLambdaFVars u.xs b.term, ← mkLambdaFVars u.xs b.proof)
      app.assign cost term
      app.assign proof prf
    let statePaid ← mkAppM ``Expr.statePaid #[c.tables.flags, modes, paid, live, ri.src, cond,
      u.r.src]
    let paidState ← evalBool m!"whether the state of a loop is paid" statePaid
    let pairState ← evalBool m!"whether the state of a loop is a pair"
      (mkApp (mkConst ``Ty.isPair) (tyExpr ri.ty))
    if paidState && pairState then
      -- The smaller of the bounds with an unpaid and a paid state.
      let app ← fill (if sa.flat.isNone then ``loop_min_bound else ``loop_min_flat_bound)
      passes app `BA0 `hba0 pass
      passes app `BA1 `hba1 passBuys
      return ← boundOf (← app.finish)
    let app ← fill (if sa.flat.isNone then ``loop_bound else ``loop_flat_bound)
    match ← zeroBuysAll (← app.hypType `hby) with
    | some hby =>
      app.assign `hby hby
      passes app `BA `hba pass
      boundOf (← app.finish)
    | none =>
      -- The state is paid, and the body's code charges credits at the `if`s in its result.
      let app ← fill (if sa.flat.isNone then ``loop_buy_bound else ``loop_buy_flat_bound)
      passes app `BA `hba passBuys
      boundOf (← app.finish)
  foldBound (ri : Reflection) (u : Under) (α β xs init F x hx : Lean.Expr) :
      BoundBuilder := fun modes paid live => do
    let sa ← shapeOf α
    let sb ← shapeOf β
    let start (thm : Name) : MetaM LemmaApp := do
      LemmaApp.start thm (boundArgs c (c.tables.table false) modes paid live ++
        [(`φ, ← sb.fn β), (`ψ, ← sa.fn α), (`xs, xs), (`I, init), (`F, F), (`x, x),
          (`init, ri.src), (`body, u.r.src), (`hx, hx)])
    let probe ← start ``fold_flat_bound
    let some (_, statePaid, _) := (← probe.hypType `hps).eq?
      | throwError "verified_compile: the fold's state flag"
    let minimum := (← evalBool m!"whether the state of a fold is paid" statePaid) &&
      (← evalBool m!"whether the state of a fold is a pair"
        (mkApp (mkConst ``Ty.isPair) (tyExpr ri.ty)))
    let app ← if minimum then start ``fold_min_flat_bound else pure probe
    let some (_, _, allRhs) := (← app.hypType `hall).eq?
      | throwError "verified_compile: the fold's live variables"
    app.assign `all allRhs
    app.assign `hall (← mkEqRefl allRhs)
    let _ ← assignMode app `M `hM
    if app.names.contains `ps then
      let some (_, statePaid, _) := (← app.hypType `hps).eq?
        | throwError "verified_compile: the fold's state flag"
      let ps := boolConst (← evalBool m!"whether the state of a fold is paid" statePaid)
      app.assign `ps ps
      app.assign `hps (← evalEq statePaid ps)
    else
      assignFlag app `hps
    assignFlag app `hpair
    app.assign `hi (← mkExpectedTypeHint ri.proof (← app.hypType `hi))
    app.assign `hb (← mkExpectedTypeHint u.r.proof (← app.hypType `hb))
    let _ ← app.child `hia ri.bound
    let _ ← assignCoerce c.base app `hka ri.ty init
    let some (_, credit, _) := (← app.hypType `hcr).eq?
      | throwError "verified_compile: the fold's credit"
    let (``ite, #[_, charged, _, creditTerm, _]) := credit.getAppFnArgs
      | throwError "verified_compile: the fold's credit {credit}"
    let (``Eq, #[_, chargedFlag, _]) := charged.getAppFnArgs
      | throwError "verified_compile: the fold's credit {credit}"
    if ← evalBool m!"whether a fold is charged a credit" chargedFlag then
      let (``Ty.credit, #[_, v]) := creditTerm.getAppFnArgs
        | throwError "verified_compile: the fold's credit {creditTerm}"
      let (CR, hcr) ← ValueCost.credit.eq c.base ri.ty v init
      app.assign `CR CR
      app.assign `hcr (← mkAppM ``credit_some #[← evalEq chargedFlag (boolConst true), hcr])
    else
      app.assign `CR natZero
      app.assign `hcr (← mkAppOptM ``credit_none
        #[some chargedFlag, some creditTerm, some (← evalEq chargedFlag (boolConst false))])
    match ← zeroBuysAll (← app.hypType `hby) with
    | some hby => app.assign `hby hby
    | none => throwError "verified_compile: a fold whose body charges credits at the `if`s in its \
        result is not supported"
    let pass (cost proof : Name) : MetaM Unit := do
      let hbaTy ← app.hypType proof
      let (term, prf) ← withExistingLocalDecls u.decls do
        let ty ← u.instantiate hbaTy
        let some (_, lhs, _) := ty.eq? | throwError "verified_compile: the fold's body"
        let (``HAdd.hAdd, #[_, _, _, _, allocs, coerce]) := lhs.getAppFnArgs
          | throwError "verified_compile: the fold's body"
        let args := allocs.getAppArgs
        let b ← u.r.bound args[4]! args[5]! args[6]!
        let (``coerceCost, #[_, s, M, v]) := coerce.getAppFnArgs
          | throwError "verified_compile: the fold's body"
        let value ← projReduce (F.beta #[u.xs[1]!, u.xs[2]!])
        let (K, hk) ← coerceEq c.base ri.ty s M v value
        let b ← boundOf
          (← congr2 lhs.appFn!.appFn! allocs b.term coerce K (some b.proof) (some hk))
        return (← mkLambdaFVars u.xs b.term, ← mkLambdaFVars u.xs b.proof)
      app.assign cost term
      app.assign proof prf
    if minimum then
      pass `BA0 `hba0
      pass `BA1 `hba1
    else
      pass `BA `hba
    boundOf (← app.finish)
  foldFits (ri : Reflection) (u : Under) (α β xs init F x hx : Lean.Expr) : FitsBuilder := do
    let sa ← shapeOf α
    let sb ← shapeOf β
    let app ← LemmaApp.start ``fold_flat_fits
      (fitsArgs c ++ [(`φ, ← sb.fn β), (`ψ, ← sa.fn α), (`xs, xs), (`I, init), (`F, F),
        (`x, x), (`init, ri.src), (`body, u.r.src), (`hx, hx)])
    app.assign `hi (← mkExpectedTypeHint ri.proof (← app.hypType `hi))
    app.assign `hb (← mkExpectedTypeHint u.r.proof (← app.hypType `hb))
    app.childFits `hif ri.fits
    let bf ← u.fits
    app.assign `BF bf.term
    app.assign `hbf (← mkExpectedTypeHint bf.proof (← app.hypType `hbf))
    fitsOf (← app.finish)
  /-- The frames builder of a loop, with the parts that `loopBound` takes and the builder
  `condFits` of the condition's frames under its state, or `none` for the condition `true`. -/
  loopFits (rn ri : Reflection) (u : Under) (cond α init C : Lean.Expr)
      (hc : Lean.Expr → MetaM Lean.Expr) (F : Lean.Expr) (condFits : Option FitsBuilder) :
      FitsBuilder := do
    let sa ← shapeOf α
    let flatArgs ← match sa.flat with
      | none => pure []
      | some φ => pure [(`φ, φ), (`I, init)]
    let app ← LemmaApp.start (if sa.flat.isNone then ``loop_fits else ``loop_flat_fits)
      (fitsArgs c ++ [(`count, rn.src), (`init, ri.src), (`cond, cond), (`body, u.r.src),
        (`C, C), (`F, F)] ++ flatArgs)
    app.assign `hn (← userProof c rn)
    app.assign `hi (← userProof c ri)
    app.assign `hc (← hc (← app.hypType `hc))
    app.assign `hb (← mkExpectedTypeHint u.r.proof (← app.hypType `hb))
    app.childFits `hnf rn.fits
    app.childFits `hif ri.fits
    match condFits with
    | some b => app.childFits `hcf b
    | none => app.noDepth `hcf
    app.childFits `hbf u.fits
    fitsOf (← app.finish)
  /-- The builder of a pair, with the coercions of its components to the pair's mode. -/
  pairBound (ra rb : Reflection) : BoundBuilder := fun modes paid live => do
    let bounds := c.tables.table false
    let app ← LemmaApp.start ``pair_bound
      (boundArgs c bounds modes paid live ++ [(`a, ra.src), (`b, rb.src)])
    let _ ← assignMode app `M `hM
    app.assign `ha (← userProof c ra)
    app.assign `hb (← userProof c rb)
    let _ ← app.child `haa ra.bound
    let _ ← assignCoerce c.base app `hka ra.ty ra.lean
    let _ ← app.child `hba rb.bound
    let _ ← assignCoerce c.base app `hkb rb.ty rb.lean
    boundOf (← app.finish)
  reflectRecursiveConstructor? (e : Lean.Expr) : MetaM (Option Reflection) := do
    let .const ctor _ := e.getAppFn | return none
    let some (.ctorInfo info) := (← getEnv).find? ctor | return none
    let some layout ← recursiveLayout? (mkConst info.induct) | return none
    let shape := treeShapeExpr layout.shape
    let ty := Ty.tree layout.shape
    let some r := layout.record? ctor | do
      let h ← hasNullProof layout.shape
      let src ← mkAppOptM ``Expr.treeNil #[some c.sigs, some c.ctx, some shape, some h]
      return some ⟨src, ← rflProof c src (← flatValue e), ty, e,
        leafBound c ``treeNil_bound [(`shape, shape), (`h, h)], leafFits c src, none⟩
    let record := recordExpr layout.shape r
    let natives := (layout.recordCtor r).2
    let args := e.getAppArgs.toList
    unless args.length == natives.length do
      throwError "verified_compile: incomplete recursive constructor {e}"
    -- The record reads each leaf of a flat field from the field's tuple: the `Flat` tuple of a
    -- variable, or the tuple of a structure's constructor.  Any other field is bound first.
    let tuples ← (args.zip natives).mapM fun (a, kind) => do
      let .flat _ _ := kind | return some a
      let a ← projReduce a
      if a.isFVar then return some (← flatTerm a)
      ctorTuple? a
    if tuples.any (·.isNone) then
      return some (← reflectAs (← bindArgs e.getAppFn args (tuples.map (·.isNone)) #[] #[]) e)
    let mut typedWords : List (Elem × Reflection) := []
    let mut children : List Reflection := []
    let mut typedArrays : List (Elem × Reflection) := []
    let mut buffers : List Reflection := []
    for ((a, kind), tuple) in (args.zip natives).zip (tuples.filterMap id) do
      match kind with
      | .child => children := children ++ [← reflect c a]
      | .array el => typedArrays := typedArrays ++ [(el, ← reflect c a)]
      | .bytes => buffers := buffers ++ [← reflect c a]
      | .leaf el => typedWords := typedWords ++ [(el, ← reflect c a)]
      | .flat _ leaves =>
        -- The first segment of a leaf of a field is empty, and the tuple is the field's flattening.
        for (el, segments) in leaves do
          typedWords := typedWords ++ [(el, ← reflect c (← tupleLeaf tuple segments.tail))]
    let elems := typedWords.map (·.1)
    let words := typedWords.map (·.2)
    let sourceType (t : Ty) := mkApp3 (mkConst ``Expr) c.sigs c.ctx (tyExpr t)
    let wordFn ← exprFamily c layout.shape r (elems.zip (words.map (·.src)))
    let childFn ← mkExpectedTypeHint (← finiteFn (sourceType ty) (children.map (·.src)))
      (← mkArrow (mkApp (mkConst ``Fin) (← mkAppM ``TreeShape.children #[shape, record]))
        (sourceType ty))
    let arrays := typedArrays.map (·.2)
    let arrayFn ← arrayExprFamily c layout.shape r (typedArrays.map fun (e, ra) => (e, ra.src))
    let bufferFn ← bufferExprFamily c layout.shape r (buffers.map (·.src))
    let header := mkApp2 (mkConst ``Var) c.ctx (tyExpr (.treeHeader layout.shape r))
    let reuse ← match c.vars.find? (fun (_, t) => t == .treeHeader layout.shape r) with
      | none => mkAppOptM ``Option.none #[some header]
      | some (value, _) => do
        let (x, _) ← varOf c value
        mkAppOptM ``Option.some #[some header, some x]
    let src ← mkAppM ``Expr.treeNode #[record, reuse, wordFn, arrayFn, bufferFn, childFn]
    let parts := [(`shape, shape), (`r, record), (`reuse, reuse), (`words, wordFn),
      (`arrays, arrayFn), (`buffers, bufferFn), (`children, childFn)]
    let app ← LemmaApp.start ``treeNode_eq
      ([(`S, c.sigs), (`Γ, c.ctx), (`funs, c.funs), (`env, c.env)] ++ parts)
    let values (rs : List Reflection) : MetaM (List Bound) :=
      rs.mapM fun r => return ⟨← flatValue r.lean, ← userProof c r⟩
    let wordValues ← values words
    if layout.shape.allWords then
      let _ ← assignFiniteEquation app `wordValues `hw (mkConst ``UInt64) wordValues
    else
      let _ ← assignFamilyEquation app `wordValues `hw
        (← wordFamily layout.shape r (elems.zip (wordValues.map (·.term)))) wordValues
    let _ ← assignFiniteEquation app `childValues `hc (mkApp (mkConst ``Tree) shape)
      (← values children)
    let arrayValues ← values arrays
    let _ ← assignFamilyEquation app `arrayValues `ha
      (← arrayFamily layout.shape r ((typedArrays.map (·.1)).zip (arrayValues.map (·.term))))
      arrayValues
    let bufferValues ← values buffers
    let _ ← assignFamilyEquation app `bufferValues `hb
      (← bufferFamily layout.shape r (bufferValues.map (·.term))) bufferValues
    let proof ← app.finish
    let (_, value) ← eqSides proof
    let proof ← transHint proof (← bareEq value (← flatValue e))
    let addBounds (a b : Bound) : MetaM Bound := do
      let (left, _) ← eqSides a.proof
      let (right, _) ← eqSides b.proof
      boundOf (← congr2 natAdd left a.term right b.term (some a.proof) (some b.proof))
    let bound : BoundBuilder := fun modes paid live => do
      let app ← LemmaApp.start ``treeNode_bound
        (boundArgs c (c.tables.table false) modes paid live ++ parts)
      let wb ← finiteFieldBounds app `hw words
      let cb ← finiteFieldBounds app `hc children
      let kb ← children.zipIdx.mapM fun (field, i) => do
        let expected ← instantiateForall (← app.hypType `hk) #[← finiteIndex children.length i]
        let some (_, lhs, _) := expected.eq?
          | throwError "verified_compile: recursive child coercion is not an equation"
        let (``coerceCost, #[_, s, M, value]) := lhs.getAppFnArgs
          | throwError "verified_compile: recursive child coercion has an invalid form"
        let (cost, proof) ← coerceEq c.base ty s M value field.lean
        return (⟨cost, proof⟩ : Bound)
      let ab ← finiteFieldBounds app `ha arrays
      let akb ← typedArrays.zipIdx.mapM fun ((el, field), i) => do
        let expected ← instantiateForall (← app.hypType `hak)
          #[← finiteIndex typedArrays.length i]
        let some (_, lhs, _) := expected.eq?
          | throwError "verified_compile: recursive array coercion is not an equation"
        let (``coerceCost, #[_, s, M, value]) := lhs.getAppFnArgs
          | throwError "verified_compile: recursive array coercion has an invalid form"
        let value ← mkExpectedTypeHint value (mkApp (mkConst ``Ty.denote) (tyExpr (.array el)))
        let (cost, proof) ← coerceEq c.base (.array el) s M value field.lean
        return (⟨cost, proof⟩ : Bound)
      let _ ← assignFiniteEquation app `W `hw (mkConst ``Nat) wb
      let _ ← assignFiniteEquation app `C `hc (mkConst ``Nat) cb
      let _ ← assignFiniteEquation app `K `hk (mkConst ``Nat) kb
      let _ ← assignFiniteEquation app `A `ha (mkConst ``Nat) ab
      let _ ← assignFiniteEquation app `AK `hak (mkConst ``Nat) akb
      let bb ← finiteFieldBounds app `hb buffers
      let bkb ← buffers.zipIdx.mapM fun (field, i) => do
        let expected ← instantiateForall (← app.hypType `hbk) #[← finiteIndex buffers.length i]
        let some (_, lhs, _) := expected.eq?
          | throwError "verified_compile: recursive buffer coercion is not an equation"
        let (``coerceCost, #[_, s, M, value]) := lhs.getAppFnArgs
          | throwError "verified_compile: recursive buffer coercion has an invalid form"
        let value ← mkExpectedTypeHint value (mkApp (mkConst ``Ty.denote) (tyExpr .bytes))
        let (cost, proof) ← coerceEq c.base .bytes s M value field.lean
        return (⟨cost, proof⟩ : Bound)
      let _ ← assignFiniteEquation app `B `hb (mkConst ``Nat) bb
      let _ ← assignFiniteEquation app `BK `hbk (mkConst ``Nat) bkb
      let some (_, parent, _) := (← app.hypType `hp).eq?
        | throwError "verified_compile: recursive parent cost is not an equation"
      let p ← evalNat parent
      app.assign `hp (← evalEq parent p)
      let fieldsBound ← addBounds (← addBounds (← addBounds (← finiteSumBound wb)
        (← addBounds (← finiteSumBound cb) (← finiteSumBound kb)))
        (← addBounds (← finiteSumBound ab) (← finiteSumBound akb)))
        (← addBounds (← finiteSumBound bb) (← finiteSumBound bkb))
      let total ← addBounds fieldsBound ⟨p, ← mkEqRefl p⟩
      boundOf (← transHint (← app.finish) total.proof)
    let fits : FitsBuilder := do
      let app ← LemmaApp.start ``treeNode_fits (fitsArgs c ++ parts)
      let wb ← words.mapM (·.fits)
      let cb ← children.mapM (·.fits)
      let ab ← arrays.mapM (·.fits)
      let bf ← buffers.mapM (·.fits)
      let _ ← assignFiniteEquation app `W `hw (mkConst ``Bool) wb
      let _ ← assignFiniteEquation app `C `hc (mkConst ``Bool) cb
      let _ ← assignFiniteEquation app `A `ha (mkConst ``Bool) ab
      let _ ← assignFiniteEquation app `B `hb (mkConst ``Bool) bf
      let andBound (a b : Bound) : MetaM Bound := do
        let (left, _) ← eqSides a.proof
        let (right, _) ← eqSides b.proof
        fitsOf (← congr2 (mkConst ``Bool.and) left a.term right b.term
          (some a.proof) (some b.proof))
      let words ← finiteAllFits wb
      let all ← andBound (← andBound (← andBound words (← finiteAllFits cb))
        (← finiteAllFits ab)) (← finiteAllFits bf)
      fitsOf (← transHint (← app.finish) all.proof)
    return some ⟨src, proof, ty, e, bound, fits, none⟩
  reflectSumConstructor? (e : Lean.Expr) : MetaM (Option Reflection) := do
    let .const ctorName _ := e.getAppFn | return none
    let some (.ctorInfo ctor) := (← getEnv).find? ctorName | return none
    let type ← inferType e
    let some name ← sumName? type | return none
    unless e.getAppNumArgs == ctor.numFields do return none
    let layout ← sumLayout type name
    let flat := mkApp4 (mkConst ``LeanExe.Pipeline.Flat.flat) type layout.flatType layout.inst e
    let r ← reflect c (← reduceTuple flat layout.flatType)
    return some (r.as (← mkExpectedTypeHint r.proof
      (← mkEq (← denoteExpr c r.src) (← flatValue e))) e)
  /-- A structure built with its constructor: the tuple that its `Flat` instance makes of the
  fields, reflected as a tuple, whose meaning is the structure's flattening. -/
  reflectStruct? (e : Lean.Expr) : MetaM (Option Reflection) := do
    let some tuple ← ctorTuple? e | return none
    let r ← reflect c tuple
    return some (r.as (← mkExpectedTypeHint r.proof
      (← mkEq (← denoteExpr c r.src) (← flatValue e))) e)
  /-- `e`, reflected as the term `T` with `eq : T = e`. -/
  reflectVia (T eq : Lean.Expr) : MetaM Reflection := do
    let r ← reflect c T
    let some (_, _, e) := (← inferType eq).eq? | throwError "verified_compile: the equation {eq}"
    return r.as (← restate r.proof eq) e
  /-- The `LawfulBEq` instance of an enumeration, which `==` on it needs. -/
  enumLawful (α beq : Lean.Expr) : MetaM Lean.Expr := do
    let some inst ← synthInstance? (mkApp2 (mkConst ``LawfulBEq [Level.zero]) α beq)
      | throwError "verified_compile: `==` on {α} needs `LawfulBEq {α}`; derive `DecidableEq`, or \
          `BEq` and `LawfulBEq`"
    return inst
  /-- `==` or `!=` (the function `op`) on enumerations, as the same comparison of their words,
  by the lemma `thm`. -/
  enumBEq? (op thm : Name) (α inst a b : Lean.Expr) : MetaM (Option Reflection) := do
    let some (n, flatInst) ← enumFlat? α | return none
    let h ← flatInjective c.base n flatInst
    let lawful ← enumLawful α inst
    let flat := enumFlat n flatInst
    let eq ← mkAppOptM thm #[some α, some flatInst, some inst, some lawful, some h, some a, some b]
    return some (← reflectVia (← mkAppM op #[mkApp flat a, mkApp flat b]) (← mkEqSymm eq))
  /-- `decide (a = b)` on enumerations, as the same decision on their words. -/
  enumDecide? (p inst : Lean.Expr) : MetaM (Option Reflection) := do
    let (``Eq, #[_, a, b]) := p.consumeMData.getAppFnArgs | return none
    let some (n, flatInst) ← enumFlat? (← inferType a) | return none
    let h ← flatInjective c.base n flatInst
    let flat := enumFlat n flatInst
    let eq ← mkAppOptM ``flat_decide #[none, some flatInst, some h, some a, some b, some inst]
    let words ← mkEq (mkApp flat a) (mkApp flat b)
    return some (← reflectVia (← mkDecide words) (← mkEqSymm eq))
  /-- `e`, reflected as `T`, which equals it by `bareEq`. -/
  reflectAs (T e : Lean.Expr) : MetaM Reflection := do
    let r ← reflect c T
    return r.as (← restate r.proof (← bareEq T e)) e
  /-- `if a = b` and `if a ≠ b` on enumerations, as the same test on their words. -/
  enumIte? (α p inst x y : Lean.Expr) : MetaM (Option Reflection) := do
    let (thm, rel, a, b) ← match p.consumeMData.getAppFnArgs with
      | (``Eq, #[_, a, b]) => pure (``flat_ite, ``Eq, a, b)
      | (``Ne, #[_, a, b]) => pure (``flat_ite_ne, ``Ne, a, b)
      | _ => return none
    let some (n, flatInst) ← enumFlat? (← inferType a) | return none
    let h ← flatInjective c.base n flatInst
    let flat := enumFlat n flatInst
    let eq ← mkAppOptM thm #[none, some α, some flatInst, some h, some a, some b, some inst,
      some x, some y]
    let test ← mkAppM rel #[mkApp flat a, mkApp flat b]
    return some (← reflectVia (← mkAppM ``ite #[test, x, y]) (← mkEqSymm eq))
  reflectTreeMatch (app : MatcherApp) (layout : Option RecursiveLayout) : MetaM Reflection := do
    let xs := app.discrs[0]!
    unless (← projReduce xs).isFVar do
      return ← reflectAs (← withLetDecl `xs (← inferType xs) xs fun value =>
        mkLetFVars #[value] { app with discrs := #[value] }.toExpr) app.toExpr
    unless app.remaining.isEmpty do
      throwError "verified_compile: a list match cannot be applied to further arguments"
    match layout with
    | none => reflectListMatch app xs
    | some layout => reflectRecursiveMatch app xs layout
  reflectListMatch (app : MatcherApp) (xs : Lean.Expr) : MetaM Reflection := do
    let (empty, branch, nativeEq) ← listMatcherCases app
    let (x, _) ← varOf c xs
    let hx ← bareEq (← mkAppM ``Env.get #[c.env, x]) (← flatValue xs)
    let re ← reflect c empty
    let ub ← withListCaseFields c xs fun inner head tail => do
      let rn ← reflect inner (branch.beta #[head, tail])
      unless rn.ty == re.ty do
        throwError "verified_compile: list branches have different source types"
      pure (⟨{ rn with proof := ← userProof inner rn }, #[head, tail],
        ← [head, tail].mapM fun field => field.fvarId!.getDecl⟩ : Under)
    let emptyFn ← emptyBranchFn listShape re.src
    let nodesFn ← recordFamily listShape c.ctx (mkApp3 (mkConst ``Expr) c.sigs · (tyExpr re.ty))
      [ub.r.src]
    let src ← mkAppM ``Expr.treeCase #[x, emptyFn, nodesFn]
    let common := [(`S, c.sigs), (`Γ, c.ctx), (`funs, c.funs), (`env, c.env),
      (`x, x), (`empty, re.src), (`node, ub.r.src), (`xs, xs), (`value, xs), (`hx, hx)]
    let proof ← withExistingLocalDecls ub.decls do
      let hn ← mkLambdaFVars ub.xs ub.r.proof
      let rule ← LemmaApp.start ``listCase_eq (common ++
        [(`flatten, ← (← shapeOf (← inferType empty)).fn (← inferType empty)),
          (`a, empty), (`b, branch)])
      rule.assign `he (← mkExpectedTypeHint (← userProof c re) (← rule.hypType `he))
      rule.assign `hn (← mkExpectedTypeHint hn (← rule.hypType `hn))
      rule.finish
    let bound : BoundBuilder := fun modes paid live => do
      let app ← LemmaApp.start ``listCase_bound
        (boundArgs c (c.tables.table false) modes paid live ++ common)
      let some (_, rootCost, _) := (← app.hypType `hc).eq?
        | throwError "verified_compile: malformed list root cost"
      let (``Var.cost, #[_, rootLive, _, _, _, _]) := rootCost.getAppFnArgs
        | throwError "verified_compile: malformed list root liveness"
      let root ← LemmaApp.start ``varCost_eq
        (boundArgs c (c.tables.table false) modes paid rootLive ++ [(`x, x)])
      let _ ← root.child `h (varBound c x (.tree listShape) xs)
      app.assign `hc (← root.finish)
      let _ ← assignBranch c.base app `he re.ty re
      let nodeBound ← withExistingLocalDecls ub.decls do
        let b ← branchBound c.base (← ub.instantiate (← app.hypType `hn)) re.ty ub.r
        pure (⟨← mkLambdaFVars ub.xs b.term, ← mkLambdaFVars ub.xs b.proof⟩ : Bound)
      app.assign `N nodeBound.term
      app.assign `hn (← mkExpectedTypeHint nodeBound.proof (← app.hypType `hn))
      boundOf (← app.finish)
    let fits : FitsBuilder := do
      let app ← LemmaApp.start ``listCase_fits (fitsArgs c ++ common)
      app.childFits `he re.fits
      let nb ← ub.fits
      app.assign `N nb.term
      app.assign `hn (← mkExpectedTypeHint nb.proof (← app.hypType `hn))
      fitsOf (← app.finish)
    return ⟨src, ← restate proof nativeEq, re.ty, app.toExpr, bound, fits, none⟩
  reflectRecursiveMatch (app : MatcherApp) (xs : Lean.Expr) (layout : RecursiveLayout) :
      MetaM Reflection := do
    let (branches, nativeEq) ← treeMatcherCases layout app
    let (x, _) ← varOf c xs
    let hx ← bareEq (← mkAppM ``Env.get #[c.env, x]) (← flatValue xs)
    let ctors := layout.ctors.toArray
    let mut emptyR : Option Reflection := none
    let mut unders : Array Under := #[]
    let mut ty? : Option Ty := none
    for j in [:ctors.size] do
      match layout.record? ctors[j]!.1 with
      | none =>
        let re ← reflect c branches[j]!
        if let some ty := ty? then
          unless re.ty == ty do
            throwError "verified_compile: recursive branches have different source types"
        ty? := some re.ty
        emptyR := some re
      | some r =>
        let ub ← withRecursiveCaseFields c layout r fun inner fields => do
          let rn ← reflect inner (branches[j]!.beta fields)
          pure (⟨{ rn with proof := ← userProof inner rn }, fields,
            ← fields.toList.mapM fun field => field.fvarId!.getDecl⟩ : Under)
        if let some ty := ty? then
          unless ub.r.ty == ty do
            throwError "verified_compile: recursive branches have different source types"
        ty? := some ub.r.ty
        unders := unders.push ub
    let some ty := ty? | throwError "verified_compile: a recursive match without branches"
    let underAt (i : Nat) : MetaM Under := do
      let some u := unders[i]? | throwError "verified_compile: a record branch is missing"
      return u
    let exprType (ctx : Lean.Expr) := mkApp3 (mkConst ``Expr) c.sigs ctx (tyExpr ty)
    let emptyFn ← match emptyR with
      | some re => emptyBranchFn layout.shape re.src
      | none => absurdBranchFn layout.shape (exprType c.ctx)
    let nodesFn ← recordFamily layout.shape c.ctx exprType (unders.toList.map (·.r.src))
    let src ← mkAppM ``Expr.treeCase #[x, emptyFn, nodesFn]
    let decls := unders.toList.flatMap (·.decls)
    let common := [(`S, c.sigs), (`Γ, c.ctx), (`funs, c.funs), (`env, c.env),
      (`x, x), (`empty, emptyFn), (`nodes, nodesFn), (`value, xs), (`hx, hx)]
    let name (base : String) (j : Nat) : Name := Name.mkSimple s!"{base}{j}"
    -- The position among the record constructors of each constructor that is one.
    let recordOf (j : Nat) : Option Nat := (layout.record? ctors[j]!.1).map (·.val)
    let proof ← withExistingLocalDecls decls do
      let resultType := (← inferType app.toExpr).headBeta
      let flattenFn ← (← shapeOf resultType).fn resultType
      let rule ← LemmaApp.start (layout.decl `case_eq) (common ++ [(`flatten, flattenFn)] ++
        (List.range ctors.size).map fun j => (name "b" j, branches[j]!))
      for j in [:ctors.size] do
        match recordOf j, emptyR with
        | none, some re =>
          rule.assign (name "h" j) (← mkExpectedTypeHint (← userProof c re)
            (← rule.hypType (name "h" j)))
        | some i, _ =>
          let ub ← underAt i
          rule.assign (name "h" j) (← mkExpectedTypeHint (← mkLambdaFVars ub.xs ub.r.proof)
            (← rule.hypType (name "h" j)))
        | none, none => throwError "verified_compile: a null branch without a reflection"
      rule.finish
    let bound : BoundBuilder := fun modes paid live => do
      let app ← LemmaApp.start (layout.decl `case_bound)
        (boundArgs c (c.tables.table false) modes paid live ++ common)
      for j in [:ctors.size] do
        match recordOf j, emptyR with
        | none, some re =>
          let _ ← assignBranch c.base app (name "h" j) re.ty re
        | some i, _ =>
          let ub ← underAt i
          let some (_, rootCost, _) := (← app.hypType (name "hc" j)).eq?
            | throwError "verified_compile: malformed recursive root cost"
          let (``Var.cost, #[_, rootLive, _, _, _, _]) := rootCost.getAppFnArgs
            | throwError "verified_compile: malformed recursive root liveness"
          let root ← LemmaApp.start ``varCost_eq
            (boundArgs c (c.tables.table false) modes paid rootLive ++ [(`x, x)])
          let _ ← root.child `h (varBound c x (.tree layout.shape) xs)
          app.assign (name "hc" j) (← root.finish)
          let nodeBound ← withExistingLocalDecls ub.decls do
            let b ← branchBound c.base (← ub.instantiate (← app.hypType (name "h" j))) ty ub.r
            pure (⟨← mkLambdaFVars ub.xs b.term, ← mkLambdaFVars ub.xs b.proof⟩ : Bound)
          app.assign (name "N" j) nodeBound.term
          app.assign (name "h" j)
            (← mkExpectedTypeHint nodeBound.proof (← app.hypType (name "h" j)))
        | none, none => throwError "verified_compile: a null branch without a reflection"
      boundOf (← app.finish)
    let fits : FitsBuilder := do
      let app ← LemmaApp.start (layout.decl `case_fits) (fitsArgs c ++ common)
      for j in [:ctors.size] do
        match recordOf j, emptyR with
        | none, some re => app.childFits (name "h" j) re.fits
        | some i, _ =>
          let nb ← (← underAt i).fits
          app.assign (name "N" j) nb.term
          app.assign (name "h" j) (← mkExpectedTypeHint nb.proof (← app.hypType (name "h" j)))
        | none, none => throwError "verified_compile: a null branch without a reflection"
      fitsOf (← app.finish)
    return ⟨src, ← restate proof nativeEq, ty, app.toExpr, bound, fits, none⟩
  reflectDataMatch (app : MatcherApp) (name : Name) : MetaM Reflection := do
    let d := app.discrs[0]!
    unless (← projReduce d).isFVar do
      return ← reflectAs (← withLetDecl `t (← inferType d) d fun y => do
        mkLetFVars #[y] { app with discrs := #[y] }.toExpr) app.toExpr
    unless app.remaining.isEmpty do
      throwError "verified_compile: the match {app.toExpr} is applied to further arguments"
    let .lam _ _ resultTy _ := app.motive
      | throwError "verified_compile: the match {app.toExpr} has an unexpected motive"
    if resultTy.hasLooseBVars then
      throwError "verified_compile: the type of the match {app.toExpr} depends on its value"
    let type ← inferType d
    let layout ← sumLayout type name
    let flat := mkApp3 (mkConst ``LeanExe.Pipeline.Flat.flat) type layout.flatType layout.inst
    let altTys ← app.alts.mapM inferType
    let hyps := (List.range app.alts.size).toArray.map fun i => (Name.mkSimple s!"h{i}", altTys[i]!)
    let heap ← heapSum? type
    withLocalDeclsDND hyps fun hs => withLocalDeclD `x type fun x => do
      -- The chain reads the components of the tuple `P` of `x` and closes it with `close`.  A sum
      -- that holds heap values binds its tuple once with `let`, which the reflector destructures
      -- into variables, one for each component; a scalar sum projects its variable.
      let run (P : Lean.Expr) (close : Lean.Expr → MetaM Lean.Expr) : MetaM Reflection := do
        let choices ← layout.ctors.toList.mapM fun ctor => do
          let info ← getConstInfoCtor ctor.name
          forallTelescope info.type fun fields _ => do
            let value := mkAppN (mkConst ctor.name) fields
            let .reduced v ← reduceMatcher? { app with discrs := #[value], alts := hs }.toExpr
              | throwError "verified_compile: cannot reduce the match {app.toExpr} at {ctor.name}"
            let some j := hs.findIdx? (· == v.getAppFn)
              | throwError "verified_compile: the match {app.toExpr} at {ctor.name} gives {v}"
            let replacements ← ctor.fields.mapM (projectTuple P)
            let args := v.getAppArgs.map fun arg =>
              (arg.replace fun term => if term == value then some x else none).replaceFVars
                fields replacements
            return (ctor.tag, j, args)
        let groups ← (List.range app.alts.size).filterMapM fun j => do
          let cs := choices.filter (·.2.1 == j)
          let (_, _, args) :: _ := cs | return none
          for (_, _, other) in cs do
            unless args.size == other.size do
              throwError "verified_compile: inconsistent alternative arguments in {app.toExpr}"
            for i in [:args.size] do
              unless ← kernelDefEq args[i]! other[i]! do
                throwError "verified_compile: an alternative of {app.toExpr} binds different \
                  fields"
          return some (cs.map (·.1), j, args)
        let tag ← projectTuple P layout.tagPath
        let rec chain (alts : Array Lean.Expr) (beta : Bool) :
            List (List UInt64 × Nat × Array Lean.Expr) → MetaM Lean.Expr
          | [] => throwError "verified_compile: the match {app.toExpr} has no alternatives"
          | [(_, j, args)] => return if beta then alts[j]!.beta args else mkAppN alts[j]! args
          | ([w], j, args) :: rest => do
            let test ← mkAppM ``BEq.beq #[tag, toExpr w]
            let branch := if beta then alts[j]!.beta args else mkAppN alts[j]! args
            mkAppM ``ite #[← mkEq test (mkConst ``Bool.true), branch, ← chain alts beta rest]
          | _ :: _ =>
            throwError "verified_compile: a wildcard alternative must be last in {app.toExpr}"
        let chainAbs ← close (← chain hs false groups)
        let matchAbs := { app with discrs := #[x], alts := hs }.toExpr
        let motive ← mkLambdaFVars #[x] (← mkEq chainAbs matchAbs)
        let minors ← layout.ctors.mapM fun ctor => do
          let info ← getConstInfoCtor ctor.name
          forallTelescope info.type fun fields _ => do
            let value := mkAppN (mkConst ctor.name) fields
            let lhs := chainAbs.replaceFVar x value
            let rhs := matchAbs.replaceFVar x value
            unless ← kernelDefEq lhs rhs do
              throwError "verified_compile: the Flat fields of {ctor.name} do not reproduce its \
                match"
            mkLambdaFVars fields (← mkExpectedTypeHint (← mkEqRefl lhs) (← mkEq lhs rhs))
        let cases := mkAppN (mkConst (name ++ `casesOn) [Level.zero]) (#[motive, x] ++ minors)
        let gen ← mkLambdaFVars (hs.push x) cases
        let eq := mkAppN gen (app.alts.push d)
        let chainReal := (← close (← chain app.alts true groups)).replaceFVar x d
        reflectVia chainReal eq
      if heap then
        withLetDecl `p layout.flatType (mkApp flat x) fun p => run p (mkLetFVars #[p])
      else run (mkApp flat x) pure

  /-- An `if` on the condition `p` between `a` and `b`, whose meaning is the `if` of their
  flattenings. -/
  reflectIte (p inst a b : Lean.Expr) : MetaM Reflection := do
    let ra ← reflect c a
    let rb ← reflect c b
    let iteBound (thm : Name) (condArgs : List (Name × Lean.Expr))
        (conds : List (Name × Reflection)) (cond : BoundBuilder) : BoundBuilder :=
        fun modes paid live => do
      let bounds := c.tables.table false
      let app ← LemmaApp.start thm
        (boundArgs c bounds modes paid live ++ condArgs ++ [(`a, ra.src), (`b, rb.src)])
      let _ ← assignMode app `M `hM
      for (name, r) in conds do app.assign name (← userProof c r)
      app.assign `ha (← userProof c ra)
      app.assign `hb (← userProof c rb)
      let _ ← app.child `hca cond
      let _ ← assignBranch c.base app `haa ra.ty ra
      let _ ← assignBranch c.base app `hba rb.ty rb
      boundOf (← app.finish)
    let iteFits (thm : Name) (condArgs : List (Name × Lean.Expr))
        (conds : List (Name × Reflection)) (cond : FitsBuilder) : FitsBuilder := do
      let app ← LemmaApp.start thm (fitsArgs c ++ condArgs ++ [(`a, ra.src), (`b, rb.src)])
      for (name, r) in conds do app.assign name (← userProof c r)
      app.childFits `hcf cond
      app.childFits `haf ra.fits
      app.childFits `hbf rb.fits
      fitsOf (← app.finish)
    let iteBuys (rc : Reflection) : BoundBuilder := fun modes paid live => do
      let app ← LemmaApp.start ``ite_buys
        (buysArgs c modes paid live ++ [(`c, rc.src), (`a, ra.src), (`b, rb.src)])
      app.assign `hc (← userProof c rc)
      app.assign `ha (← userProof c ra)
      app.assign `hb (← userProof c rb)
      let _ ← app.childBuys `hya (buysOf c ra)
      let _ ← app.childBuys `hyb (buysOf c rb)
      assignBuy c.base app `KA `hka ra.ty ra.lean
      assignBuy c.base app `KB `hkb rb.ty rb.lean
      boundOf (← app.finish)
    match (p.consumeMData).getAppFnArgs with
    | (``Eq, #[α, cond, tru]) =>
      if (← whnfR α).isConstOf ``Bool && tru.isConstOf ``Bool.true then
        let rc ← reflect c cond
        return ⟨← mkAppM ``Expr.ite #[rc.src, ra.src, rb.src],
          ← mkAppM ``ite_eq #[rc.proof, ra.proof, rb.proof], ra.ty, a,
          iteBound ``ite_bound [(`c, rc.src)] [(`hc, rc)] rc.bound,
          iteFits ``ite_fits [(`c, rc.src)] [(`hc, rc)] rc.fits, some (iteBuys rc)⟩
    | _ => pure ()
    match p.consumeMData.getAppFnArgs with
    | (``Eq, #[α, _, _]) | (``Ne, #[α, _, _]) =>
      if (← whnfR α).isConstOf ``Bool then
        let d ← mkAppOptM ``Decidable.decide #[some p, some inst]
        let rc ← reflect c d
        let h ← mkAppM ``ite_eq #[rc.proof, ra.proof, rb.proof]
        let A ← flatValue a
        let B ← flatValue b
        let eq ← mkAppOptM ``ite_decide_eq
          #[some (← inferType A), some p, some inst, some A, some B]
        return ⟨← mkAppM ``Expr.ite #[rc.src, ra.src, rb.src],
          ← mkEqTrans h eq, ra.ty, a,
          iteBound ``ite_bound [(`c, rc.src)] [(`hc, rc)] rc.bound,
          iteFits ``ite_fits [(`c, rc.src)] [(`hc, rc)] rc.fits, some (iteBuys rc)⟩
    | _ => pure ()
    if let some (op, l, r) ← fcomparison? p then
      let rl ← reflect c l
      let rr ← reflect c r
      let fp32 := rl.ty == .float32
      let cond ← mkAppM (if fp32 then ``Expr.fcmp32 else ``Expr.fcmp) #[fcmpExpr op, rl.src, rr.src]
      let (thm, bthm, fthm) ← match op, fp32 with
        | .lt, false => pure (``ite_flt_eq, ``ite_flt_bound, ``ite_flt_fits)
        | .le, false => pure (``ite_fle_eq, ``ite_fle_bound, ``ite_fle_fits)
        | .lt, true => pure (``ite_flt32_eq, ``ite_flt32_bound, ``ite_flt32_fits)
        | .le, true => pure (``ite_fle32_eq, ``ite_fle32_bound, ``ite_fle32_fits)
        | .eq, _ => throwError "verified_compile: unsupported condition {p}"
      return ⟨← mkAppM ``Expr.ite #[cond, ra.src, rb.src],
        ← mkAppM thm #[rl.proof, rr.proof, ra.proof, rb.proof], ra.ty, a,
        iteBound bthm [(`l, rl.src), (`r, rr.src)] [(`hl, rl), (`hr, rr)]
          (binBound c (if fp32 then ``fcmp32_bound else ``fcmp_bound) [(`op, fcmpExpr op)] rl rr),
        iteFits fthm [(`l, rl.src), (`r, rr.src)] [(`hl, rl), (`hr, rr)]
          (binFits c (if fp32 then ``fcmp32_fits else ``fcmp_fits) [(`op, fcmpExpr op)] rl rr), none⟩
    let some (op, l, r) ← comparison? p
      | throwError "verified_compile: unsupported condition {p}"
    let rl ← reflect c l
    let rr ← reflect c r
    let cond ← mkAppM ``Expr.cmp #[cmpExpr op, rl.src, rr.src]
    let (bthm, fthm) := match op with
      | .lt => (``ite_lt_bound, ``ite_lt_fits)
      | .le => (``ite_le_bound, ``ite_le_fits)
      | .eq => (``ite_eqP_bound, ``ite_eqP_fits)
      | .ne => (``ite_ne_bound, ``ite_ne_fits)
    return ⟨← mkAppM ``Expr.ite #[cond, ra.src, rb.src],
      ← mkAppM (iteLemma op) #[rl.proof, rr.proof, ra.proof, rb.proof], ra.ty, a,
      iteBound bthm [(`l, rl.src), (`r, rr.src)] [(`hl, rl), (`hr, rr)]
        (binBound c ``cmp_bound [(`op, cmpExpr op)] rl rr),
      iteFits fthm [(`l, rl.src), (`r, rr.src)] [(`hl, rl), (`hr, rr)]
        (binFits c ``cmp_fits [(`op, cmpExpr op)] rl rr), none⟩
  /-- The reflection of `body` in the context `c`, with each variable of `xs` that has a pair
  type split first into its components, except a variable of a sum that holds heap values. -/
  reflectSplit (c : Ctx) : List Lean.Expr → Lean.Expr → MetaM Reflection
    | [], body => reflect c body
    | x :: rest, body => do
      match ← tyOf (← inferType x) with
      | .pair _ _ =>
        if ← heapSum? (← inferType x) then return ← reflectSplit c rest body
        let view ← pairView c.base (← inferType x)
        let r ← destructure c rest x fun a b => do
          return body.replaceFVar x (← view.rebuild a b)
        -- The body at the value built from `x`'s components is the body, by the view's eta.
        let P := view.pair x
        let split := body.replaceFVar x
          (← view.rebuild (← mkAppM ``Prod.fst #[P]) (← mkAppM ``Prod.snd #[P]))
        let eta ← view.eta (← mkLambdaFVars #[x] body) x
        return r.as (← restate r.proof (← mkExpectedTypeHint eta (← mkEq split body))) body
      | _ => reflectSplit c rest body
  /-- The reflection of `body a` with `a : α` of type `s` as variable 0, with its proof and its
  bound abstracted over `a`, which is split when it has a pair type. -/
  reflectUnder1 (c : Ctx) (α : Lean.Expr) (s : Ty) (body : Lean.Expr → MetaM Lean.Expr) :
      MetaM Under :=
    withLocalDeclD `a α fun a => do
      let env' ← mkAppOptM ``Env.cons
        #[some c.ctx, some (tyExpr s), some (← flatValue a), some c.env]
      let c' : Ctx := { c with vars := (a, s) :: c.vars, env := env', ctx := consCtx s c.ctx }
      let r ← reflectSplit c' [a] (← body a)
      let proof ← mkLambdaFVars #[a] r.proof
      return ⟨{ r with proof, buys := some (buysOf c' r) }, #[a], [← a.fvarId!.getDecl]⟩
  /-- The reflection of `body a b` with `a : α` of type `s` as variable 1 and `b : β` of type `t`
  as variable 0, with its proof and its bound abstracted over `a` and `b`.  The variables `a`,
  `b`, and `rest` that have pair types are split. -/
  reflectUnder (c : Ctx) (rest : List Lean.Expr) (α β : Lean.Expr) (s t : Ty)
      (body : Lean.Expr → Lean.Expr → MetaM Lean.Expr) : MetaM Under :=
    withLocalDeclD `a α fun a => withLocalDeclD `b β fun b => do
      let envA ← mkAppOptM ``Env.cons
        #[some c.ctx, some (tyExpr s), some (← flatValue a), some c.env]
      let ctxA := consCtx s c.ctx
      let envB ← mkAppOptM ``Env.cons
        #[some ctxA, some (tyExpr t), some (← flatValue b), some envA]
      let c' : Ctx := { c with vars := (b, t) :: (a, s) :: c.vars, env := envB, ctx := consCtx t ctxA }
      let r ← reflectSplit c' (b :: a :: rest) (← body a b)
      let proof ← mkLambdaFVars #[a, b] r.proof
      return ⟨{ r with proof, buys := some (buysOf c' r) }, #[a, b],
        [← a.fvarId!.getDecl, ← b.fvarId!.getDecl]⟩
  reflectUnder3 (c : Ctx) (α β γ : Lean.Expr) (s t u : Ty)
      (body : Lean.Expr → Lean.Expr → Lean.Expr → MetaM Lean.Expr) : MetaM Under :=
    withLocalDeclD `i α fun i => withLocalDeclD `a β fun a => withLocalDeclD `v γ fun v => do
      let envI ← mkAppOptM ``Env.cons
        #[some c.ctx, some (tyExpr s), some (← flatValue i), some c.env]
      let ctxI := consCtx s c.ctx
      let envA ← mkAppOptM ``Env.cons
        #[some ctxI, some (tyExpr t), some (← flatValue a), some envI]
      let ctxA := consCtx t ctxI
      let envV ← mkAppOptM ``Env.cons
        #[some ctxA, some (tyExpr u), some (← flatValue v), some envA]
      let c' : Ctx := { c with
        vars := (v, u) :: (a, t) :: (i, s) :: c.vars
        env := envV
        ctx := consCtx u ctxA }
      let r ← reflectSplit c' [v, a, i] (← body i a v)
      let proof ← mkLambdaFVars #[i, a, v] r.proof
      return ⟨{ r with proof, buys := some (buysOf c' r) }, #[i, a, v],
        [← i.fvarId!.getDecl, ← a.fvarId!.getDecl, ← v.fvarId!.getDecl]⟩
  /-- A component of a tuple or a field of a structure, `e`, a chain of `Prod.fst`, `Prod.snd`,
  and structure projections: the projection of a variable along a path, with a value that is not
  a variable bound with `let` first.  Besides the base and the path, the walk returns the chain as
  a function of the base. -/
  reflectProj (e : Lean.Expr) : MetaM Reflection := do
    let rec walk (e : Lean.Expr) (steps : List Bool) :
        MetaM (Lean.Expr × List Bool × (Lean.Expr → MetaM Lean.Expr)) := do
      let e ← projReduce e
      let down (p : Lean.Expr) (path : List Bool) (step : Lean.Expr → MetaM Lean.Expr) := do
        let (base, steps, chain) ← walk p (path ++ steps)
        return (base, steps, fun y => do step (← chain y))
      match e.getAppFnArgs with
      | (``LeanExe.Pipeline.Flat.flat, #[α, β, inst, p]) =>
        let some (_, flatInst) ← flatInstance? α
          | throwError "verified_compile: unsupported Flat projection {e}"
        unless ← kernelDefEq inst flatInst do
          throwError "verified_compile: {e} uses a different Flat instance"
        down p [] (fun y => pure (mkApp4 (mkConst ``LeanExe.Pipeline.Flat.flat) α β inst y))
      | (``Prod.fst, #[_, _, p]) =>
        if let .elem _ ← tyOf (← inferType p) then down p [false] (mkAppM ``Prod.fst #[·])
        else return (e, steps, pure)
      | (``Prod.snd, #[_, _, p]) =>
        if let .elem _ ← tyOf (← inferType p) then down p [true] (mkAppM ``Prod.snd #[·])
        else return (e, steps, pure)
      | _ =>
        let some (i, p) ← structProj? e | return (e, steps, pure)
        let some path ← fieldPath? (← inferType p) i | return (e, steps, pure)
        let some (_, fields) ← structOf? (← inferType p) | return (e, steps, pure)
        down p path (mkProjection · fields[i]!)
    let (base, steps, chain) ← walk e []
    if base.isFVar then
      if let some r ← keyedComponent? c base steps then return r.as' e
      let (x, t) ← varOf c base
      let .elem be := t | throwError "verified_compile: {base} is not a tuple"
      let (path, target) ← pathExpr be steps
      let src ← mkAppOptM ``Expr.proj #[some c.sigs, some c.ctx, some (elemExpr be),
        some (elemExpr target), some x, some path]
      return ⟨src, ← rflProof c src (← flatValue e), .elem target, e,
        leafBound c ``proj_bound [(`x, x), (`p, path)], leafFits c src, none⟩
    reflectAs (← withLetDecl `t (← inferType base) base fun y => do
      mkLetFVars #[y] (← chain y)) e
  /-- The destructuring of the pair or record `p` into the components `a` and `b` of its pair
  view, as variables 1 and 0 of the body `body a b`, in which the variables `rest` are split. -/
  destructure (c : Ctx) (rest : List Lean.Expr) (p : Lean.Expr)
      (body : Lean.Expr → Lean.Expr → MetaM Lean.Expr) : MetaM Reflection := do
    let rp ← reflect c p
    let .pair s t := rp.ty | throwError "verified_compile: {p} is not a pair"
    let view ← pairView c.base (← inferType p)
    let u ← reflectUnder c rest view.α view.β s t body
    let rb := u.r
    let sa ← shapeOf view.α
    let sb ← shapeOf view.β
    let src ← mkAppM ``Expr.letPair #[rp.src, rb.src]
    let flat := sa.flat.isSome || sb.flat.isSome
    let identity (α : Lean.Expr) : MetaM Lean.Expr :=
      withLocalDeclD `x α fun x => mkLambdaFVars #[x] x
    let flatArgs ← if flat then
        pure [(`φa, ← match sa.flat with | some f => pure f | none => identity view.α),
          (`φb, ← match sb.flat with | some f => pure f | none => identity view.β),
          (`P, view.pair p)]
      else pure []
    -- The components, those of a pair built in place or the projections, assigned with the
    -- pair's equation.
    let parts (app : LemmaApp) : MetaM (Lean.Expr × Lean.Expr) := do
      app.assign `he (← userProof c rp)
      let pair ← if flat then pure (view.pair p)
        else instantiateMVars app.mvars[← app.index `E]!
      let (A, B) ← match pair.getAppFnArgs with
        | (``Prod.mk, #[_, _, a, b]) => pure (a, b)
        | _ => do pure (← mkAppM ``Prod.fst #[pair], ← mkAppM ``Prod.snd #[pair])
      app.assign `A A
      app.assign `B B
      app.assign `hA (← mkEqRefl A)
      app.assign `hB (← mkEqRefl B)
      return (A, B)
    let bound : BoundBuilder := fun modes paid live => do
      let bounds := c.tables.table false
      let app ← LemmaApp.start (if flat then ``letPair_flat_bound else ``letPair_bound)
        (boundArgs c bounds modes paid live ++ [(`e, rp.src), (`body, rb.src)] ++ flatArgs)
      let m ← assignMode app `m `hm
      let p ← assignPaid app
      let (A, B) ← parts app
      let _ ← app.child `hea rp.bound
      let bb ← u.bound (← mkAppM ``List.cons #[m, ← mkAppM ``List.cons #[m, modes]])
        (← mkAppM ``List.cons #[p, ← mkAppM ``List.cons #[p, paid]])
        (← mkAppM ``shift #[mkNatLit 2, live])
      app.assign `hba (← bb.at #[A, B]).proof
      boundOf (← app.finish)
    let fits : FitsBuilder := do
      let app ← LemmaApp.start (if flat then ``letPair_flat_fits else ``letPair_fits)
        (fitsArgs c ++ [(`e, rp.src), (`body, rb.src)] ++ flatArgs)
      let (A, B) ← parts app
      app.childFits `hef rp.fits
      app.childFits `hbf do (← u.fits).at #[A, B]
      fitsOf (← app.finish)
    let buys : BoundBuilder := fun modes paid live => do
      let app ← LemmaApp.start (if flat then ``letPair_flat_buys else ``letPair_buys)
        (buysArgs c modes paid live ++ [(`e, rp.src), (`body, rb.src)] ++ flatArgs)
      let m ← assignMode app `m `hm
      let p ← assignPaid app
      let (A, B) ← parts app
      let bb ← u.buys (← mkAppM ``List.cons #[m, ← mkAppM ``List.cons #[m, modes]])
        (← mkAppM ``List.cons #[p, ← mkAppM ``List.cons #[p, paid]])
        (← mkAppM ``shift #[mkNatLit 2, live])
      app.assign `hy (← bb.at #[A, B]).proof
      boundOf (← app.finish)
    if !flat then
      return ⟨src, ← mkAppM ``letPair_eq #[rp.proof, rb.proof], rb.ty, rb.lean, bound, fits,
        some buys⟩
    return ⟨src, ← mkAppM ``letPair_flat_eq #[← sa.fn view.α, ← sb.fn view.β, view.pair p,
      rp.proof, rb.proof], rb.ty, rb.lean, bound, fits, some buys⟩
  /-- A call of a listed definition before this one: the source call, with the proof built from
  the arguments' proofs and the callee's equation. -/
  reflectCall? (e : Lean.Expr) : MetaM (Option Reflection) := do
    let .const fn _ := e.getAppFn | return none
    let some j := c.callees.findIdx? (·.name == fn) | return none
    let some callee := c.callees[j]? | return none
    let args := e.getAppArgs
    unless args.size == callee.sig.params.length do
      throwError "verified_compile: {fn} must be applied to all {callee.sig.params.length} \
        arguments"
    let bind ← (args.toList.zip callee.sig.params).zipIdx.mapM fun ((a, t), i) => do
      if t.scalar then return false
      if callee.sig.mode i = .owned then return !(← projReduce a).isFVar
      return !(← isPlace a)
    if bind.any id then
      return some (← reflectAs (← bindArgs e.getAppFn args.toList bind #[] #[]) e)
    let reflected ← args.toList.mapM (reflect c)
    let nilArgs ← mkAppOptM ``Args.nil #[some c.sigs, some c.ctx]
    let argList ← reflected.foldrM (fun r acc => mkAppM ``Args.cons #[r.src, acc]) nilArgs
    let nilEq ← mkAppOptM ``ofFn_nil_eq #[some c.sigs, some c.ctx, some c.funs, some c.env]
    let hargs ← reflected.foldrM (fun r acc => mkAppM ``ofFn_cons_eq #[r.proof, acc]) nilEq
    let values ← envExpr (args.toList.zip callee.sig.params)
    let f ← fvarAt c.sigs j
    -- `funs.get f values` is the callee's meaning by `getChain`, and the callee's equation gives
    -- its value, with no unfolding of the callee's definition.
    let hf ← transHint (← getChain c.funs f values)
      (mkAppN (mkConst callee.denoteEq) args)
    let src ← mkAppM ``Expr.call #[f, ← mkAppM ``Args.get #[argList]]
    let cb := callee.bound
    let depth := callee.sig.depth
    let owned := (List.range args.size).map fun i => callee.sig.mode i == .owned &&
      !callee.sig.params[i]!.scalar
    let tuple ← argsTuple (args.toList.zip owned)
    -- The proof of `table.get f A = target` for the callee's bound or frames condition `target`
    -- at the arguments, which take the fuel first when the callee's code takes the call depth.
    let entry (fits : Bool) (name : Name) (getLhs : Lean.Expr) : MetaM Lean.Expr := do
      let chain ← c.tables.get fits f getLhs.appArg!
      let target := if depth then mkApp2 (mkConst name) c.tables.fuel tuple
        else mkApp (mkConst name) tuple
      let some (_, _, chainRhs) := (← inferType chain).eq?
        | throwError "verified_compile: the bounds of {fn}"
      checkEntryTarget m!"{fn}" chainRhs target
      mkExpectedTypeHint chain (← mkEq getLhs target)
    let bound : BoundBuilder := fun modes paid live => do
      let bounds := c.tables.table false
      let app ← LemmaApp.start ``call_bound
        (boundArgs c bounds modes paid live ++ [(`f, f), (`argList, argList)])
      for (name, h) in [(`all, `hall), (`kept, `hkept)] do
        let some (_, _, rhs) := (← app.hypType h).eq?
          | throwError "verified_compile: the argument {h} of call_bound"
        app.assign name rhs
        app.assign h (← mkEqRefl rhs)
      app.assign `hargs hargs
      let some (_, sumLhs, _) := (← app.hypType `hsum).eq?
        | throwError "verified_compile: the argument hsum of call_bound"
      -- `ArgsCost funs flags bounds modes paid all kept env md argList`, with `md` third from the
      -- end.
      let sumArgs := sumLhs.getAppArgs
      unless sumLhs.isAppOf ``ArgsCost && sumArgs.size ≥ 6 do
        throwError "verified_compile: the arguments' bound {sumLhs}"
      let all := sumArgs[sumArgs.size - 6]!
      let kept := sumArgs[sumArgs.size - 5]!
      let md := sumArgs[sumArgs.size - 3]!
      let hsum ← argsCostBound bounds modes paid all kept md (reflected.zip callee.sig.params)
        argList
      app.assign `hsum hsum
      -- The credits of the arguments at paid owned parameters that the call does not move from
      -- paid variables.
      let some (_, _, cRhs) := (← app.hypType `hc).eq?
        | throwError "verified_compile: the argument hc of call_bound"
      app.assign `c cRhs
      app.assign `hc (← mkEqRefl cRhs)
      app.assign `hcr (← argsCreditBound cRhs (reflected.zip callee.sig.params) argList)
      let some (_, getLhs, _) := (← app.hypType `hb).eq?
        | throwError "verified_compile: the argument hb of call_bound"
      let hb ← entry false cb.bound getLhs
      let hb ← match cb.numeralEq with
        | some n => mkEqTrans hb (mkAppN (mkConst n) args)
        | none => pure hb
      app.assign `hb hb
      boundOf (← app.finish)
    let fits : FitsBuilder := do
      let app ← LemmaApp.start (if depth then ``call_depth_fits else ``call_fits)
        (fitsArgs c ++ [(`f, f), (`argList, argList)])
      let some (_, sigDepth, _) := (← app.hypType `hd).eq?
        | throwError "verified_compile: the argument hd of the frames of a call"
      app.assign `hd (← evalEq sigDepth (boolConst depth))
      app.assign `hsum (← argsFits reflected argList)
      if depth then
        let some name := cb.fits?
          | throwError "verified_compile: {fn} takes the call depth and has no frames condition"
        app.assign `hargs hargs
        let some (_, getLhs, _) := (← app.hypType `hf).eq?
          | throwError "verified_compile: the argument hf of call_depth_fits"
        app.assign `hf (← entry true name getLhs)
      fitsOf (← app.finish)
    return some ⟨src, ← mkAppM ``call_eq #[f, hargs, hf], callee.sig.result, e, bound, fits, none⟩
  /-- The proof of `ArgsFits funs fits env argList = AS` for the arguments `args`. -/
  argsFits (args : List Reflection) (argList : Lean.Expr) : MetaM Lean.Expr := do
    match args with
    | [] => (← LemmaApp.start ``argsFits_nil (fitsArgs c)).finish
    | r :: rest =>
      let restList := argList.appArg!
      let app ← LemmaApp.start ``argsFits_cons (fitsArgs c ++ [(`e, r.src), (`rest, restList)])
      app.childFits `he r.fits
      app.assign `hr (← argsFits rest restList)
      app.finish
  /-- The proof of `ArgsCost funs flags bounds modes paid all kept env md argList = AS` for the
  arguments `args`, each with its parameter type. -/
  argsCostBound (bounds modes paid all kept md : Lean.Expr) (args : List (Reflection × Ty))
      (argList : Lean.Expr) : MetaM Lean.Expr := do
    let common := [(`S, c.sigs), (`Γ, c.ctx), (`funs, c.funs), (`flags, c.tables.flags),
      (`bounds, bounds), (`modes, modes), (`paid, paid), (`all, all), (`kept, kept),
      (`env, c.env), (`md, md)]
    match args with
    | [] => return (← (← LemmaApp.start ``argsCost_nil common).finish)
    | (r, t) :: rest =>
      let restList := argList.appArg!
      let parts := common ++ [(`e, r.src), (`rest, restList)]
      let scalar := mkApp (mkConst ``Ty.scalar) (tyExpr t)
      let app ← if t.scalar then do
          let app ← LemmaApp.start ``argsCost_scalar
            (parts ++ [(`ht, ← evalEq scalar (boolConst true))])
          let some (_, lhs, _) := (← app.hypType `he).eq?
            | throwError "verified_compile: the argument he of argsCost_scalar"
          let (``Expr.allocs, #[_, _, _, _, ms, pd, lv, _, _, _, _]) := lhs.getAppFnArgs
            | throwError "verified_compile: the argument he of argsCost_scalar"
          let b ← r.bound ms pd lv
          app.assign `he b.proof
          pure app
        else do
          let m0 := (mkApp md (mkNatLit 0)).headBeta
          if ← evalOwned m!"the mode of a parameter" m0 then
            let app ← LemmaApp.start ``argsCost_owned (parts ++
              [(`ht, ← evalEq scalar (boolConst false)), (`hm, ← evalEq m0 (modeConst true))])
            let (``Expr.var, #[_, _, _, x]) := r.src.getAppFnArgs
              | throwError "verified_compile: an argument at an owned parameter is not a variable"
            app.assign `he (← (← LemmaApp.start ``ownedArg_var [(`S, c.sigs), (`Γ, c.ctx),
              (`modes, modes), (`env, c.env), (`x, x), (`kept, kept),
              (`h, ← varOwnedEq c modes kept x t r.lean)]).finish)
            pure app
          else
            LemmaApp.start ``argsCost_borrowed (parts ++
              [(`ht, ← evalEq scalar (boolConst false)), (`hm, ← evalEq m0 (modeConst false))])
      let some (_, lhs, _) := (← app.hypType `hr).eq?
        | throwError "verified_compile: the argument hr of the arguments' bound"
      let restArgs := lhs.getAppArgs
      unless lhs.isAppOf ``ArgsCost && restArgs.size ≥ 3 do
        throwError "verified_compile: the arguments' bound {lhs}"
      let md' := restArgs[restArgs.size - 3]!
      let hr ← argsCostBound bounds modes paid all kept md' rest restList
      app.assign `hr hr
      return (← boundOf (← app.finish)).proof
  /-- The proof of `ArgsCredit funs env cf argList = CR` for the arguments `args`, each with its
  parameter type: the credit of each argument for which the kernel evaluates `cf` to `true`. -/
  argsCreditBound (cf : Lean.Expr) (args : List (Reflection × Ty)) (argList : Lean.Expr) :
      MetaM Lean.Expr := do
    let common := [(`S, c.sigs), (`Γ, c.ctx), (`funs, c.funs), (`env, c.env), (`c, cf)]
    match args with
    | [] => (← LemmaApp.start ``argsCredit_nil common).finish
    | (r, t) :: rest =>
      let restList := argList.appArg!
      let parts := common ++ [(`e, r.src), (`rest, restList)]
      let probe ← LemmaApp.start ``argsCredit_none parts
      let some (_, cond, _) := (← probe.hypType `hc).eq?
        | throwError "verified_compile: the argument hc of argsCredit_none"
      let charged ← evalBool m!"whether a call charges a credit for {r.lean}" cond
      let app ← if charged then do
          let app ← LemmaApp.start ``argsCredit_some parts
          app.assign `hc (← evalEq cond (boolConst true))
          let some (_, credit, _) := (← app.hypType `he).eq?
            | throwError "verified_compile: the argument he of argsCredit_some"
          let (``Ty.credit, #[_, v]) := credit.getAppFnArgs
            | throwError "verified_compile: the credit {credit}"
          let (E, he) ← ValueCost.credit.eq c.base t v r.lean
          app.assign `E E
          app.assign `he he
          pure app
        else do
          probe.assign `hc (← evalEq cond (boolConst false))
          pure probe
      let some (_, lhs, _) := (← app.hypType `hr).eq?
        | throwError "verified_compile: the argument hr of the arguments' credits"
      let restArgs := lhs.getAppArgs
      unless lhs.isAppOf ``ArgsCredit && restArgs.size ≥ 2 do
        throwError "verified_compile: the arguments' credits {lhs}"
      app.assign `hr (← argsCreditBound restArgs[restArgs.size - 2]! rest restList)
      return (← boundOf (← app.finish)).proof
  reflectCmp (op : CmpOp) (a b : Lean.Expr) : MetaM Reflection := do
    let rl ← reflect c a
    unless rl.ty == .word do
      throwError "verified_compile: unsupported comparison on {← inferType a}"
    let rr ← reflect c b
    return ⟨← mkAppM ``Expr.cmp #[cmpExpr op, rl.src, rr.src],
      ← mkAppM ``cmp_eq #[cmpExpr op, rl.proof, rr.proof], .bool, a,
      binBound c ``cmp_bound [(`op, cmpExpr op)] rl rr,
      binFits c ``cmp_fits [(`op, cmpExpr op)] rl rr, none⟩
  reflectFCmp (op : FCmpOp) (a b : Lean.Expr) : MetaM Reflection := do
    let rl ← reflect c a
    let rr ← reflect c b
    let fp32 := rl.ty == .float32
    return ⟨← mkAppM (if fp32 then ``Expr.fcmp32 else ``Expr.fcmp) #[fcmpExpr op, rl.src, rr.src],
      ← mkAppM (if fp32 then ``fcmp32_eq else ``fcmp_eq) #[fcmpExpr op, rl.proof, rr.proof], .bool, a,
      binBound c (if fp32 then ``fcmp32_bound else ``fcmp_bound) [(`op, fcmpExpr op)] rl rr,
      binFits c (if fp32 then ``fcmp32_fits else ``fcmp_fits) [(`op, fcmpExpr op)] rl rr, none⟩
  reflectFUnary (op x : Lean.Expr) : MetaM Reflection := do
    let r ← reflect c x
    let fp32 := r.ty == .float32
    return ⟨← mkAppM (if fp32 then ``Expr.funary32 else ``Expr.funary) #[op, r.src],
      ← mkAppM (if fp32 then ``funary32_eq else ``funary_eq) #[op, r.proof],
      (if fp32 then .float32 else .float), x,
      unBound c (if fp32 then ``funary32_bound else ``funary_bound) [(`op, op)] r,
      unFits c (if fp32 then ``funary32_fits else ``funary_fits) [(`op, op)] r, none⟩
  reflectConv (ctor thm bthm fthm : Name) (op x : Lean.Expr) (t : Ty) : MetaM Reflection := do
    let r ← reflect c x
    return ⟨← mkAppM ctor #[op, r.src], ← mkAppM thm #[op, r.proof], t, x,
      unBound c bthm [(`op, op)] r, unFits c fthm [(`op, op)] r, none⟩

/-- The instance that Lean synthesizes for `userT`, which the theorem's statement uses. -/
def userInst (userT : Lean.Expr) : MetaM Lean.Expr := do
  let some inst ← synthInstance? (mkApp (mkConst ``LeanExe.Pipeline.Represent) userT)
    | throwError "verified_compile: Lean has no `Represent` instance for {userT}, so no theorem \
        can be stated for it"
  return inst

/-- `proof` as a proof of `Agree inst src.2 φ`, for Lean's instance `inst` for `userT`; the kernel
checks that the two types are equal by unfolding. -/
def agreeAs (userT inst : Lean.Expr) (src : Lean.Expr × Lean.Expr) (φ proof : Lean.Expr) :
    MetaM (Lean.Expr × Lean.Expr) := do
  return (φ, ← mkExpectedTypeHint proof (mkAppN (mkConst ``Agree) #[userT, src.1, inst, src.2, φ]))

/-- The proof by `rfl` of `prop`, of the form `∀ xs, a = b`, after a check that `a` and `b` are
equal by unfolding. -/
def eqByUnfolding (prop userT : Lean.Expr) : MetaM Lean.Expr :=
  forallTelescope prop fun xs eq => do
    let some (_, a, b) := eq.eq? | throwError "verified_compile: {eq} is not an equation"
    unless ← withTransparency .all (isDefEq a b) do
      throwError "verified_compile: the words of {userT} and of its flattening differ: {a} and {b}"
    mkLambdaFVars xs (← mkExpectedTypeHint (← mkEqRefl a) eq)

/-- The proof of `b = true` by evaluation, which the kernel checks. -/
def trueByEval (b : Lean.Expr) : MetaM Lean.Expr := do
  mkExpectedTypeHint (mkApp2 (mkConst ``Eq.refl [Level.one]) (mkConst ``Bool) (mkConst ``Bool.true))
    (← mkEq b (mkConst ``Bool.true))

/-- The flattening of `userT` as a lambda, the identity when nothing in it is flattened.  The
theorem applies it to Lean's values, so it carries no type annotation that would keep the
application from reducing by beta reduction. -/
def flatFn (userT : Lean.Expr) : MetaM Lean.Expr := do
  if let some f := (← shapeOf userT).flat then return f
  withLocalDeclD `x userT fun x => mkLambdaFVars #[x] x

/-- `Agree.refl` for a type that the reflector does not flatten, after a check that Lean's instance
unfolds to the source instance. -/
def agreeRefl (userT inst : Lean.Expr) (src : Lean.Expr × Lean.Expr) :
    MetaM (Lean.Expr × Lean.Expr) := do
  unless ← withTransparency .all (isDefEq inst src.2) do
    throwError "verified_compile: Lean's instance for {userT} does not unfold to the source \
      instance"
  agreeAs userT inst src (← withLocalDeclD `x userT fun x => mkLambdaFVars #[x] x)
    (← mkAppM ``Agree.refl #[inst])

/-- `Agree.scalar` for a type without arrays, whose source instance comes from `srcScalar`, along
the flattening `φ`. -/
def agreeScalar (userT inst : Lean.Expr) (src : Lean.Expr × Lean.Expr) (srcScalar φ : Lean.Expr) :
    MetaM (Lean.Expr × Lean.Expr) := do
  let some userScalar ← synthInstance? (mkApp (mkConst ``LeanExe.Pipeline.Scalar) userT)
    | throwError "verified_compile: Lean has no `Scalar` instance for {userT}"
  let app ← mkAppOptM ``Agree.scalar #[some userT, some src.1, some userScalar, some srcScalar,
    some φ]
  let .forallE _ hTy _ _ ← inferType app | throwError "verified_compile: `Agree.scalar`"
  agreeAs userT inst src φ (mkApp app (← eqByUnfolding hTy userT))

/-- The flattening of an array of the structure type `el`, inside `Moved` for `Agree.flatMoved`,
and the proof of agreement by `thm`, `Agree.flatArray` or `Agree.flatMoved`. -/
def agreeArray (thm : Name) (el : Lean.Expr) : MetaM (Lean.Expr × Lean.Expr) := do
  let se ← shapeOf el
  let .elem e := se.ty | throwError "verified_compile: an array holds elements, not {el}"
  let app ← mkAppOptM thm #[some el, none, none, none, some (elemExpr e), some (← se.fn el)]
  let .forallE _ hφTy concl _ ← inferType app
    | throwError "verified_compile: the hypothesis of {thm}"
  return (concl.appArg!, mkApp app (← eqByUnfolding hφTy el))

/-- The flattening of pairs from the flattenings of their components and the agreement by
`Agree.prod` from the components' agreements. -/
def agreeProd (a b : Lean.Expr × Lean.Expr) : MetaM (Lean.Expr × Lean.Expr) := do
  let proof ← mkAppM ``Agree.prod #[a.2, b.2]
  return (← Core.betaReduce (← inferType proof).appArg!, proof)

/-- The flattening of Lean's values of type `userT` to the meaning of `t`, and the proof that the
instance Lean synthesizes for `userT` agrees with `Ty.leanInst t` along it: `Agree.scalar` for a
type without arrays, `Agree.flatArray` for an array of structures, `Agree.refl` for another array,
and `Agree.prod` for a pair that holds arrays. -/
partial def agreeTy (userT : Lean.Expr) (t : Ty) : MetaM (Lean.Expr × Lean.Expr) := do
  let inst ← userInst userT
  let src := (mkApp (mkConst ``Ty.denote) (tyExpr t), mkApp (mkConst ``Ty.leanInst) (tyExpr t))
  -- Every agreement is stated along `flatFn userT`, the flattening of the equation's right side.
  let φ ← flatFn userT
  if t.scalar then
    let h ← trueByEval (mkApp (mkConst ``Ty.scalar) (tyExpr t))
    return ← agreeScalar userT inst src (mkApp2 (mkConst ``Ty.scalarInst) (tyExpr t) h) φ
  match t, (← whnfR userT).getAppFnArgs with
  | .bytes, _ => agreeRefl userT inst src
  | .tree _, (``List, #[_]) =>
    agreeAs userT inst src φ (mkConst ``Agree.listTree)
  | .tree _, _ =>
    let some layout ← recursiveLayout? userT
      | throwError "verified_compile: no recursive layout for {userT}"
    agreeAs userT inst src φ
      (← mkAppM ``Agree.encode #[φ, mkConst (layout.decl `encoding)])
  | .array _, (``Array, #[el]) =>
    if (← shapeOf el).flat.isNone then return ← agreeRefl userT inst src
    let (_, proof) ← agreeArray ``Agree.flatArray el
    agreeAs userT inst src φ proof
  | .pair a b, (``Prod, #[ua, ub]) =>
    let (_, proof) ← agreeProd (← agreeTy ua a) (← agreeTy ub b)
    agreeAs userT inst src φ proof
  | .pair _ _, _ =>
    -- A record with arrays agrees as its `Flat` tuple does.
    let some (β, _) ← flatInstance? userT
      | throwError "verified_compile: the type {userT} does not have the shape of {tyExpr t}"
    let (_, proof) ← agreeTy β t
    agreeAs userT inst src φ
      (← mkAppOptM ``Agree.flat #[some userT, some β, none, none, none, none, none, some proof])
  | _, _ => throwError "verified_compile: the type {userT} does not have the shape of {tyExpr t}"

/-- The flattening of an argument of type `userT`, a value of `t.argTy m`, and the proof of
agreement with `t.argInst m`. -/
def agreeArg (userT : Lean.Expr) (t : Ty) (m : Mode) : MetaM (Lean.Expr × Lean.Expr) := do
  let inst ← userInst userT
  let src := (mkApp2 (mkConst ``Ty.argTy) (tyExpr t) (modeExpr m),
    mkApp2 (mkConst ``Ty.argInst) (tyExpr t) (modeExpr m))
  match t, m, (← whnfR userT).getAppFnArgs with
  | .bytes, .owned, (``LeanExe.Pipeline.Moved, #[_]) => agreeRefl userT inst src
  | .tree _, .owned, (``LeanExe.Pipeline.Moved, #[native]) =>
    let proof ← if (← whnfR native).isAppOf ``List then pure (Lean.mkConst ``Agree.movedListTree)
      else do
        let some layout ← recursiveLayout? native
          | throwError "verified_compile: no recursive layout for {native}"
        mkAppM ``Agree.movedEncode
          #[mkConst (layout.decl `toTree), mkConst (layout.decl `encoding)]
    return (← Core.betaReduce (← inferType proof).appArg!, proof)
  | .array _, .owned, (``LeanExe.Pipeline.Moved, #[a]) =>
    let (``Array, #[el]) := (← whnfR a).getAppFnArgs
      | throwError "verified_compile: {a} is not an array"
    if (← shapeOf el).flat.isNone then return ← agreeRefl userT inst src
    let (φ, proof) ← agreeArray ``Agree.flatMoved el
    agreeAs userT inst src φ proof
  | _, _, _ =>
    let (φ, proof) ← agreeTy userT t
    agreeAs userT inst src φ proof

/-- The flattening of the tuple of a definition's arguments, of type `userT`, a value of
`argsTy ps ms`, and the proof of agreement with `argsInst ps ms`, by the cases of `argsInst`. -/
partial def agreeArgs (userT : Lean.Expr) (ps : List Ty) (ms : List Mode) :
    MetaM (Lean.Expr × Lean.Expr) := do
  let inst ← userInst userT
  let src := (mkApp2 (mkConst ``argsTy) (ctxExpr ps) (modesExpr ms),
    mkApp2 (mkConst ``argsInst) (ctxExpr ps) (modesExpr ms))
  if ps.all Ty.scalar then
    let h ← trueByEval (← mkAppM ``List.all #[ctxExpr ps, mkConst ``Ty.scalar])
    let φ ← if ps.isEmpty then withLocalDeclD `x userT fun x => mkLambdaFVars #[x] x
      else flatFn userT
    return ← agreeScalar userT inst src
      (mkApp3 (mkConst ``argsScalarInst) (ctxExpr ps) (modesExpr ms) h) φ
  match ps, (← whnfR userT).getAppFnArgs with
  | [t], _ =>
    let (φ, proof) ← agreeArg userT t (ms.headD .borrowed)
    agreeAs userT inst src φ proof
  | t :: u :: ts, (``Prod, #[ua, ub]) =>
    let (φ, proof) ← agreeProd (← agreeArg ua t (ms.headD .borrowed))
      (← agreeArgs ub (u :: ts) ms.tail)
    agreeAs userT inst src φ proof
  | _, _ => throwError "verified_compile: the arguments {userT} do not have the shape of the \
    parameters"

/-- What the reflector learns from one definition: its signature, whether a call may trap, the
modes of its parameters, and whether its code takes the call depth. -/
structure Reflected where
  name : Name
  params : List Ty
  result : Ty
  aborts : Bool
  modes : List Mode
  depth : Bool
  /-- The equation `∀ args, F (env of args) = flat (name args)` of the meaning `F` of the
  definition's function in the program's meanings. -/
  meaningEq : Name
  /-- The Lean type of the tuple of the definition's arguments, with `Moved` for an owned array. -/
  argsType : Lean.Expr
  /-- The Lean type of the definition's result. -/
  resultType : Lean.Expr
  /-- The flattening of the argument tuple, a lambda. -/
  flatArgs : Lean.Expr
  /-- The flattening of the result, a lambda. -/
  flatResult : Lean.Expr
  /-- The bound of a listed definition, or `none` for a wrapper. -/
  bound? : Option CalleeBound := none
  /-- Whether a parameter is paid, so that the bound adds the credits to the table's entry. -/
  paid : Bool := false
  deriving Inhabited

/-- The modes of the list of modes `e`, evaluated by the kernel. -/
partial def modesOf (e : Lean.Expr) : MetaM (Option (List Mode)) := do
  match (← kernelWhnf e).getAppFnArgs with
  | (``List.nil, _) => return some []
  | (``List.cons, #[_, m, rest]) =>
    let m ← kernelWhnf m
    let m? := if m.isConstOf ``Mode.owned then some Mode.owned
      else if m.isConstOf ``Mode.borrowed then some Mode.borrowed else none
    match m?, ← modesOf rest with
    | some m, some ms => return some (m :: ms)
    | _, _ => return none
  | _ => return none

/-- The parameter modes that `Expr.paramChoice` gives for the source body `src` of `name`. -/
def paramChoiceOf (name : Name) (src : Lean.Expr) : MetaM (List Mode) := do
  let some modes ← modesOf (← mkAppM ``Expr.paramChoice #[src])
    | throwError "verified_compile: cannot evaluate the parameter modes of {name}"
  return modes

/-- The right-nested product of `tys`, `Unit` for none. -/
def tupleType : List Lean.Expr → MetaM Lean.Expr
  | [] => return mkConst ``Unit
  | [t] => return t
  | t :: ts => do mkAppM ``Prod #[t, ← tupleType ts]

/-- What `reflectDefinition` and `reflectRecursive` record of definition `name` with parameters
`params` of types `types` and result type `resultType`: Lean's tuple of the arguments, in which an
owned array has type `Moved`, the flattenings of the arguments and of the result, and the theorems
`base.argsAgree` and `base.resultAgree` that Lean's instances agree with the source instances
along them. -/
def finishReflected (base name : Name) (params : Array Lean.Expr) (types : List Ty) (result : Ty)
    (resultType : Lean.Expr) (aborts : Bool) (modes : List Mode) (depth : Bool)
    (meaningEq : Name) : MetaM Reflected := do
  let argTys ← (params.toList.zip (paramModes types modes)).mapM fun (p, m) => do
    let ty ← inferType p
    return if m == .owned then mkApp (mkConst ``LeanExe.Pipeline.Moved) ty else ty
  let argsType ← tupleType argTys
  let (flatArgs, argsAgree) ← agreeArgs argsType types modes
  let (flatResult, resultAgree) ← agreeTy resultType result
  addTheorem (base ++ `argsAgree) (← inferType argsAgree) argsAgree
  addTheorem (base ++ `resultAgree) (← inferType resultAgree) resultAgree
  return ⟨name, types, result, aborts, modes, depth, meaningEq, argsType, resultType, flatArgs,
    flatResult, none, false⟩

/-- Adds the definition `name` of a bound or frames condition on Lean's argument tuple, with a
height above its value's, so that the kernel unfolds it, and not the compiler's function, when it
matches a statement with a proof. -/
def addBoundDefinition (name : Name) (type value : Lean.Expr) : MetaM Unit := do
  addAndCompile <| .defnDecl <| mkDefinitionValEx name [] type value
    (.regular (getMaxHeight (← getEnv) value + 1)) .safe [name]

/-- The record type, its `Flat` tuple type and instance, and the value `x` of `e = Flat.flat x`,
when the type is a structure without parameters that holds arrays, which `shapeOf` represents by
its tuple of fields.  A structure with parameters keeps the flattened form, so that the lemmas of
`flatFieldEq`, named after the structure, belong to one type. -/
def recordFlat? (e : Lean.Expr) :
    MetaM (Option (Lean.Expr × Lean.Expr × Lean.Expr × Lean.Expr)) := do
  let (``LeanExe.Pipeline.Flat.flat, #[type, τ, inst, x]) := e.getAppFnArgs | return none
  let .const _ _ := type | return none
  if (← shapeOf type).ty matches .elem _ then return none
  if (← structOf? type).isNone then return none
  return some (type, τ, inst, x)

/-- The proof of `(Flat.flat x).path = x.f`, for field `f` of a record type that holds arrays at
the leaf `path` of its tuple tree, from the theorem `base.flat_field.R.f`, which is added once per
program, record type, and field and proved by `rfl` with `v` free.  The kernel then unfolds only
the `Flat` instance and structure eta, never the term that `x` stands for. -/
def flatFieldEq (base : Name) (type τ inst : Lean.Expr) (path : List Bool) (field : Name)
    (x : Lean.Expr) : MetaM Lean.Expr := do
  let .const n _ := type
    | throwError "verified_compile: the record {type} of a field lemma has parameters"
  let name := base ++ `flat_field ++ n ++ field
  unless (← getEnv).contains name do
    let (stmt, proof) ← withLocalDeclD `v type fun v => do
      let lhs ← tuplePath (mkApp4 (mkConst ``LeanExe.Pipeline.Flat.flat) type τ inst v) path
      let rhs ← mkProjection v field
      let proof ← mkExpectedTypeHint (← mkEqRefl rhs) (← mkEq lhs rhs)
      return (← mkForallFVars #[v] (← mkEq lhs rhs), ← mkLambdaFVars #[v] proof)
    addTheorem name stmt proof
  return mkApp (mkConst name) x

/-- `y`, for an application of a structure's constructor whose fields are the projections of `y`
in order, which structure eta makes equal to `y`. -/
def structEta? (e : Lean.Expr) : MetaM (Option Lean.Expr) := do
  let some fs ← ctorFields? e | return none
  let mut y? : Option Lean.Expr := none
  for h : i in [0:fs.size] do
    let some (j, y) ← structProj? fs[i] | return none
    unless j == i do return none
    if let some y' := y? then
      unless y' == y do return none
    else y? := some y
  let some y := y? | return none
  unless ← isDefEq (← inferType y) (← inferType e) do return none
  return some y

/-- Whether `x` is a variable or a projection of one. -/
partial def isVarPlace (x : Lean.Expr) : MetaM Bool := do
  if x.isFVar then return true
  match x.getAppFnArgs with
  | (``Prod.fst, #[_, _, p]) | (``Prod.snd, #[_, _, p]) => isVarPlace p
  | _ =>
    let some (_, p) ← structProj? x | return false
    isVarPlace p

/-- The term under the pair projections of `e`, and the steps to `e` from it, `false` for a first
component and `true` for a second, before `path`. -/
partial def pairPath (e : Lean.Expr) (path : List Bool) : Lean.Expr × List Bool :=
  match e.getAppFnArgs with
  | (``Prod.fst, #[_, _, p]) => pairPath p (false :: path)
  | (``Prod.snd, #[_, _, p]) => pairPath p (true :: path)
  | _ => (e, path)

/-- `x.f`, for `e = (Flat.flat x).path` with `x` a variable or a projection of one, of a record type
that holds arrays, and `f` the field at the leaf `path` of its tuple tree.  Both sides hold the
variable, so the kernel compares them by unfolding the `Flat` instance and structure eta. -/
def placeField? (e : Lean.Expr) : MetaM (Option Lean.Expr) := do
  let (flat, path) := pairPath e []
  if path.isEmpty then return none
  let some (type, τ, inst, x) ← recordFlat? flat | return none
  unless ← isVarPlace x do return none
  let some (ctor, fields) ← structOf? type | return none
  let tree ← flatTree "verified_compile" type τ inst ctor
  let some (i, _) := tree.find? (·.2 == path) | return none
  return some (← mkProjection x fields[i]!)

/-- `y`, for a pair `(y.1, y.2)` or an application of a structure's constructor whose fields are the
projections of `y` in order, which eta makes equal to `y`. -/
def etaStep? (e : Lean.Expr) : MetaM (Option Lean.Expr) := do
  if let (``Prod.mk, #[_, _, a, b]) := e.getAppFnArgs then
    if let (``Prod.fst, #[_, _, y]) := a.getAppFnArgs then
      if let (``Prod.snd, #[_, _, y']) := b.getAppFnArgs then
        if y == y' then return some y
    return none
  structEta? e

/-- The field of a projection of an application of a structure's constructor. -/
def ctorProjStep? (e : Lean.Expr) : MetaM (Option Lean.Expr) := do
  let some (i, p) ← structProj? e | return none
  let some fs ← ctorFields? p | return none
  return fs[i]?

/-- A subterm `Flat.flat x` of `e` of a record type that holds arrays and not in `skip`, with no
loose bound variable, innermost first: the subterms of a term come before it. -/
partial def innerRecordFlat? (skip : Array Lean.Expr) (e : Lean.Expr) :
    MetaM (Option (Lean.Expr × Lean.Expr × Lean.Expr × Lean.Expr)) := do
  let sub ← match e with
    | .app f a => do
      if let some r ← innerRecordFlat? skip f then pure (some r) else innerRecordFlat? skip a
    | .lam _ t b _ | .forallE _ t b _ => do
      if let some r ← innerRecordFlat? skip t then pure (some r) else innerRecordFlat? skip b
    | .letE _ t v b _ => do
      if let some r ← innerRecordFlat? skip t then pure (some r)
      else if let some r ← innerRecordFlat? skip v then pure (some r)
      else innerRecordFlat? skip b
    | .mdata _ b | .proj _ _ b => innerRecordFlat? skip b
    | _ => pure none
  if sub.isSome then return sub
  if e.hasLooseBVars || skip.contains e then return none
  recordFlat? e

/-- `b` with each component `(Flat.flat x).path` of a record that holds arrays, at the leaf `path`
of the record's tuple tree for field `f`, written as `x.f`.  When `x` holds no variable that a
binder inside the term binds, a lemma of `flatFieldEq` rewrites it by congruence on the term with
the occurrence abstracted at reducible transparency, innermost first, so that the kernel unfolds
neither `x` nor a term that unfolds to it.  When `x` is a variable or a projection of one, also
under a binder, the component becomes `x.f` behind a type hint, which the kernel checks with the
variable free.  The hint also covers the eta of a pair or a structure into `y` when `y` is a
variable or a projection of one, and, where a term holds a variable of the context, the reduction
of a projection of a constructor's application.  A component whose `x` holds a bound variable and
is not a variable or its projection keeps its form. -/
def fieldTerms (base : Name) (b : Bound) : MetaM Bound := do
  let mut term := b.term
  let mut proof := b.proof
  let mut done : Array Lean.Expr := #[]
  repeat
    let some (type, τ, inst, x) ← innerRecordFlat? done term | break
    let flat := mkApp4 (mkConst ``LeanExe.Pipeline.Flat.flat) type τ inst x
    done := done.push flat
    let some (ctor, fields) ← structOf? type
      | throwError "verified_compile: the record {type} is not a structure"
    let tree ← flatTree "verified_compile" type τ inst ctor
    for (i, path) in tree do
      let occ ← tuplePath flat path
      let abst ← withReducible (kabstract term occ)
      unless abst.hasLooseBVars do continue
      unless abst.instantiate1 occ == term do
        throwError "verified_compile: a field of {type} abstracts to a different term"
      let eqn ← flatFieldEq base type τ inst path fields[i]! x
      let some (_, _, rhs) := (← inferType eqn).eq?
        | throwError "verified_compile: the field lemma {eqn} is not an equation"
      let motive := Lean.mkLambda `t .default (← inferType occ) abst
      let step ← mkCongrArg motive eqn
      let term' := abst.instantiate1 rhs
      proof ← mkEqTrans proof (← mkExpectedTypeHint step (← mkEq term term'))
      term := term'
  let lctx ← getLCtx
  let reduced ← Meta.transform term (post := fun e => do
    if let some e' ← placeField? e then return .done e'
    if let some y ← etaStep? e then
      if ← isVarPlace y then return .done y
    unless e.hasAnyFVar lctx.contains do return .done e
    return .done ((← ctorProjStep? e).getD e))
  if reduced == term then return if term == b.term then b else ⟨term, proof⟩
  let (lhs, _) ← eqSides proof
  return ⟨reduced, ← mkExpectedTypeHint proof (← mkEq lhs reduced)⟩

/-- Adds the theorem `name : ∀ xs, lhs = T`, for `root.proof : own = root.term` with `own` the value
of `lhs`'s definition at its arguments, which the kernel checks by unfolding `lhs`, and `T` the term
that `fieldTerms` gives for `root.term`, with the lemmas of the program `program`. -/
def addEquation (program name : Name) (xs : Array Lean.Expr) (lhs : Lean.Expr) (root : Bound) :
    MetaM Unit := do
  let (own, _) ← eqSides root.proof
  let step ← mkExpectedTypeHint (← mkEqRefl lhs) (← mkEq lhs own)
  let root ← fieldTerms program root
  addTheorem name (← mkForallFVars xs (← mkEq lhs root.term))
    (← mkLambdaFVars xs (← mkEqTrans step root.proof))

/-- The source environment of the flattening of Lean's argument tuple `x` of `r`. -/
def Reflected.envOf (r : Reflected) (x : Lean.Expr) : Lean.Expr :=
  mkAppN (mkConst ``Env.ofArgs)
    #[ctxExpr r.params, modesExpr r.modes, (mkApp r.flatArgs x).headBeta]

/-- The tuple of the parameters `params` of `r`, with each owned array as `Moved`. -/
def Reflected.tupleOf (r : Reflected) (params : Array Lean.Expr) : MetaM Lean.Expr :=
  argsTuple (params.toList.zip ((paramModes r.params r.modes).map (· == .owned)))

/-- The equation of a function's bound by the lemma `thm`, which states it from its body's: the
body's bound at the entry modes with nothing live after it, from the reflection `body` of the body
of definition `r` at the parameters `params` and their environment `env`, with the body's equation
`denoteEq`, and the copy of a borrowed result.  The lemma's arguments `args` name the function and
the bounds of its callees, and `base` is the program's name.  For a recursive definition, `self?`
is the table of flags with the definition's own entry, which the lemma's `fl` takes. -/
def bodyBoundEq (thm : Name) (args : List (Name × Lean.Expr)) (r : Reflected)
    (params : Array Lean.Expr) (env : Lean.Expr) (resultShape : Shape) (base denoteEq : Name)
    (body : Reflection) (self? : Option Lean.Expr := none) : MetaM Bound := do
  let some entry ← modesOf (← mkAppM ``entryModes #[ctxExpr r.params, modesExpr r.modes])
    | throwError "verified_compile: cannot evaluate the entry modes of {r.name}"
  let ms := modesExpr entry
  let app ← LemmaApp.start thm (args ++ [(`args, env), (`ms, ms)])
  let some (_, entryModes, _) := (← app.hypType `hms).eq?
    | throwError "verified_compile: the entry modes of {r.name}"
  app.assign `hms (← evalEq entryModes ms)
  -- The parameters' flags, which the kernel evaluates.
  let some (_, pfTerm, _) := (← app.hypType `hpf).eq?
    | throwError "verified_compile: the parameter flags of {r.name}"
  let pf := toExpr (← evalBoolList m!"the parameter flags of {r.name}" pfTerm)
  app.assign `pf pf
  app.assign `hpf (← evalEq pfTerm pf)
  if app.names.contains `hfl then
    let some (_, flTerm, _) := (← app.hypType `hfl).eq?
      | throwError "verified_compile: the flags of {r.name}"
    let some fl := self?
      | throwError "verified_compile: the flags of {r.name} are missing"
    app.assign `fl fl
    app.assign `hfl (← mkExpectedTypeHint (← mkEqRefl fl) (← mkEq flTerm fl))
  let call := mkAppN (mkConst r.name) params
  app.assign `V (resultShape.apply call)
  app.assign `hv (← mkExpectedTypeHint (mkAppN (mkConst denoteEq) params) (← app.hypType `hv))
  let (bodyModes, paid, live) ← app.allocsArgs `hba
  let b ← body.bound bodyModes paid live
  app.assign `BA b.term
  app.assign `hba (← mkExpectedTypeHint b.proof (← app.hypType `hba))
  -- The copy of a borrowed result, stated with the result's type and body as the terms of the
  -- function, which the kernel unfolds.
  let some (_, coerce, _) := (← app.hypType `hk).eq?
    | throwError "verified_compile: the result of {r.name}"
  let (``coerceCost, #[_, s, M, v]) := coerce.getAppFnArgs
    | throwError "verified_compile: the result of {r.name}"
  let (K, hk) ← coerceEq base r.result s M v call
  app.assign `KA K
  app.assign `hk (← mkExpectedTypeHint hk (← app.hypType `hk))
  boundOf (← app.finish)

/-- The equation of a function's frames condition by the lemma `thm`, which states it from its
body's, from the reflection `body` of the body. -/
def bodyFitsEq (thm : Name) (args : List (Name × Lean.Expr)) (env : Lean.Expr)
    (body : Reflection) : MetaM Bound := do
  let app ← LemmaApp.start thm (args ++ [(`args, env)])
  let b ← body.fits
  app.assign `B b.term
  app.assign `h (← mkExpectedTypeHint b.proof (← app.hypType `h))
  return ⟨b.term, ← app.finish⟩

/-- For definition `r`, whose code takes the call depth, adds `base.cost` and `base.fits`, its
table's entry and frames condition with `k` frames on Lean's argument tuple, from its entries `B k`
and `Fi k` of the tables, and their equations `base.cost_eq` and `base.fits_eq` at `k + 1` frames,
for `k` the local variable `k`, by the lemmas `boundThm` and `fitsThm` with the arguments `args`,
and the callees' tables `rest` and `restFits`.  The name `cost` is `bound` for a function without
paid parameters, and `self?` is as `bodyBoundEq` takes it.  The lemmas take the function's value,
a `Func.mk` or a `RecFunc.mk`, whose projections reduce without unfolding it. -/
def addDepthBound (base : Name) (r : Reflected) (B Fi k : Lean.Expr) (params : Array Lean.Expr)
    (env : Lean.Expr) (resultShape : Shape) (body : Reflection) (boundThm fitsThm : Name)
    (args : List (Name × Lean.Expr)) (rest restFits : Lean.Expr) (cost : Name := `bound)
    (self? : Option Lean.Expr := none) : MetaM Unit := do
  let nat := Lean.mkConst ``Nat
  for (name, entry, ty) in [(cost, B, nat), (`fits, Fi, mkConst ``Bool)] do
    let value ← withLocalDeclD `k nat fun k => withLocalDeclD `x r.argsType fun x => do
      mkLambdaFVars #[k, x] (mkApp2 entry k (r.envOf x))
    addBoundDefinition (base ++ name) (← mkArrow nat (← mkArrow r.argsType ty)) value
  let tuple ← r.tupleOf params
  -- The definition at `k + 1`, the fuel of the lemma's statement, which `boundAt` and `fitsAt`
  -- take before the environment, and the tuple.
  let equation (name eq : Name) (root : Bound) : MetaM Unit := do
    let (own, _) ← eqSides root.proof
    let args := own.getAppArgs
    addEquation base.getPrefix (base ++ eq) (#[k] ++ params)
      (mkApp2 (mkConst (base ++ name)) args[args.size - 2]! tuple) root
  equation cost (Name.mkSimple (cost.toString ++ "_eq"))
    (← bodyBoundEq boundThm (args ++ [(`rest, rest)]) r params env resultShape base.getPrefix
      (base ++ `denote_eq) body self?)
  equation `fits `fits_eq (← bodyFitsEq fitsThm (args ++ [(`rest, restFits)]) env body)

/-- The proof of `Env.credit sel env = C` for the environment `env` of a definition's parameters,
the Lean terms and types `vars`: the credit of each parameter that the kernel evaluates `sel` to
pick. -/
partial def envCreditEq (base : Name) (sel env : Lean.Expr) :
    List (Lean.Expr × Ty) → MetaM Bound
  | [] => do return ⟨natZero, ← (← LemmaApp.start ``envCredit_nil [(`sel, sel)]).finish⟩
  | (u, t) :: rest => do
    let (``Env.cons, #[_, _, v, envRest]) := env.getAppFnArgs
      | throwError "verified_compile: the parameters' environment {env}"
    let parts := [(`sel, sel), (`t, tyExpr t), (`v, v), (`rest, envRest)]
    let probe ← LemmaApp.start ``envCredit_none parts
    let some (_, cond, _) := (← probe.hypType `hs).eq?
      | throwError "verified_compile: the argument hs of envCredit_none"
    let picked ← evalBool m!"whether the parameter {u} is paid" cond
    let app ← if picked then do
        let app ← LemmaApp.start ``envCredit_some parts
        app.assign `hs (← evalEq cond (boolConst true))
        let (E, he) ← ValueCost.credit.eq base t v u
        app.assign `E E
        app.assign `he he
        pure app
      else do
        probe.assign `hs (← evalEq cond (boolConst false))
        pure probe
    let some (_, lhs, _) := (← app.hypType `hr).eq?
      | throwError "verified_compile: the argument hr of the parameters' credits"
    let r ← envCreditEq base lhs.getAppArgs[0]! envRest rest
    app.assign `hr r.proof
    boundOf (← app.finish)

/-- For definition `r`, which has a paid parameter, adds `base.bound`, the credits of its paid owned
parameters plus `base.cost`, on Lean's argument tuple, with the number of frames first when its
code takes the call depth, and its equation `base.bound_eq`.  The parameters' signature is `g`,
their flags `pf`, their Lean terms and types `vars`, and their environment `env`. -/
def addCreditBound (base : Name) (r : Reflected) (g : Lean.Expr) (pf : List Bool) (depth : Bool)
    (params : Array Lean.Expr) (env k : Lean.Expr) (vars : List (Lean.Expr × Ty)) :
    MetaM Unit := do
  let sel := mkApp2 (mkConst ``Sig.paidSel) g (toExpr pf)
  let nat := Lean.mkConst ``Nat
  let credit (e : Lean.Expr) := mkAppN (mkConst ``Env.credit) #[sel, ctxExpr r.params, e]
  let cost := Lean.mkConst (base ++ `cost)
  let value ← withLocalDeclD `k nat fun kv => withLocalDeclD `x r.argsType fun x => do
    let c := if depth then mkApp2 cost kv x else mkApp cost x
    let body := mkApp2 natAdd (credit (r.envOf x)) c
    if depth then mkLambdaFVars #[kv, x] body else mkLambdaFVars #[x] body
  let type ← if depth then mkArrow nat (← mkArrow r.argsType nat) else mkArrow r.argsType nat
  addBoundDefinition (base ++ `bound) type value
  let tuple ← r.tupleOf params
  let c := if depth then mkApp2 cost k tuple else mkApp cost tuple
  let ce ← envCreditEq base.getPrefix sel env vars
  let (CR, hn?) ← normCost ce.term
  let hc ← match hn? with
    | some h => mkEqTrans ce.proof h
    | none => pure ce.proof
  let proof ← congr2 natAdd (credit env) CR c c (some hc) none
  let lhs := if depth then mkApp2 (mkConst (base ++ `bound)) k tuple
    else mkApp (mkConst (base ++ `bound)) tuple
  addEquation base.getPrefix (base ++ `bound_eq) (if depth then #[k] ++ params else params) lhs
    ⟨mkApp2 natAdd CR c, proof⟩

/-- Reflects definition `name` as a function that may call the functions `sigs`, meaning
`funs`, of the program `prog`, with the parameter modes that `Expr.paramChoice` gives, and adds
`base.func`, `base.denote_eq`, and `base.bound`, the function's allocation bound on Lean's tuple of
its arguments, with `base.bound_eq`, which states the bound as a Lean term in the parameters.  For
a function with a paid parameter, `base.cost` is the table's entry with `base.cost_eq`, and
`base.bound` is the credits of the paid arguments plus `base.cost`.  When its code takes the call
depth, the bound takes the frames available, and `base.fits` and `base.fits_eq` state whether its
calls find their frames. -/
def reflectDefinition (base name : Name) (sigs funs prog : Lean.Expr) (callees : List Callee) :
    MetaM Reflected := do
  let info ← getConstInfoDefn name
  unless info.levelParams.isEmpty do
    throwError "verified_compile: {name} has universe parameters"
  lambdaTelescope (← instantiateMVars info.value) fun params body =>
      withLocalDeclD `k (mkConst ``Nat) fun k => do
    let types ← params.toList.mapM fun p => do tyOf (← inferType p)
    let resultShape ← shapeOf (← inferType body)
    let result := resultShape.ty
    let vars := params.toList.zip types
    let (ctx, env) ← ctxEnvExpr vars
    -- The tables at `k` frames.  A function whose code takes no call depth has the same bound at
    -- every `k`, and its equation is stated at 0.
    let tables : Tables := { sigs, prog, funs, fuel := k }
    let c : Ctx :=
      { base := base.getPrefix, sigs := sigs, funs := funs, callees := callees, vars := vars,
        env := env, ctx := ctx, tables }
    let r ← reflect.reflectSplit c params.toList body
    let modes ← paramChoiceOf name r.src
    let funcType := mkApp (mkConst ``Func) sigs
    let func ← mkAppOptM ``Func.mk #[some sigs, some (toExpr name.getString!),
      some (ctxExpr types), some (tyExpr result), some r.src, some (← mkEqRefl (toExpr true)),
      some (modesExpr modes)]
    addDefinition (base ++ `func) funcType func
    let f := Lean.mkConst (base ++ `func)
    let lhs ← mkAppM ``Func.denote #[f, funs, env]
    let eqType ← mkForallFVars params
      (← mkEq lhs (resultShape.apply (mkAppN (mkConst name) params)))
    -- `name = fun params => body` by `rfl`: against a lambda the kernel can only unfold `name`.
    -- Applied to the parameters, it relates the body to `name params` by beta reduction, so the
    -- kernel never compares `name params` with a body headed by a matcher, which it would unfold
    -- first, evaluating the matcher's discriminant.
    let value ← instantiateMVars info.value
    let hdef ← mkExpectedTypeHint (← mkEqRefl (mkConst name)) (← mkEq (mkConst name) value)
    let happ ← params.foldlM (fun h p => mkCongrFun h p) hdef
    let full ← restate r.proof (← mkEqSymm happ)
    addTheorem (base ++ `denote_eq) eqType (← mkLambdaFVars params full)
    let aborts ← evalBool m!"whether {name} may trap" (← mkAppM ``Func.aborts #[f])
    let depth ← evalBool m!"whether the code of {name} takes the call depth"
      (← mkAppM ``Func.depth #[f])
    let reflected ← finishReflected base name params types result (← inferType body) aborts
      modes depth (base ++ `denote_eq)
    -- The parameters' flags, from the flags of the functions before it.  A function with a paid
    -- parameter has its table's entry as `base.cost` and the credits plus it as `base.bound`.
    let flags := mkApp2 (mkConst ``Prog.flags) sigs prog
    let pf ← evalBoolList m!"the parameter flags of {name}"
      (mkAppN (mkConst ``Func.paidParams) #[sigs, f, flags])
    let paid := pf.any id
    let cost : Name := if paid then `cost else `bound
    let costName := base ++ cost
    let credited? := if paid then some (base ++ `bound) else none
    let g := mkApp2 (mkConst ``Func.sig) sigs f
    if depth then
      let rest := mkAppN (mkConst ``Prog.boundsAt) #[sigs, prog, funs]
      let restFits := mkAppN (mkConst ``Prog.fitsAt) #[sigs, prog, funs]
      addDepthBound base reflected (mkAppN (mkConst ``Func.boundAt) #[sigs, f, funs, flags, rest])
        (mkAppN (mkConst ``Func.fitsAt) #[sigs, f, funs, restFits]) k params env resultShape r
        ``funcAt_bound ``funcAt_fits [(`func, func), (`funs, funs), (`flags, flags), (`k, k)] rest
        restFits cost
      if paid then addCreditBound base reflected g pf true params env k vars
      return { reflected with
        bound? := some { bound := costName, fits? := some (base ++ `fits), credited? }, paid }
    -- The bound: the compiler's bound of the function, among the functions before it, at the
    -- flattening of Lean's tuple of the arguments.
    let bounds := mkAppN (mkConst ``Prog.boundsAt) #[sigs, prog, funs, mkNatLit 0]
    let boundVal ← withLocalDeclD `x reflected.argsType fun x => do
      mkLambdaFVars #[x]
        (mkAppN (mkConst ``Func.bound) #[sigs, f, funs, flags, bounds, reflected.envOf x])
    addBoundDefinition costName (← mkArrow reflected.argsType (mkConst ``Nat)) boundVal
    let root ← bodyBoundEq ``func_bound
      [(`func, func), (`funs, funs), (`flags, flags), (`bounds, tables.table false)] reflected
      params env resultShape base.getPrefix (base ++ `denote_eq) r
    let root : Bound :=
      ⟨root.term.replaceFVar k (mkNatLit 0), root.proof.replaceFVar k (mkNatLit 0)⟩
    let costEq := base ++ Name.mkSimple (cost.toString ++ "_eq")
    addEquation base.getPrefix costEq params (mkApp (mkConst costName) (← reflected.tupleOf params))
      root
    if paid then addCreditBound base reflected g pf false params env k vars
    let numeralEq := if (natOf root.term).isSome then some costEq else none
    return { reflected with bound? := some { bound := costName, numeralEq, credited? }, paid }

/-- The inverse `u` of the flattening `φ` of a Lean type, which the meaning of a recursive
definition applies to the values of its parameters, with the proofs of the two inverse laws at
given terms: `left a : u (φ a) = a` and `right v : φ (u v) = v`. -/
structure Inverse where
  u : Lean.Expr
  left : Lean.Expr → MetaM Lean.Expr
  right : Lean.Expr → MetaM Lean.Expr

/-- The proof of `x = y` by `rfl`, for terms that the kernel identifies by unfolding a flattening
and its inverse, by projections of constructors, and by structure eta, none of which evaluates a
definition. -/
def rflEq (x y : Lean.Expr) : MetaM Lean.Expr := do
  mkExpectedTypeHint (← mkEqRefl y) (← mkEq x y)

/-- A structure in a value of type `type`, through pairs and nested structures, whose `Flat`
tuple leaves out one of its fields, with the name of that field. -/
partial def flatOmission? (type : Lean.Expr) : MetaM (Option (Lean.Expr × Name)) := do
  let type ← withReducible (whnf type)
  if (fieldElem? type).isSome then return none
  if let (``Prod, #[a, b]) := type.getAppFnArgs then
    if let some found ← flatOmission? a then return some found
    return ← flatOmission? b
  let some (ctor, names) ← structOf? type | return none
  let some (β, inst) ← flatInstance? type | return none
  let tree ← flatTree "verified_compile" type β inst ctor
  let fieldTypes ← forallTelescope ctor.type fun xs _ => xs.toList.mapM inferType
  for (fieldType, j) in fieldTypes.zipIdx do
    if (tree.find? (·.1 == j)).isNone then return some (type, names[j]!)
    if let some found ← flatOmission? fieldType then return some found
  return none

/-- The inverse of the flattening of a Lean type, `none` for a type that flattening leaves as it
is.  A pair maps its components, an array maps its elements, and a structure whose `Flat` instance
is a tuple of all its fields builds the structure from the tuple's components.  The laws hold by
`rfl`, except for an array, whose laws follow from its elements' by `map_inverse`.  An
enumeration has no inverse on the words that encode no constructor, and the reflector rejects it.
-/
partial def inverseOf? (type : Lean.Expr) : MetaM (Option Inverse) := do
  let sh ← shapeOf type
  let some φ := sh.flat | return none
  let type ← whnfR type
  let src := mkApp (mkConst ``Ty.denote) (tyExpr sh.ty)
  let inverse (u : Lean.Expr) (left right : Lean.Expr → MetaM Lean.Expr) : Inverse :=
    ⟨u, left, right⟩
  if let (``List, #[el]) := type.getAppFnArgs then
    if (← whnfR el).isConstOf ``UInt64 then
      return some (inverse (mkConst ``Tree.toList)
        (fun x => mkAppM ``Tree.toList_ofList #[x])
        (fun v => mkAppM ``Tree.ofList_toList #[v]))
  if let some layout ← recursiveLayout? type then
    unless (← getEnv).contains (layout.decl `fromTree) do
      for (_, fields) in layout.ctors do
        for field in fields do
          let .flat fieldType _ := field | continue
          if let some (holder, name) ← flatOmission? fieldType then
            throwError "verified_compile: the parameter type {type} of a recursive definition has \
              a field that holds the structure {holder}, whose `Flat` tuple leaves out its \
              field {name}"
      throwError "verified_compile: the parameter type {type} of a recursive definition holds an \
        enumeration or a sum, whose flattening has no inverse on the values that encode no \
        constructor"
    return some (inverse (mkConst (layout.decl `fromTree))
      (fun x => pure (mkApp (mkConst (layout.decl `from_to)) x))
      (fun v => pure (mkApp (mkConst (layout.decl `to_from)) v)))
  if let (``Prod, #[a, b]) := type.getAppFnArgs then
    let ia ← inverseOf? a
    let ib ← inverseOf? b
    let part (i : Option Inverse) (x : Lean.Expr) : Lean.Expr := match i with
      | some i => i.u.beta #[x]
      | none => x
    let u ← withLocalDeclD `v src fun v => do
      mkLambdaFVars #[v] (← mkAppOptM ``Prod.mk #[some a, some b,
        some (part ia (← mkAppM ``Prod.fst #[v])), some (part ib (← mkAppM ``Prod.snd #[v]))])
    let lawOf (i : Option Inverse) (f : Inverse → Lean.Expr → MetaM Lean.Expr) (x : Lean.Expr) :
        MetaM Lean.Expr := match i with
      | some i => f i x
      | none => mkEqRefl x
    let left (x : Lean.Expr) : MetaM Lean.Expr := do
      let h1 ← lawOf ia Inverse.left (← mkAppM ``Prod.fst #[x])
      let h2 ← lawOf ib Inverse.left (← mkAppM ``Prod.snd #[x])
      let h ← mkCongr (← mkCongrArg (mkApp2 (mkConst ``Prod.mk [Level.zero, Level.zero]) a b) h1)
        h2
      mkExpectedTypeHint h (← mkEq (u.beta #[φ.beta #[x]]) x)
    let right (v : Lean.Expr) : MetaM Lean.Expr := do
      let h1 ← lawOf ia Inverse.right (← mkAppM ``Prod.fst #[v])
      let h2 ← lawOf ib Inverse.right (← mkAppM ``Prod.snd #[v])
      let (α', β') ← match (← whnf (← inferType v)).getAppFnArgs with
        | (``Prod, #[α', β']) => pure (α', β')
        | _ => throwError "verified_compile: the flattening of {type} is not a pair"
      let h ← mkCongr
        (← mkCongrArg (mkApp2 (mkConst ``Prod.mk [Level.zero, Level.zero]) α' β') h1) h2
      mkExpectedTypeHint h (← mkEq (φ.beta #[u.beta #[v]]) v)
    return some (inverse u left right)
  if let (``Array, #[el]) := type.getAppFnArgs then
    let some ie ← inverseOf? el | return none
    let se ← shapeOf el
    let φe ← se.fn el
    let srcEl := mkApp (mkConst ``Ty.denote) (tyExpr se.ty)
    let u ← withLocalDeclD `v src fun v => do
      mkLambdaFVars #[v] (← mkAppOptM ``Array.map #[some srcEl, some el, some ie.u, some v])
    let left (x : Lean.Expr) : MetaM Lean.Expr := do
      let h ← withLocalDeclD `y el fun y => do mkLambdaFVars #[y] (← ie.left y)
      let p ← mkAppM ``map_inverse #[φe, ie.u, h, x]
      mkExpectedTypeHint p (← mkEq (u.beta #[φ.beta #[x]]) x)
    let right (v : Lean.Expr) : MetaM Lean.Expr := do
      let h ← withLocalDeclD `w srcEl fun w => do mkLambdaFVars #[w] (← ie.right w)
      let p ← mkAppM ``map_inverse #[ie.u, φe, h, v]
      mkExpectedTypeHint p (← mkEq (φ.beta #[u.beta #[v]]) v)
    return some (inverse u left right)
  let some (ctor, _) ← structOf? type
    | throwError "verified_compile: the parameter type {type} of a recursive definition holds an \
        enumeration or a sum, whose flattening has no inverse on the values that encode no \
        constructor"
  let some (β, inst) ← flatInstance? type
    | throwError "verified_compile: the structure {type} has no `Flat` instance"
  let tree ← flatTree "verified_compile" type β inst ctor
  unless tree.length == ctor.numFields do
    throwError "verified_compile: the `Flat` instance of {type} does not hold all its fields"
  let iβ ← inverseOf? β
  -- The structure built from a tuple `w` of its fields.
  let ctorOf (w : Lean.Expr) : MetaM Lean.Expr := do
    let fields ← (List.range ctor.numFields).mapM fun i => do
      let some (_, steps) := tree.find? (·.1 == i)
        | throwError "verified_compile: field {i} of {type} is missing from its `Flat` instance"
      tuplePath w steps
    return mkAppN (mkConst ctor.name type.getAppFn.constLevels!) (type.getAppArgs ++ fields.toArray)
  let u ← withLocalDeclD `v src fun v => do
    mkLambdaFVars #[v] (← ctorOf (match iβ with
      | some i => i.u.beta #[v]
      | none => v))
  let some i := iβ
    | return some (inverse u (fun x => rflEq (u.beta #[φ.beta #[x]]) x)
        (fun v => rflEq (φ.beta #[u.beta #[v]]) v))
  -- The tuple's laws, under the structure's constructor; the rest is structure eta and the
  -- unfolding of `Flat.flat`.
  let left (x : Lean.Expr) : MetaM Lean.Expr := do
    let fx := mkApp4 (mkConst ``LeanExe.Pipeline.Flat.flat) type β inst x
    let ctorFn ← withLocalDeclD `t β fun t => do mkLambdaFVars #[t] (← ctorOf t)
    let h ← transHint (← mkCongrArg ctorFn (← i.left fx)) (← rflEq (← ctorOf fx) x)
    mkExpectedTypeHint h (← mkEq (u.beta #[φ.beta #[x]]) x)
  let right (v : Lean.Expr) : MetaM Lean.Expr := do
    mkExpectedTypeHint (← i.right v) (← mkEq (φ.beta #[u.beta #[v]]) v)
  return some (inverse u left right)

/-- The proof of `∀ env, P env` for environments of the context `ts`, from the proof that `k`
gives of `P (Env.cons v₀ (… Env.nil))` for variables `v₀ …` of the context's types. -/
partial def splitEnv (ts : List Ty) (P : Lean.Expr) (k : List Lean.Expr → MetaM Lean.Expr) :
    MetaM Lean.Expr := do
  match ts with
  | [] => return mkApp2 (mkConst ``env_forall_nil) P (← k [])
  | t :: rest =>
    let h ← withLocalDeclD `v (mkApp (mkConst ``Ty.denote) (tyExpr t)) fun v => do
      let P' ← withLocalDeclD `e (mkApp (mkConst ``Env) (ctxExpr rest)) fun e => do
        let cons ← mkAppOptM ``Env.cons #[some (ctxExpr rest), some (tyExpr t), some v, some e]
        mkLambdaFVars #[e] (mkApp P cons).headBeta
      mkLambdaFVars #[v] (← splitEnv rest P' fun vs => k (v :: vs))
    return mkAppN (mkConst ``env_forall_cons) #[tyExpr t, ctxExpr rest, P, h]

/-- `Env.cons v₀ (… Env.nil)` for values `vs` of the context `ts`. -/
def envOfValues : List Ty → List Lean.Expr → MetaM Lean.Expr
  | t :: ts, v :: vs => do
    mkAppOptM ``Env.cons #[some (ctxExpr ts), some (tyExpr t), some v, some (← envOfValues ts vs)]
  | _, _ => return mkConst ``Env.nil

structure RecursiveInput where
  params : Array Lean.Expr
  types : List Ty
  rhs : Lean.Expr
  resultType : Lean.Expr
  resultShape : Shape
  vars : List (Lean.Expr × Ty)
  ctx : Lean.Expr
  env : Lean.Expr
  invs : List (Option Inverse)
  meaning : Lean.Expr
  argsAt : Lean.Expr → MetaM (List Lean.Expr)
  meaningAt : Lean.Expr → MetaM Lean.Expr

def withRecursiveInput {α : Type} (base name eqName : Name)
    (go : RecursiveInput → TermElabM α) : TermElabM α := do
  let info ← getConstInfoDefn name
  unless info.levelParams.isEmpty do
    throwError "verified_compile: {name} has universe parameters"
  if (← collectAxioms name).contains ``sorryAx then
    throwError "verified_compile: the definition of {name} uses `sorry`"
  forallTelescope (← inferType (mkConst eqName)) fun params eqn => do
    let some (_, _, rhs) := eqn.eq?
      | throwError "verified_compile: the unfolding equation of {name} is {eqn}"
    let types ← params.toList.mapM fun p => do tyOf (← inferType p)
    let resultType ← inferType rhs
    let resultShape ← shapeOf resultType
    let result := resultShape.ty
    let vars := params.toList.zip types
    let (ctx, env) ← ctxEnvExpr vars
    let invs ← params.toList.mapM fun p => do inverseOf? (← inferType p)
    -- The arguments at an environment `e`: the inverses of its values.
    let getAt (e : Lean.Expr) (i : Nat) : MetaM Lean.Expr := do
      let t := types[i]!
      let x ← mkAppOptM ``Var.ofIndex #[some (tyExpr t), some ctx, some (toExpr i),
        some (← mkEqRefl (mkApp (mkApp (mkConst ``Option.some [Level.zero]) (mkConst ``Ty))
          (tyExpr t)))]
      mkAppOptM ``Env.get #[some ctx, some (tyExpr t), some e, some x]
    let argsAt (e : Lean.Expr) : MetaM (List Lean.Expr) :=
      (List.range types.length).mapM fun i => do
        let g ← getAt e i
        return match invs[i]! with
          | some inv => inv.u.beta #[g]
          | none => g
    let meaningAt (e : Lean.Expr) : MetaM Lean.Expr := do
      return resultShape.apply (mkAppN (mkConst name) (← argsAt e).toArray)
    let envType := mkApp (mkConst ``Env) ctx
    let mValue ← withLocalDeclD `env envType fun e => do mkLambdaFVars #[e] (← meaningAt e)
    addDefinition (base ++ `meaning) (← mkArrow envType (mkApp (mkConst ``Ty.denote)
      (tyExpr result))) mValue
    let M := Lean.mkConst (base ++ `meaning)
    -- `M` at the flattenings of `params`: by unfolding `M`, then by the left inverse law at each
    -- argument, under the definition.
    let mid ← meaningAt env
    let step1 ← rflEq (mkApp M env) mid
    let argsEnv ← argsAt env
    let mut nameEq ← mkEqRefl (mkConst name)
    for i in [0:types.length] do
      let p := params[i]!
      let h ← match invs[i]! with
        | some inv => do mkExpectedTypeHint (← inv.left p) (← mkEq argsEnv[i]! p)
        | none => rflEq argsEnv[i]! p
      nameEq ← mkCongr nameEq h
    let step2 ← match resultShape.flat with
      | none => pure nameEq
      | some _ => mkCongrArg (← resultShape.fn resultType) nameEq
    let selfEq ← transHint step1 step2
    addTheorem (base ++ `meaning_eq)
      (← mkForallFVars params (← mkEq (mkApp M env)
        (resultShape.apply (mkAppN (mkConst name) params))))
      (← mkLambdaFVars params selfEq)
    go ⟨params, types, rhs, resultType, resultShape, vars, ctx, env, invs, M, argsAt, meaningAt⟩

/-- Reflects the recursive definition `name`, whose unfolding equation is `eqName`, as a
recursive function that may call itself and the functions `sigs`, meaning `funs`, after the
program `rest` with the proof `hRest` that `funs` are its meanings.  It adds `base.meaning`, the
function of an environment that the definition means; `base.meaning_eq`, its value at the
flattenings of arguments; `base.func`; `base.denote_eq`, the body's value; and `base.fixed`, the
equation that makes `base.meaning` the function's meaning in `Prog.Meaning`.  The equations never
make the kernel compare the definition at two different arguments, since its value is a
`WellFounded.fix`.  The parameter modes are the choice of `Expr.paramChoice` for the body
reflected with the modes before, from all borrowed, until the choice repeats or every parameter
has had a round. -/
def reflectRecursive (base name eqName : Name) (sigs funs rest hRest : Lean.Expr)
    (callees : List Callee) : TermElabM Reflected := do
  withRecursiveInput base name eqName fun input =>
      withLocalDeclD `k (mkConst ``Nat) fun k => do
    let ⟨params, types, _, resultType, resultShape, vars, ctx, env, invs, M, argsAt, meaningAt⟩ := input
    let rhs := input.rhs
    let result := resultShape.ty
    -- The body, reflected with a callee for the definition itself as function 0, and with the
    -- definition's own bound and frames condition at `k` frames first in the tables.  They name
    -- `base.func`, which the reflector adds before it builds them.
    let selfSig (modes : List Mode) : Sig := ⟨types, result, true, modes, true⟩
    let fConst := Lean.mkConst (base ++ `func)
    let funsP := mkAppN (mkConst ``Funs.cons)
      #[sigs, mkApp2 (mkConst ``RecFunc.sig) sigs fConst, M, funs]
    let restB := mkAppN (mkConst ``Prog.boundsAt) #[sigs, rest, funs]
    let restF := mkAppN (mkConst ``Prog.fitsAt) #[sigs, rest, funs]
    let restFlags := mkApp2 (mkConst ``Prog.flags) sigs rest
    let selfB := mkAppN (mkConst ``RecFunc.boundAt) #[sigs, fConst, funsP, restFlags, restB]
    let selfF := mkAppN (mkConst ``RecFunc.fitsAt) #[sigs, fConst, funsP, restF]
    -- The flags of the definition and of the functions before it, with the definition's own
    -- entry as its parameters' flags `pf` and its result's `rf`.
    let flagsWith (modes : List Mode) (pf : List Bool) (rf : Bool) : Lean.Expr :=
      mkAppN (mkConst ``Flags.cons) #[sigs, sigExpr (selfSig modes), toExpr pf, toExpr rf, restFlags]
    let reflectWith (modes : List Mode) (pf : List Bool) (rf : Bool) : MetaM Reflection := do
      let g := sigExpr (selfSig modes)
      let sigs' := mkApp3 (mkConst ``List.cons [Level.zero]) (mkConst ``Sig) g sigs
      let funs' := mkAppN (mkConst ``Funs.cons) #[sigs, g, M, funs]
      let cost : Name := if pf.any id then `cost else `bound
      let callee : Callee :=
        { name := name, sig := selfSig modes, denoteEq := base ++ `meaning_eq,
          bound := { bound := base ++ cost, fits? := some (base ++ `fits) } }
      let tables : Tables :=
        { sigs, prog := rest, funs, fuel := k, self := some (g, mkApp selfB k, mkApp selfF k),
          selfFlags := some (flagsWith modes pf rf) }
      let ctx : Ctx :=
        { base := base.getPrefix, sigs := sigs', funs := funs', callees := callee :: callees,
          vars := vars, env := env, ctx := ctx, tables }
      reflect.reflectSplit ctx params.toList rhs
    -- The flags that the body gives: a parameter is paid when the body extends an array, with
    -- the definition's calls of itself counted as extending nothing, and the result when the
    -- body's value is paid with the calls of itself paid.
    let flagsOf (modes : List Mode) (src : Lean.Expr) : MetaM (List Bool × Bool) := do
      let g := sigExpr (selfSig modes)
      let sigs' := mkApp3 (mkConst ``List.cons [Level.zero]) (mkConst ``Sig) g sigs
      let off := mkAppN (mkConst ``Flags.cons) #[sigs, g, toExpr ([] : List Bool),
        toExpr false, restFlags]
      let grows ← evalBool m!"whether the body of {name} extends an array"
        (mkAppN (mkConst ``Expr.grows) #[sigs', off, ctx, tyExpr result, src])
      let pf := (paramModes types modes).map fun m => m == .owned && grows
      if result.scalar then return (pf, false)
      let live := Lean.mkLambda `i .default (mkConst ``Nat) (mkConst ``Bool.false)
      let paidV ← evalBool m!"whether the body of {name} is paid"
        (mkAppN (mkConst ``Expr.paid) #[sigs', flagsWith modes pf true,
          modesExpr (paramModes types modes), toExpr pf, live, ctx, tyExpr result, src])
      return (pf, paidV)
    let mut modes : List Mode := types.map fun _ => .borrowed
    let mut pf : List Bool := types.map fun _ => false
    let mut rf : Bool := false
    let mut r ← reflectWith modes pf rf
    for _ in [0:types.length] do
      let choice ← paramChoiceOf name r.src
      if choice == modes then break
      modes := choice
      r ← reflectWith modes pf rf
    let (pf', rf') ← flagsOf modes r.src
    if pf' != pf || rf' != rf then
      pf := pf'
      rf := rf'
      r ← reflectWith modes pf rf
    let src := r.src
    let proof := r.proof
    let g := sigExpr (selfSig modes)
    let sigs' := mkApp3 (mkConst ``List.cons [Level.zero]) (mkConst ``Sig) g sigs
    let funs' := mkAppN (mkConst ``Funs.cons) #[sigs, g, M, funs]
    let func ← mkAppOptM ``RecFunc.mk #[some sigs, some (toExpr name.getString!), some ctx,
      some (tyExpr result), some (modesExpr modes), some src, some (← mkEqRefl (toExpr true))]
    addDefinition (base ++ `func) (mkApp (mkConst ``RecFunc) sigs) func
    let f := Lean.mkConst (base ++ `func)
    let body := mkApp2 (mkConst ``RecFunc.body) sigs f
    let denote (e : Lean.Expr) : Lean.Expr :=
      mkAppN (mkConst ``Expr.denote) #[sigs', funs', ctx, tyExpr result, body, e]
    let full ← restate proof (← mkEqSymm (mkAppN (mkConst eqName) params))
    addTheorem (base ++ `denote_eq)
      (← mkForallFVars params (← mkEq (denote env)
        (resultShape.apply (mkAppN (mkConst name) params))))
      (← mkLambdaFVars params full)
    -- The fixed-point equation at each environment `E`: `M E` unfolds to the definition at the
    -- inverses of `E`'s values, which is the body's value at their flattenings, which are `E`'s
    -- values by the right inverse law.
    let consRecApp := mkAppN (mkConst ``Prog.Meaning.consRec) #[sigs, f, rest, funs, M, hRest]
    let .forallE _ fixedType _ _ ← whnf (← inferType consRecApp)
      | throwError "verified_compile: the type of Prog.Meaning.consRec"
    let .forallE n envTy P0 bi := fixedType
      | throwError "verified_compile: the fixed-point equation {fixedType}"
    let P := Lean.mkLambda n bi envTy P0
    let fixed ← splitEnv types P fun vs => do
      let E ← envOfValues types vs
      let as ← argsAt E
      let step1 ← rflEq (mkApp M E) (← meaningAt E)
      let bodyEq := mkAppN (mkConst (base ++ `denote_eq)) as.toArray
      -- The flattenings of the arguments are the values `vs`.
      let mut envEq ← mkEqRefl (mkConst ``Env.nil)
      let mut flatTail := Lean.mkConst ``Env.nil
      for i in (List.range types.length).reverse do
        let t := types[i]!
        let rest := ctxExpr (types.drop (i + 1))
        let a := as[i]!
        let flat := (← shapeOf (← inferType params[i]!)).apply a
        let h ← match invs[i]! with
          | some inv => do mkExpectedTypeHint (← inv.right vs[i]!) (← mkEq flat vs[i]!)
          | none => rflEq flat vs[i]!
        let cons := mkApp2 (mkConst ``Env.cons) rest (tyExpr t)
        envEq ← mkCongr (← mkCongrArg cons h) envEq
        flatTail := mkApp2 cons flat flatTail
      let envEq' ← mkExpectedTypeHint envEq (← mkEq flatTail E)
      let denEq ← mkCongrArg (mkAppN (mkConst ``Expr.denote) #[sigs', funs', ctx, tyExpr result,
        body]) envEq'
      let h ← transHint (← transHint step1 (← mkEqSymm bodyEq)) denEq
      mkExpectedTypeHint h (mkApp P E).headBeta
    addTheorem (base ++ `fixed) fixedType fixed
    let reflected ← finishReflected base name params types result resultType true modes true
      (base ++ `meaning_eq)
    -- The lemmas take the function's value, whose projections reduce without unfolding it.
    let sigV := mkApp2 (mkConst ``RecFunc.sig) sigs func
    let funsV := mkAppN (mkConst ``Funs.cons) #[sigs, sigV, M, funs]
    let flagsV := mkAppN (mkConst ``Flags.cons) #[sigs, sigV, toExpr pf, toExpr rf, restFlags]
    let paid := pf.any id
    let cost : Name := if paid then `cost else `bound
    addDepthBound base reflected selfB selfF k params env resultShape r ``recFuncAt_bound
      ``recFuncAt_fits [(`func, func), (`funs, funsV), (`flags, restFlags), (`k, k)] restB restF
      cost (some flagsV)
    if paid then
      addCreditBound base reflected (mkApp2 (mkConst ``RecFunc.sig) sigs func) pf true params env k
        vars
    return { reflected with
      bound? := some { bound := base ++ cost, fits? := some (base ++ `fits),
                       credited? := if paid then some (base ++ `bound) else none }, paid }

/-- The values of the components of `x`, the tuple of a definition's arguments, as terms. -/
def argProjsE (x : Lean.Expr) : List Mode → Nat → MetaM (List Lean.Expr)
  | _, 0 => return []
  | ms, 1 => return [← argValE x (ms.headD .borrowed)]
  | ms, n + 2 => do
    return (← argValE (← mkAppM ``Prod.fst #[x]) (ms.headD .borrowed)) ::
      (← argProjsE (← mkAppM ``Prod.snd #[x]) ms.tail (n + 1))
where
  argValE (x : Lean.Expr) : Mode → MetaM Lean.Expr
    | .owned => mkAppM ``LeanExe.Pipeline.Moved.val #[x]
    | .borrowed => return x

end Verified.Reflect