import all

This PR changes the CI setup to generate `lean-pr-testing-NNNN` branches
for Mathlib on the `leanprover-community/mathlib4-nightly-testing` fork,
rather than on the main repo.

.github/workflows/ci.yml

@@ -421,6 +421,6 @@ jobs:
           GITHUB_TOKEN: ${{ secrets.RELEASE_INDEX_TOKEN }}
       - name: Update toolchain on mathlib4's nightly-testing branch
         run: |
-          gh workflow -R leanprover-community/mathlib4 run nightly_bump_toolchain.yml
+          gh workflow -R leanprover-community/mathlib4-nightly-testing run nightly_bump_toolchain.yml
         env:
           GITHUB_TOKEN: ${{ secrets.MATHLIB4_BOT }}

.github/workflows/pr-release.yml

@@ -167,7 +167,7 @@ jobs:
             echo "The merge base of this PR coincides with the nightly release"
 
             BATTERIES_REMOTE_TAGS="$(git ls-remote https://github.com/leanprover-community/batteries.git nightly-testing-"$MOST_RECENT_NIGHTLY")"
-            MATHLIB_REMOTE_TAGS="$(git ls-remote https://github.com/leanprover-community/mathlib4.git nightly-testing-"$MOST_RECENT_NIGHTLY")"
+            MATHLIB_REMOTE_TAGS="$(git ls-remote https://github.com/leanprover-community/mathlib4-nightly-testing.git nightly-testing-"$MOST_RECENT_NIGHTLY")"
 
             if [[ -n "$BATTERIES_REMOTE_TAGS" ]]; then
               echo "... and Batteries has a 'nightly-testing-$MOST_RECENT_NIGHTLY' tag."
@@ -355,7 +355,7 @@ jobs:
         if: steps.workflow-info.outputs.pullRequestNumber != '' && steps.ready.outputs.mathlib_ready == 'true'
         uses: actions/checkout@v4
         with:
-          repository: leanprover-community/mathlib4
+          repository: leanprover-community/mathlib4-nightly-testing
           token: ${{ secrets.MATHLIB4_BOT }}
           ref: nightly-testing
           fetch-depth: 0 # This ensures we check out all tags and branches.

doc/dev/index.md

@@ -85,5 +85,6 @@ such that changing files in `Init` doesn't force a full rebuild of `Lean`.
 You can test a Lean PR against Mathlib and Batteries by rebasing your PR
 on to `nightly-with-mathlib` branch. (It is fine to force push after rebasing.)
 CI will generate a branch of Mathlib and Batteries called `lean-pr-testing-NNNN`
-that uses the toolchain for your PR, and will report back to the Lean PR with results from Mathlib CI.
+on the `leanprover-community/mathlib4-nightly-testing` fork of Mathlib.
+This branch uses the toolchain for your PR, and will report back to the Lean PR with results from Mathlib CI.
 See https://leanprover-community.github.io/contribute/tags_and_branches.html for more details.

script/mathlib-bench

@@ -5,8 +5,11 @@ set -euo pipefail
 
 [ $# -eq 1 ] || (echo "usage: $0 <lean4 PR #>"; exit 1)
 
+echo "Warning: the speedcenter is probably not listening on mathlib4-nightly-testing yet."
+echo "If you're using this script, please contact @kim-em or @Kha to get this set up, and then remove this notice."
+
 LEAN_PR=$1
-PR_RESPONSE=$(gh api repos/leanprover-community/mathlib4/pulls -X POST -f head=lean-pr-testing-$LEAN_PR -f base=nightly-testing -f title="leanprover/lean4#$LEAN_PR benchmarking" -f draft=true -f body="ignore me")
+PR_RESPONSE=$(gh api repos/leanprover-community/mathlib4-nightly-testing/pulls -X POST -f head=lean-pr-testing-$LEAN_PR -f base=nightly-testing -f title="leanprover/lean4#$LEAN_PR benchmarking" -f draft=true -f body="ignore me")
 PR_NUMBER=$(echo "$PR_RESPONSE" | jq '.number')
-echo "opened https://github.com/leanprover-community/mathlib4/pull/$PR_NUMBER"
-gh api repos/leanprover-community/mathlib4/issues/$PR_NUMBER/comments -X POST -f body="!bench" > /dev/null
+echo "opened https://github.com/leanprover-community/mathlib4-nightly-testing/pull/$PR_NUMBER"
+gh api repos/leanprover-community/mathlib4-nightly-testing/issues/$PR_NUMBER/comments -X POST -f body="!bench" > /dev/null

src/Init/Conv.lean

@@ -339,6 +339,12 @@ This is the conv mode version of the `lift_lets` tactic.
 -/
 syntax (name := liftLets) "lift_lets " optConfig : conv
 
+/--
+Transforms `let` expressions into `have` expressions within th etarget expression when possible.
+This is the conv mode version of the `let_to_have` tactic.
+-/
+syntax (name := letToHave) "let_to_have" : conv
+
 /--
 `conv => ...` allows the user to perform targeted rewriting on a goal or hypothesis,
 by focusing on particular subexpressions.

src/Init/Data/BitVec/Bitblast.lean

@@ -1674,7 +1674,7 @@ private theorem neg_udiv_eq_intMin_iff_eq_intMin_eq_one_of_msb_eq_true
     obtain ⟨hx, hy⟩ := this
     simp only [beq_iff_eq] at hy
     subst hy
-    simp only [udiv_one, zero_lt_succ, neg_eq_intMin] at h
+    simp only [udiv_one, neg_eq_intMin] at h
     simp [h]
   · rintro ⟨hx, hy⟩
     subst hx hy
@@ -1701,10 +1701,9 @@ theorem msb_sdiv_eq_decide {x y : BitVec w} :
      := by
   rcases w; decide +revert
   case succ w =>
-    simp only [decide_true, ne_eq, decide_and, decide_not, Bool.true_and,
-      sdiv_eq, udiv_eq]
+    simp only [sdiv_eq, udiv_eq]
     rcases hxmsb : x.msb <;> rcases hymsb : y.msb
-    · simp [hxmsb, hymsb, msb_udiv_eq_false_of, Bool.not_false, Bool.and_false, Bool.false_and,
+    · simp [hxmsb, msb_udiv_eq_false_of, Bool.not_false, Bool.and_false, Bool.false_and,
         Bool.and_true, Bool.or_self, Bool.and_self]
     · simp only [hxmsb, hymsb, msb_neg, msb_udiv_eq_false_of, bne_false, Bool.not_false,
         Bool.and_self, ne_zero_of_msb_true, decide_false, Bool.and_true, Bool.true_and, Bool.not_true,
@@ -1716,7 +1715,7 @@ theorem msb_sdiv_eq_decide {x y : BitVec w} :
         obtain ⟨hcontra, _⟩ := this
         simp only [hcontra, true_eq_false] at hxmsb
       simp [this, hymsb, udiv_ne_zero_iff_ne_zero_and_le]
-    · simp only [hxmsb, hymsb, Bool.not_true, Bool.and_self, Bool.false_and, Bool.not_false,
+    · simp only [Bool.not_true, Bool.and_self, Bool.false_and, Bool.not_false,
         Bool.true_and, Bool.false_or, Bool.and_false, Bool.or_false]
       by_cases hx₁ : x = 0#(w + 1)
       · simp [hx₁, neg_zero, zero_udiv, msb_zero, le_zero_iff, Bool.and_not_self]
@@ -1725,12 +1724,12 @@ theorem msb_sdiv_eq_decide {x y : BitVec w} :
         · simp only [hy₁, decide_false, Bool.not_false, Bool.and_true]
           by_cases hxy₁ : (- x / y) = 0#(w + 1)
           · simp only [hxy₁, neg_zero, msb_zero, false_eq_decide_iff, BitVec.not_le,
-              decide_eq_true_eq, BitVec.not_le]
+              BitVec.not_le]
             simp only [udiv_eq_zero_iff_eq_zero_or_lt, hy₁, _root_.false_or] at hxy₁
             bv_omega
           · simp only [udiv_eq_zero_iff_eq_zero_or_lt, _root_.not_or, BitVec.not_lt,
               hy₁, not_false_eq_true, _root_.true_and] at hxy₁
-            simp only [hxy₁, decide_true, msb_neg, bne_iff_ne, ne_eq,
+            simp only [decide_true, msb_neg, bne_iff_ne, ne_eq,
               bool_to_prop,
               bne_iff_ne, ne_eq, udiv_eq_zero_iff_eq_zero_or_lt, hy₁, _root_.false_or,
               BitVec.not_lt, hxy₁, _root_.true_and, decide_not, not_eq_eq_eq_not, not_eq_not,

src/Init/Data/BitVec/Lemmas.lean

@@ -1880,14 +1880,14 @@ theorem toInt_shiftLeftZeroExtend {x : BitVec w} :
     (shiftLeftZeroExtend x n).toInt = x.toInt * 2 ^ n := by
   rw [shiftLeftZeroExtend_eq]
   rcases w with _|w
-  · simp [of_length_zero, shiftLeftZeroExtend_eq]
+  · simp [of_length_zero]
   · rcases n with _|n
-    · simp [shiftLeftZeroExtend_eq]
+    · simp
     · have := Nat.pow_pos (a := 2) (n := n + 1) (by omega)
       have : x.toNat <<< (n + 1) < 2 ^ (w + 1 + (n + 1)) := by
         rw [Nat.shiftLeft_eq, Nat.pow_add (a := 2) (m := w + 1) (n := n + 1), Nat.mul_lt_mul_right (by omega)]
         omega
-      simp only [shiftLeftZeroExtend_eq, toInt_shiftLeft, toNat_setWidth, Nat.lt_add_right_iff_pos,
+      simp only [toInt_shiftLeft, toNat_setWidth, Nat.lt_add_right_iff_pos,
         Nat.zero_lt_succ, toNat_mod_cancel_of_lt, Int.bmod_def]
       by_cases hmsb : x.msb
       · have hge := toNat_ge_of_msb_true hmsb
@@ -1902,7 +1902,7 @@ theorem toInt_shiftLeftZeroExtend {x : BitVec w} :
           show ¬2 * x.toNat < 2 ^ (w + 1) by simp [Nat.pow_add, Nat.mul_comm (2 ^ w) 2, hge]]
         norm_cast
         simp [Int.natCast_mul, Int.natCast_pow, Int.cast_ofNat_Int, Int.sub_mul,
-          Int.sub_right_inj, show w + (n + 1) + 1 = (w + 1) + (n + 1) by omega, Nat.pow_add]
+          show w + (n + 1) + 1 = (w + 1) + (n + 1) by omega, Nat.pow_add]
       · simp only [Bool.not_eq_true] at hmsb
         have hle := toNat_lt_of_msb_false (x := x) hmsb
         simp only [Nat.add_one_sub_one] at hle

src/Init/Data/Int/OfNat.lean

@@ -30,6 +30,7 @@ inductive Expr where
   | mul  (a b : Expr)
   | div  (a b : Expr)
   | mod  (a b : Expr)
+  | pow  (a : Expr) (k : Nat)
   deriving BEq
 
 @[expose]
@@ -40,6 +41,7 @@ def Expr.denote (ctx : Context) : Expr → Nat
   | .mul a b  => Nat.mul (denote ctx a) (denote ctx b)
   | .div a b  => Nat.div (denote ctx a) (denote ctx b)
   | .mod a b  => Nat.mod (denote ctx a) (denote ctx b)
+  | .pow a k  => Nat.pow (denote ctx a) k
 
 @[expose]
 def Expr.denoteAsInt (ctx : Context) : Expr → Int
@@ -49,6 +51,7 @@ def Expr.denoteAsInt (ctx : Context) : Expr → Int
   | .mul a b  => Int.mul (denoteAsInt ctx a) (denoteAsInt ctx b)
   | .div a b  => Int.ediv (denoteAsInt ctx a) (denoteAsInt ctx b)
   | .mod a b  => Int.emod (denoteAsInt ctx a) (denoteAsInt ctx b)
+  | .pow a k  => Int.pow (denoteAsInt ctx a) k
 
 theorem Expr.denoteAsInt_eq (ctx : Context) (e : Expr) : e.denoteAsInt ctx = e.denote ctx := by
   induction e <;> simp [denote, denoteAsInt, *] <;> rfl

src/Init/Data/Iterators/Lemmas/Consumers/Loop.lean

@@ -130,7 +130,7 @@ theorem Iter.forIn'_toList {α β : Type w} [Iterator α Id β]
   rw [forIn'_toList.aux this]
   rw [forIn'_eq_match_step]
   rw [List.forIn'_eq_foldlM] at *
-  simp only [map_eq_pure_bind, List.foldlM_map, hs]
+  simp only [map_eq_pure_bind, hs]
   cases step using PlausibleIterStep.casesOn
   · rename_i it' out h
     simp only [List.attach_cons, List.foldlM_cons, bind_pure_comp, map_bind]
@@ -180,7 +180,7 @@ theorem Iter.forIn_toList {α β : Type w} [Iterator α Id β]
     intro forInStep
     cases forInStep
     · induction it'.toList <;> simp [*]
-    · simp only [ForIn.forIn, forIn', List.forIn'] at ihy
+    · simp only [ForIn.forIn] at ihy
       simp [ihy h, forIn_eq_forIn_toIterM]
   · rename_i it' h
     simp only [bind_pure_comp]

src/Init/Data/Iterators/Lemmas/Consumers/Monadic/Collect.lean

@@ -63,7 +63,7 @@ theorem IterM.toArray_eq_match_step [Monad m] [LawfulMonad m] [Iterator α m β]
       | .done _ => return #[]) := by
   simp only [IterM.toArray, LawfulIteratorCollect.toArrayMapped_eq]
   rw [IterM.DefaultConsumers.toArrayMapped_eq_match_step]
-  simp [bind_pure_comp, pure_bind, toArray]
+  simp [bind_pure_comp, pure_bind]
 
 theorem IterM.toList_toArray [Monad m] [Iterator α m β] [Finite α m] [IteratorCollect α m m]
     {it : IterM (α := α) m β} :

src/Init/Data/Sum/Lemmas.lean

@@ -48,10 +48,10 @@ section get
   | inr _, _ => rfl
 
 @[simp, grind =] theorem getLeft?_eq_none_iff {x : α ⊕ β} : x.getLeft? = none ↔ x.isRight := by
-  cases x <;> simp only [getLeft?, isRight, eq_self_iff_true, reduceCtorEq]
+  cases x <;> simp only [getLeft?, isRight, reduceCtorEq]
 
 @[simp, grind =] theorem getRight?_eq_none_iff {x : α ⊕ β} : x.getRight? = none ↔ x.isLeft := by
-  cases x <;> simp only [getRight?, isLeft, eq_self_iff_true, reduceCtorEq]
+  cases x <;> simp only [getRight?, isLeft, reduceCtorEq]
 
 theorem eq_left_getLeft_of_isLeft : ∀ {x : α ⊕ β} (h : x.isLeft), x = inl (x.getLeft h)
   | inl _, _ => rfl

src/Init/Grind/Module.lean

@@ -7,3 +7,4 @@ module
 
 prelude
 import Init.Grind.Module.Basic
+import Init.Grind.Module.Envelope

src/Init/Grind/Module/Basic.lean

@@ -48,7 +48,11 @@ satisfying appropriate compatibilities.
 
 Equivalently, an additive commutative group.
 -/
-class IntModule (M : Type u) extends Zero M, Add M, Neg M, Sub M, HMul Int M M where
+class IntModule (M : Type u) extends Zero M, Add M, Neg M, Sub M where
+  /-- Scalar multiplication by natural numbers. -/
+  [hmulNat : HMul Nat M M]
+  /-- Scalar multiplication by integers. -/
+  [hmulInt : HMul Int M M]
   /-- Zero is the right identity for addition. -/
   add_zero : ∀ a : M, a + 0 = a
   /-- Addition is commutative. -/
@@ -69,6 +73,8 @@ class IntModule (M : Type u) extends Zero M, Add M, Neg M, Sub M, HMul Int M M w
   neg_add_cancel : ∀ a : M, -a + a = 0
   /-- Subtraction is addition of the negative. -/
   sub_eq_add_neg : ∀ a b : M, a - b = a + -b
+  /-- Scalar multiplication by natural numbers is consistent with scalar multiplication by integers. -/
+  hmul_nat : ∀ n : Nat, ∀ a : M, (n : Int) * a = n * a
 
 namespace NatModule
 
@@ -83,27 +89,33 @@ theorem mul_hmul (n m : Nat) (a : M) : (n * m) * a = n * (m * a) := by
   | succ n ih =>
     rw [Nat.add_one_mul, add_hmul, ih, add_hmul, one_hmul]
 
+instance (priority := 100) (M : Type u) [NatModule M] : SMul Nat M where
+  smul a x := a * x
+
 end NatModule
 
 namespace IntModule
 
-attribute [instance 100] IntModule.toZero IntModule.toAdd IntModule.toNeg IntModule.toSub IntModule.toHMul
+attribute [instance 100] IntModule.toZero IntModule.toAdd IntModule.toNeg IntModule.toSub
+  IntModule.hmulNat IntModule.hmulInt
 
 instance toNatModule (M : Type u) [i : IntModule M] : NatModule M :=
   { i with
-    hMul a x := (a : Int) * x
-    hmul_zero := by simp [IntModule.hmul_zero]
-    add_hmul := by simp [IntModule.add_hmul]
-    hmul_add := by simp [IntModule.hmul_add] }
-
-variable {M : Type u} [IntModule M]
+    hMul := i.hmulNat.hMul
+    zero_hmul := by simp [← hmul_nat, zero_hmul]
+    one_hmul := by simp [← hmul_nat, one_hmul]
+    hmul_zero := by simp [← hmul_nat, hmul_zero]
+    add_hmul := by simp [← hmul_nat, add_hmul]
+    hmul_add := by simp [← hmul_nat, hmul_add] }
 
 instance (priority := 100) (M : Type u) [IntModule M] : SMul Nat M where
-  smul a x := (a : Int) * x
+  smul a x := a * x
 
 instance (priority := 100) (M : Type u) [IntModule M] : SMul Int M where
   smul a x := a * x
 
+variable {M : Type u} [IntModule M]
+
 theorem zero_add (a : M) : 0 + a = a := by
   rw [add_comm, add_zero]
 
@@ -171,6 +183,9 @@ theorem hmul_sub (k : Int) (a b : M) : k * (a - b) = k * a - k * b := by
 theorem sub_hmul (k₁ k₂ : Int) (a : M) : (k₁ - k₂) * a = k₁ * a - k₂ * a := by
   rw [Int.sub_eq_add_neg, add_hmul, neg_hmul, ← sub_eq_add_neg]
 
+theorem nat_zero_hmul (a : M) : (0 : Nat) * a = 0 := by
+  rw [← hmul_nat, Int.natCast_zero, zero_hmul]
+
 private theorem nat_mul_hmul (n : Nat) (m : Int) (a : M) :
     ((n : Int) * m) * a = (n : Int) * (m * a) := by
   induction n with
@@ -195,6 +210,23 @@ class NoNatZeroDivisors (α : Type u) [HMul Nat α α] where
 
 export NoNatZeroDivisors (no_nat_zero_divisors)
 
+namespace NoNatZeroDivisors
+
+/-- Alternative constructor for `NoNatZeroDivisors` when we have an `IntModule`. -/
+def mk' {α} [IntModule α] (eq_zero_of_mul_eq_zero : ∀ (k : Nat) (a : α), k ≠ 0 → k * a = 0 → a = 0) : NoNatZeroDivisors α where
+  no_nat_zero_divisors k a b h₁ h₂ := by
+    rw [← IntModule.sub_eq_zero_iff, ← IntModule.hmul_nat, ← IntModule.hmul_nat, ← IntModule.hmul_sub, IntModule.hmul_nat] at h₂
+    rw [← IntModule.sub_eq_zero_iff]
+    apply eq_zero_of_mul_eq_zero k (a - b) h₁ h₂
+
+theorem eq_zero_of_mul_eq_zero {α : Type u} [NatModule α] [NoNatZeroDivisors α] {k : Nat} {a : α}
+    : k ≠ 0 → k * a = 0 → a = 0 := by
+  intro h₁ h₂
+  replace h₁ : k ≠ 0 := by intro h; simp [h] at h₁
+  exact no_nat_zero_divisors k a 0 h₁ (by rwa [NatModule.hmul_zero])
+
+end NoNatZeroDivisors
+
 instance [ToInt α (some lo) (some hi)] [IntModule α] [ToInt.Zero α (some lo) (some hi)] [ToInt.Add α (some lo) (some hi)] : ToInt.Neg α (some lo) (some hi) where
   toInt_neg x := by
     have := (ToInt.Add.toInt_add (-x) x).symm

src/Init/Grind/Module/Envelope.lean

@@ -0,0 +1,369 @@
+/-
+Copyright (c) 2025 Amazon.com, Inc. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Kim Morrison
+-/
+module
+
+prelude
+import Init.Grind.Ordered.Module
+import all Init.Data.AC
+
+namespace Lean.Grind.IntModule
+
+namespace OfNatModule
+variable (α : Type u)
+variable [NatModule α]
+
+-- Helper instance for `ac_rfl`
+local instance : Std.Associative (· + · : α → α → α) where
+  assoc := NatModule.add_assoc
+local instance : Std.Commutative (· + · : α → α → α) where
+  comm := NatModule.add_comm
+
+@[local simp] private theorem exists_true : ∃ (_ : α), True := ⟨0, trivial⟩
+
+@[local simp] def r : (α × α) → (α × α) → Prop
+  | (a, b), (c, d) => ∃ k, a + d + k = b + c + k
+
+def Q := Quot (r α)
+
+variable {α}
+
+theorem r_rfl (a : α × α) : r α a a := by
+  cases a; refine ⟨0, ?_⟩; simp [NatModule.add_zero]; ac_rfl
+
+theorem r_sym {a b : α × α} : r α a b → r α b a := by
+  cases a; cases b; simp [r]; intro h w; refine ⟨h, ?_⟩; simp [w, NatModule.add_comm]
+
+theorem r_trans {a b c : α × α} : r α a b → r α b c → r α a c := by
+  cases a; cases b; cases c;
+  next a₁ a₂ b₁ b₂ c₁ c₂ =>
+  simp [r]
+  intro k₁ h₁ k₂ h₂
+  refine ⟨(k₁ + k₂ + b₁ + b₂), ?_⟩
+  replace h₁ := congrArg (· + (b₁ + c₂ + k₂)) h₁; simp at h₁
+  have haux₁ : a₁ + b₂ + k₁ + (b₁ + c₂ + k₂) = (a₁ + c₂) + (k₁ + k₂ + b₁ + b₂) := by ac_rfl
+  have haux₂ : a₂ + b₁ + k₁ + (b₁ + c₂ + k₂) = (a₂ + c₁) + (k₁ + k₂ + b₁ + b₂) := by rw [h₂]; ac_rfl
+  rw [haux₁, haux₂] at h₁
+  exact h₁
+
+def Q.mk (p : α × α) : Q α :=
+  Quot.mk (r α) p
+
+def Q.liftOn₂ (q₁ q₂ : Q α)
+    (f : α × α → α × α → β)
+    (h : ∀ {a₁ b₁ a₂ b₂}, r α a₁ a₂ → r α b₁ b₂ → f a₁ b₁ = f a₂ b₂)
+    : β := by
+  apply Quot.lift (fun (a₁ : α × α) => Quot.lift (f a₁)
+    (fun (a b : α × α) => @h a₁ a a₁ b (r_rfl a₁)) q₂) _ q₁
+  intros
+  induction q₂ using Quot.ind
+  apply h; assumption; apply r_rfl
+
+attribute [local simp] Q.mk Q.liftOn₂ NatModule.add_zero
+
+def Q.ind {β : Q α → Prop} (mk : ∀ (a : α × α), β (Q.mk a)) (q : Q α) : β q :=
+  Quot.ind mk q
+
+@[local simp] def hmulNat (n : Nat) (q : Q α) : (Q α) :=
+  q.liftOn (fun (a, b) => Q.mk (n * a, n * b))
+    (by intro (a₁, b₁) (a₂, b₂)
+        simp; intro k h; apply Quot.sound; simp
+        refine ⟨n * k, ?_⟩
+        replace h := congrArg (fun x : α => n * x) h
+        simpa [NatModule.hmul_add] using h)
+
+@[local simp] def hmulInt (n : Int) (q : Q α) : (Q α) :=
+  q.liftOn (fun (a, b) => if n < 0 then Q.mk (n.natAbs * b, n.natAbs * a) else Q.mk (n.natAbs * a, n.natAbs * b))
+    (by intro (a₁, b₁) (a₂, b₂)
+        simp; intro k h;
+        split
+        · apply Quot.sound; simp
+          refine ⟨n.natAbs * k, ?_⟩
+          replace h := congrArg (fun x : α => n.natAbs * x) h
+          simpa [NatModule.hmul_add] using h.symm
+        · apply Quot.sound; simp
+          refine ⟨n.natAbs * k, ?_⟩
+          replace h := congrArg (fun x : α => n.natAbs * x) h
+          simpa [NatModule.hmul_add] using h)
+
+@[local simp] def sub (q₁ q₂ : Q α) : Q α :=
+  Q.liftOn₂ q₁ q₂ (fun (a, b) (c, d) => Q.mk (a + d, c + b))
+    (by intro (a₁, b₁) (a₂, b₂) (a₃, b₃) (a₄, b₄)
+        simp; intro k₁ h₁ k₂ h₂; apply Quot.sound; simp
+        refine ⟨k₁ + k₂, ?_⟩
+        have : a₁ + b₂ + (a₄ + b₃) + (k₁ + k₂) = a₁ + b₃ + k₁ + (b₂ + a₄ + k₂) := by ac_rfl
+        rw [this, h₁, ← h₂]
+        ac_rfl)
+
+@[local simp] def add (q₁ q₂ : Q α) : Q α :=
+  Q.liftOn₂ q₁ q₂ (fun (a, b) (c, d) => Q.mk (a + c, b + d))
+    (by intro (a₁, b₁) (a₂, b₂) (a₃, b₃) (a₄, b₄)
+        simp; intro k₁ h₁ k₂ h₂; apply Quot.sound; simp
+        refine ⟨k₁ + k₂, ?_⟩
+        have : a₁ + a₂ + (b₃ + b₄) + (k₁ + k₂) = a₁ + b₃ + k₁ + (a₂ + b₄ + k₂) := by ac_rfl
+        rw [this, h₁, h₂]
+        ac_rfl)
+
+@[local simp] def neg (q : Q α) : Q α :=
+  q.liftOn (fun (a, b) => Q.mk (b, a))
+    (by intro (a₁, b₁) (a₂, b₂)
+        simp; intro k h; apply Quot.sound; simp
+        exact ⟨k, h.symm⟩)
+
+attribute [local simp]
+  Quot.liftOn NatModule.add_zero NatModule.zero_add NatModule.one_hmul NatModule.zero_hmul NatModule.hmul_zero
+  NatModule.hmul_add NatModule.add_hmul
+
+@[local simp] def zero : Q α :=
+  Q.mk (0, 0)
+
+theorem neg_add_cancel (a : Q α) : add (neg a) a = zero := by
+  induction a using Quot.ind
+  next a =>
+  cases a; simp
+  apply Quot.sound; simp; refine ⟨0, ?_⟩; ac_rfl
+
+theorem add_comm (a b : Q α) : add a b = add b a := by
+  induction a using Quot.ind
+  induction b using Quot.ind
+  next a b =>
+  cases a; cases b; simp; apply Quot.sound; simp; refine ⟨0, ?_⟩; ac_rfl
+
+theorem add_zero (a : Q α) : add a zero = a := by
+  induction a using Quot.ind
+  next a => cases a; simp
+
+theorem add_assoc (a b c : Q α) : add (add a b) c = add a (add b c) := by
+  induction a using Quot.ind
+  induction b using Quot.ind
+  induction c using Quot.ind
+  next a b c =>
+  cases a; cases b; cases c; simp; apply Quot.sound; simp; refine ⟨0, ?_⟩; ac_rfl
+
+theorem sub_eq_add_neg (a b : Q α) : sub a b = add a (neg b) := by
+  induction a using Quot.ind
+  induction b using Quot.ind
+  next a b =>
+  cases a; cases b; simp; apply Quot.sound; simp; refine ⟨0, ?_⟩; ac_rfl
+
+theorem one_hmul (a : Q α) : hmulInt 1 a = a := by
+  induction a using Quot.ind
+  next a => cases a; simp
+
+theorem zero_hmul (a : Q α) : hmulInt 0 a = zero := by
+  induction a using Quot.ind
+  next a => cases a; simp
+
+theorem hmul_zero (a : Int) : hmulInt a (zero : Q α) = zero := by
+  simp
+
+theorem hmul_add (a : Int) (b c : Q α) : hmulInt a (add b c) = add (hmulInt a b) (hmulInt a c) := by
+  induction b using Q.ind
+  induction c using Q.ind
+  next b c =>
+  cases b; cases c; simp
+  split <;>
+  · apply Quot.sound
+    refine ⟨0, ?_⟩
+    simp
+    ac_rfl
+
+theorem add_hmul (a b : Int) (c : Q α) : hmulInt (a + b) c = add (hmulInt a c) (hmulInt b c) := by
+  induction c using Q.ind
+  next c =>
+  rcases c with ⟨c₁, c₂⟩; simp
+  by_cases hb : b < 0
+  · simp only [if_pos hb]
+    by_cases ha : a < 0
+    · simp only [if_pos ha]
+      rw [if_pos (by omega)]
+      apply Quot.sound
+      refine ⟨0, ?_⟩
+      rw [Int.natAbs_add_of_nonpos (by omega) (by omega), NatModule.add_hmul, NatModule.add_hmul]
+      ac_rfl
+    · split
+      · apply Quot.sound
+        refine ⟨a.natAbs * c₁ + a.natAbs * c₂, ?_⟩
+        have : (a + b).natAbs + a.natAbs = b.natAbs := by omega
+        simp [← this]
+        ac_rfl
+      · apply Quot.sound
+        refine ⟨b.natAbs * c₁ + b.natAbs * c₂, ?_⟩
+        have : (a + b).natAbs + b.natAbs = a.natAbs := by omega
+        simp [← this]
+        ac_rfl
+  · simp only [if_neg hb]
+    by_cases ha : a < 0
+    · split
+      · apply Quot.sound
+        refine ⟨a.natAbs * c₁ + a.natAbs * c₂, ?_⟩
+        have : (a + b).natAbs + b.natAbs = a.natAbs := by omega
+        simp [← this]
+        ac_rfl
+      · apply Quot.sound
+        refine ⟨b.natAbs * c₁ + b.natAbs * c₂, ?_⟩
+        have : (a + b).natAbs + a.natAbs = b.natAbs := by omega
+        simp [← this]
+        ac_rfl
+    · simp only [if_neg ha]
+      rw [if_neg (by omega)]
+      apply Quot.sound
+      refine ⟨0, ?_⟩
+      rw [Int.natAbs_add_of_nonneg (by omega) (by omega), NatModule.add_hmul, NatModule.add_hmul]
+      ac_rfl
+
+theorem hmul_nat (n : Nat) (a : Q α) : hmulInt (n : Int) a = hmulNat n a := by
+  induction a using Q.ind
+  next a =>
+  rcases a with ⟨a₁, a₂⟩; simp; omega
+
+def ofNatModule : IntModule (Q α) := {
+  hmulNat := ⟨hmulNat⟩,
+  hmulInt := ⟨hmulInt⟩,
+  zero,
+  add, sub, neg,
+  add_comm, add_assoc, add_zero,
+  neg_add_cancel, sub_eq_add_neg,
+  one_hmul, zero_hmul, hmul_zero, hmul_add, add_hmul,
+  hmul_nat
+}
+
+attribute [instance] ofNatModule
+
+@[local simp] def toQ (a : α) : Q α :=
+  Q.mk (a, 0)
+
+/-! Embedding theorems -/
+
+theorem toQ_add (a b : α) : toQ (a + b) = toQ a + toQ b := by
+  simp; apply Quot.sound; simp
+
+/-!
+Helper definitions and theorems for proving `toQ` is injective when
+`CommSemiring` has the right_cancel property
+-/
+
+private def rel (h : Equivalence (r α)) (q₁ q₂ : Q α) : Prop :=
+  Q.liftOn₂ q₁ q₂
+    (fun a₁ a₂ => r α a₁ a₂)
+    (by intro a₁ b₁ a₂ b₂ h₁ h₂
+        simp [-r]; constructor
+        next => intro h₃; exact h.trans (h.symm h₁) (h.trans h₃ h₂)
+        next => intro h₃; exact h.trans h₁ (h.trans h₃ (h.symm h₂)))
+
+private theorem rel_rfl (h : Equivalence (r α)) (q : Q α) : rel h q q := by
+  induction q using Quot.ind
+  simp [rel, NatModule.add_comm]
+
+private theorem helper (h : Equivalence (r α)) (q₁ q₂ : Q α) : q₁ = q₂ → rel h q₁ q₂ := by
+  intro h; subst q₁; apply rel_rfl h
+
+theorem Q.exact : Q.mk a = Q.mk b → r α a b := by
+  apply helper
+  constructor; exact r_rfl; exact r_sym; exact r_trans
+
+-- If the `NatModule` has the `AddRightCancel` property then `toQ` is injective
+theorem toQ_inj [AddRightCancel α] {a b : α} : toQ a = toQ b → a = b := by
+  simp; intro h₁
+  replace h₁ := Q.exact h₁
+  simp at h₁
+  obtain ⟨k, h₁⟩ := h₁
+  exact AddRightCancel.add_right_cancel a b k h₁
+
+instance [NatModule α] [AddRightCancel α] [NoNatZeroDivisors α] : NoNatZeroDivisors (OfNatModule.Q α) where
+  no_nat_zero_divisors := by
+    intro k a b h₁ h₂
+    replace h₂ : k * a = k * b := h₂
+    induction a using Quot.ind
+    induction b using Quot.ind
+    next a b =>
+    rcases a with ⟨a₁, a₂⟩
+    rcases b with ⟨b₁, b₂⟩
+    replace h₂ := Q.exact h₂
+    simp [r] at h₂
+    rcases h₂ with ⟨k', h₂⟩
+    replace h₂ := AddRightCancel.add_right_cancel _ _ _ h₂
+    simp [← NatModule.hmul_add] at h₂
+    replace h₂ := NoNatZeroDivisors.no_nat_zero_divisors k (a₁ + b₂) (a₂ + b₁) h₁ h₂
+    apply Quot.sound; simp [r]; exists 0; simp [h₂]
+
+instance [Preorder α] [OrderedAdd α] : LE (OfNatModule.Q α) where
+  le a b := Q.liftOn₂ a b (fun (a, b) (c, d) => a + d ≤ b + c)
+    (by intro (a₁, b₁) (a₂, b₂) (a₃, b₃) (a₄, b₄)
+        simp; intro k₁ h₁ k₂ h₂
+        rw [OrderedAdd.add_le_left_iff (b₃ + k₁)]
+        have : a₁ + b₂ + (b₃ + k₁) = a₁ + b₃ + k₁ + b₂ := by ac_rfl
+        rw [this, h₁]; clear this
+        rw [OrderedAdd.add_le_left_iff (a₄ + k₂)]
+        have : b₁ + a₃ + k₁ + b₂ + (a₄ + k₂) = b₂ + a₄ + k₂ + b₁ + a₃ + k₁ := by ac_rfl
+        rw [this, ← h₂]; clear this
+        have : a₂ + b₄ + k₂ + b₁ + a₃ + k₁ = a₃ + b₄ + (a₂ + b₁ + k₁ + k₂) := by ac_rfl
+        rw [this]; clear this
+        have : b₁ + a₂ + (b₃ + k₁) + (a₄ + k₂) = b₃ + a₄ + (a₂ + b₁ + k₁ + k₂) := by ac_rfl
+        rw [this]; clear this
+        rw [← OrderedAdd.add_le_left_iff])
+
+@[local simp] theorem mk_le_mk [Preorder α] [OrderedAdd α] {a₁ a₂ b₁ b₂ : α}  :
+    Q.mk (a₁, a₂) ≤ Q.mk (b₁, b₂) ↔ a₁ + b₂ ≤ a₂ + b₁ := by
+  rfl
+
+instance [Preorder α] [OrderedAdd α] : Preorder (OfNatModule.Q α) where
+  le_refl a := by
+    induction a using Quot.ind
+    next a =>
+    rcases a with ⟨a₁, a₂⟩
+    change Q.mk _ ≤ Q.mk _
+    simp only [mk_le_mk]
+    simp [NatModule.add_comm]; exact Preorder.le_refl (a₁ + a₂)
+  le_trans {a b c} h₁ h₂ := by
+    induction a using Q.ind
+    induction b using Q.ind
+    induction c using Q.ind
+    next a b c =>
+    rcases a with ⟨a₁, a₂⟩; rcases b with ⟨b₁, b₂⟩; rcases c with ⟨c₁, c₂⟩
+    simp only [mk_le_mk] at h₁ h₂ ⊢
+    rw [OrderedAdd.add_le_left_iff (b₁ + b₂)]
+    have : a₁ + c₂ + (b₁ + b₂) = a₁ + b₂ + (b₁ + c₂) := by ac_rfl
+    rw [this]; clear this
+    have : a₂ + c₁ + (b₁ + b₂) = a₂ + b₁ + (b₂ + c₁) := by ac_rfl
+    rw [this]; clear this
+    exact OrderedAdd.add_le_add h₁ h₂
+
+attribute [-simp] Q.mk
+
+@[local simp] private theorem mk_lt_mk [Preorder α] [OrderedAdd α] {a₁ a₂ b₁ b₂ : α}  :
+    Q.mk (a₁, a₂) < Q.mk (b₁, b₂) ↔ a₁ + b₂ < a₂ + b₁ := by
+  simp [Preorder.lt_iff_le_not_le, NatModule.add_comm]
+
+@[local simp] private theorem mk_pos [Preorder α] [OrderedAdd α] {a₁ a₂ : α} :
+    0 < Q.mk (a₁, a₂) ↔ a₂ < a₁ := by
+  change Q.mk (0,0) < _ ↔ _
+  simp [mk_lt_mk, NatModule.zero_add]
+
+@[local simp]
+theorem toQ_le [Preorder α] [OrderedAdd α] {a b : α} : toQ a ≤ toQ b ↔ a ≤ b := by
+  simp
+
+@[local simp]
+theorem toQ_lt [Preorder α] [OrderedAdd α] {a b : α} : toQ a < toQ b ↔ a < b := by
+  simp [Preorder.lt_iff_le_not_le]
+
+instance [Preorder α] [OrderedAdd α] : OrderedAdd (OfNatModule.Q α) where
+  add_le_left_iff := by
+    intro a b c
+    induction a using Quot.ind
+    induction b using Quot.ind
+    induction c using Quot.ind
+    next a b c =>
+    rcases a with ⟨a₁, a₂⟩; rcases b with ⟨b₁, b₂⟩; rcases c with ⟨c₁, c₂⟩
+    change a₁ + b₂ ≤ a₂ + b₁ ↔ (a₁ + c₁) + _ ≤ _
+    have : a₁ + c₁ + (b₂ + c₂) = a₁ + b₂ + (c₁ + c₂) := by ac_rfl
+    rw [this]; clear this
+    have : a₂ + c₂ + (b₁ + c₁) = a₂ + b₁ + (c₁ + c₂) := by ac_rfl
+    rw [this]; clear this
+    rw [← OrderedAdd.add_le_left_iff]
+
+end OfNatModule
+end Lean.Grind.IntModule

src/Init/Grind/Ordered/Field.lean

@@ -13,18 +13,19 @@ namespace Lean.Grind
 
 namespace Field.IsOrdered
 
-variable {R : Type u} [Field R] [LinearOrder R] [Ring.IsOrdered R]
+variable {R : Type u} [Field R] [LinearOrder R] [OrderedRing R]
 
-open Ring.IsOrdered
+open OrderedAdd
+open OrderedRing
 
 theorem pos_of_inv_pos {a : R} (h : 0 < a⁻¹) : 0 < a := by
   rcases LinearOrder.trichotomy 0 a with (h' | rfl | h')
   · exact h'
   · simpa [Field.inv_zero] using h
   · exfalso
-    have := Ring.IsOrdered.mul_neg_of_pos_of_neg h h'
+    have := OrderedRing.mul_neg_of_pos_of_neg h h'
     rw [inv_mul_cancel (Preorder.ne_of_lt h')] at this
-    exact Ring.IsOrdered.not_one_lt_zero this
+    exact OrderedRing.not_one_lt_zero this
 
 theorem inv_pos_iff {a : R} : 0 < a⁻¹ ↔ 0 < a := by
   constructor
@@ -36,7 +37,7 @@ theorem inv_pos_iff {a : R} : 0 < a⁻¹ ↔ 0 < a := by
 theorem inv_neg_iff {a : R} : a⁻¹ < 0 ↔ a < 0 := by
   have := inv_pos_iff (a := -a)
   rw [Field.inv_neg] at this
-  simpa [IntModule.IsOrdered.neg_pos_iff]
+  simpa [neg_pos_iff]
 
 theorem inv_nonneg_iff {a : R} : 0 ≤ a⁻¹ ↔ 0 ≤ a := by
   simp [PartialOrder.le_iff_lt_or_eq, inv_pos_iff, Field.zero_eq_inv_iff]
@@ -44,15 +45,15 @@ theorem inv_nonneg_iff {a : R} : 0 ≤ a⁻¹ ↔ 0 ≤ a := by
 theorem inv_nonpos_iff {a : R} : a⁻¹ ≤ 0 ↔ a ≤ 0 := by
   have := inv_nonneg_iff (a := -a)
   rw [Field.inv_neg] at this
-  simpa [IntModule.IsOrdered.neg_nonneg_iff] using this
+  simpa [neg_nonneg_iff] using this
 
 private theorem mul_le_of_le_mul_inv {a b c : R} (h : 0 < c) (h' : a ≤ b * c⁻¹) : a * c ≤ b := by
   simpa [Semiring.mul_assoc, Field.inv_mul_cancel (Preorder.ne_of_gt h), Semiring.mul_one] using
-    Ring.IsOrdered.mul_le_mul_of_nonneg_right h' (Preorder.le_of_lt h)
+    OrderedRing.mul_le_mul_of_nonneg_right h' (Preorder.le_of_lt h)
 
 private theorem le_mul_inv_of_mul_le {a b c : R} (h : 0 < b) (h' : a * b ≤ c) : a ≤ c * b⁻¹ := by
   simpa [Semiring.mul_assoc, Field.mul_inv_cancel (Preorder.ne_of_gt h), Semiring.mul_one] using
-    Ring.IsOrdered.mul_le_mul_of_nonneg_right h' (Preorder.le_of_lt (inv_pos_iff.mpr h))
+    OrderedRing.mul_le_mul_of_nonneg_right h' (Preorder.le_of_lt (inv_pos_iff.mpr h))
 
 theorem le_mul_inv_iff_mul_le (a b : R) {c : R} (h : 0 < c) : a ≤ b * c⁻¹ ↔ a * c ≤ b :=
   ⟨mul_le_of_le_mul_inv h, le_mul_inv_of_mul_le h⟩
@@ -63,11 +64,11 @@ private theorem mul_inv_le_iff_le_mul (a c : R) {b : R} (h : 0 < b) : a * b⁻¹
 
 private theorem mul_lt_of_lt_mul_inv {a b c : R} (h : 0 < c) (h' : a < b * c⁻¹) : a * c < b := by
   simpa [Semiring.mul_assoc, Field.inv_mul_cancel (Preorder.ne_of_gt h), Semiring.mul_one] using
-    Ring.IsOrdered.mul_lt_mul_of_pos_right h' h
+    OrderedRing.mul_lt_mul_of_pos_right h' h
 
 private theorem lt_mul_inv_of_mul_lt {a b c : R} (h : 0 < b) (h' : a * b < c) : a < c * b⁻¹ := by
   simpa [Semiring.mul_assoc, Field.mul_inv_cancel (Preorder.ne_of_gt h), Semiring.mul_one] using
-    Ring.IsOrdered.mul_lt_mul_of_pos_right h' (inv_pos_iff.mpr h)
+    OrderedRing.mul_lt_mul_of_pos_right h' (inv_pos_iff.mpr h)
 
 theorem lt_mul_inv_iff_mul_lt (a b : R) {c : R} (h : 0 < c) : a < b * c⁻¹ ↔ a * c < b :=
   ⟨mul_lt_of_lt_mul_inv h, lt_mul_inv_of_mul_lt h⟩
@@ -77,19 +78,19 @@ theorem mul_inv_lt_iff_lt_mul (a c : R) {b : R} (h : 0 < b) : a * b⁻¹ < c ↔
 
 private theorem le_mul_of_le_mul_inv {a b c : R} (h : c < 0) (h' : a ≤ b * c⁻¹) : b ≤ a * c := by
   simpa [Semiring.mul_assoc, Field.inv_mul_cancel (Preorder.ne_of_lt h), Semiring.mul_one] using
-    Ring.IsOrdered.mul_le_mul_of_nonpos_right h' (Preorder.le_of_lt h)
+    OrderedRing.mul_le_mul_of_nonpos_right h' (Preorder.le_of_lt h)
 
 private theorem mul_le_of_mul_inv_le {a b c : R} (h : b < 0) (h' : a * b⁻¹ ≤ c) : c * b ≤ a := by
   simpa [Semiring.mul_assoc, Field.inv_mul_cancel (Preorder.ne_of_lt h), Semiring.mul_one] using
-    Ring.IsOrdered.mul_le_mul_of_nonpos_right h' (Preorder.le_of_lt h)
+    OrderedRing.mul_le_mul_of_nonpos_right h' (Preorder.le_of_lt h)
 
 private theorem mul_inv_le_of_mul_le {a b c : R} (h : b < 0) (h' : a * b ≤ c) : c * b⁻¹ ≤ a := by
   simpa [Semiring.mul_assoc, Field.mul_inv_cancel (Preorder.ne_of_lt h), Semiring.mul_one] using
-    Ring.IsOrdered.mul_le_mul_of_nonpos_right h' (Preorder.le_of_lt (inv_neg_iff.mpr h))
+    OrderedRing.mul_le_mul_of_nonpos_right h' (Preorder.le_of_lt (inv_neg_iff.mpr h))
 
 private theorem le_mul_inv_of_le_mul {a b c : R} (h : c < 0) (h' : a ≤ b * c) : b ≤ a * c⁻¹ := by
   simpa [Semiring.mul_assoc, Field.mul_inv_cancel (Preorder.ne_of_lt h), Semiring.mul_one] using
-    Ring.IsOrdered.mul_le_mul_of_nonpos_right h' (Preorder.le_of_lt (inv_neg_iff.mpr h))
+    OrderedRing.mul_le_mul_of_nonpos_right h' (Preorder.le_of_lt (inv_neg_iff.mpr h))
 
 theorem le_mul_inv_iff_le_mul_of_neg (a b : R) {c : R} (h : c < 0) : a ≤ b * c⁻¹ ↔ b ≤ a * c :=
   ⟨le_mul_of_le_mul_inv h, le_mul_inv_of_le_mul h⟩
@@ -99,19 +100,19 @@ theorem mul_inv_le_iff_mul_le_of_neg (a c : R) {b : R} (h : b < 0) : a * b⁻¹
 
 private theorem lt_mul_of_lt_mul_inv {a b c : R} (h : c < 0) (h' : a < b * c⁻¹) : b < a * c := by
   simpa [Semiring.mul_assoc, Field.inv_mul_cancel (Preorder.ne_of_lt h), Semiring.mul_one] using
-    Ring.IsOrdered.mul_lt_mul_of_neg_right h' h
+    OrderedRing.mul_lt_mul_of_neg_right h' h
 
 private theorem mul_lt_of_mul_inv_lt {a b c : R} (h : b < 0) (h' : a * b⁻¹ < c) : c * b < a := by
   simpa [Semiring.mul_assoc, Field.inv_mul_cancel (Preorder.ne_of_lt h), Semiring.mul_one] using
-    Ring.IsOrdered.mul_lt_mul_of_neg_right h' h
+    OrderedRing.mul_lt_mul_of_neg_right h' h
 
 private theorem mul_inv_lt_of_mul_lt {a b c : R} (h : b < 0) (h' : a * b < c) : c * b⁻¹ < a := by
   simpa [Semiring.mul_assoc, Field.mul_inv_cancel (Preorder.ne_of_lt h), Semiring.mul_one] using
-    Ring.IsOrdered.mul_lt_mul_of_neg_right h' (inv_neg_iff.mpr h)
+    OrderedRing.mul_lt_mul_of_neg_right h' (inv_neg_iff.mpr h)
 
 private theorem lt_mul_inv_of_lt_mul {a b c : R} (h : c < 0) (h' : a < b * c) : b < a * c⁻¹ := by
   simpa [Semiring.mul_assoc, Field.mul_inv_cancel (Preorder.ne_of_lt h), Semiring.mul_one] using
-    Ring.IsOrdered.mul_lt_mul_of_neg_right h' (inv_neg_iff.mpr h)
+    OrderedRing.mul_lt_mul_of_neg_right h' (inv_neg_iff.mpr h)
 
 theorem lt_mul_inv_iff_lt_mul_of_neg (a b : R) {c : R} (h : c < 0) : a < b * c⁻¹ ↔ b < a * c :=
   ⟨lt_mul_of_lt_mul_inv h, lt_mul_inv_of_lt_mul h⟩

src/Init/Grind/Ordered/Int.lean

@@ -16,18 +16,17 @@ import Init.Omega
 
 namespace Lean.Grind
 
-instance : Preorder Int where
+instance : LinearOrder Int where
   le_refl := Int.le_refl
   le_trans := Int.le_trans
   lt_iff_le_not_le := by omega
+  le_antisymm := Int.le_antisymm
+  le_total := Int.le_total
 
-instance : IntModule.IsOrdered Int where
-  neg_le_iff := by omega
-  add_le_left := by omega
-  hmul_pos_iff k a ha := ⟨fun h => Int.pos_of_mul_pos_left h ha, fun hk => Int.mul_pos hk ha⟩
-  hmul_nonneg hk ha := Int.mul_nonneg hk ha
+instance : OrderedAdd Int where
+  add_le_left_iff := by omega
 
-instance : Ring.IsOrdered Int where
+instance : OrderedRing Int where
   zero_lt_one := by omega
   mul_lt_mul_of_pos_left := Int.mul_lt_mul_of_pos_left
   mul_lt_mul_of_pos_right := Int.mul_lt_mul_of_pos_right

src/Init/Grind/Ordered/Linarith.lean

@@ -20,7 +20,7 @@ namespace Lean.Grind.Linarith
 abbrev Var := Nat
 open IntModule
 
-attribute [local simp] add_zero zero_add zero_hmul hmul_zero one_hmul
+attribute [local simp] add_zero zero_add zero_hmul nat_zero_hmul hmul_zero one_hmul
 
 inductive Expr where
   | zero
@@ -28,8 +28,9 @@ inductive Expr where
   | add  (a b : Expr)
   | sub  (a b : Expr)
   | neg  (a : Expr)
-  | mul  (k : Int) (a : Expr)
-  deriving Inhabited, BEq
+  | natMul  (k : Nat) (a : Expr)
+  | intMul  (k : Int) (a : Expr)
+  deriving Inhabited, BEq, Repr
 
 abbrev Context (α : Type u) := RArray α
 
@@ -41,13 +42,14 @@ def Expr.denote {α} [IntModule α] (ctx : Context α) : Expr → α
   | .var v    => v.denote ctx
   | .add a b  => denote ctx a + denote ctx b
   | .sub a b  => denote ctx a - denote ctx b
-  | .mul k a  => k * denote ctx a
+  | .natMul k a  => k * denote ctx a
+  | .intMul k a  => k * denote ctx a
   | .neg a    => -denote ctx a
 
 inductive Poly where
   | nil
   | add (k : Int) (v : Var) (p : Poly)
-  deriving BEq
+  deriving BEq, Repr
 
 def Poly.denote {α} [IntModule α] (ctx : Context α) (p : Poly) : α :=
   match p with
@@ -144,7 +146,8 @@ where
     | .var v    => (.add coeff v ·)
     | .add a b  => go coeff a ∘ go coeff b
     | .sub a b  => go coeff a ∘ go (-coeff) b
-    | .mul k a  => bif k == 0 then id else go (Int.mul coeff k) a
+    | .natMul k a  => bif k == 0 then id else go (Int.mul coeff k) a
+    | .intMul k a  => bif k == 0 then id else go (Int.mul coeff k) a
     | .neg a    => go (-coeff) a
 
 /-- Converts the given expression into a polynomial, and then normalizes it. -/
@@ -215,6 +218,8 @@ theorem Expr.denote_toPoly'_go {α} [IntModule α] {k p} (ctx : Context α) (e :
   next => ac_rfl
   next => rw [sub_eq_add_neg, neg_hmul, hmul_add, hmul_neg]; ac_rfl
   next h => simp at h; subst h; simp
+  next ih => simp at ih; rw [ih, mul_hmul, IntModule.hmul_nat]
+  next ih => simp at ih; simp [ih]
   next ih => simp at ih; rw [ih, mul_hmul]
   next => rw [hmul_neg, neg_hmul]
 
@@ -241,23 +246,23 @@ def Poly.leadCoeff (p : Poly) : Int :=
   | .add a _ _ => a
   | _ => 1
 
-open IntModule.IsOrdered
+open OrderedAdd
 
 /-!
 Helper theorems for conflict resolution during model construction.
 -/
 
-private theorem le_add_le {α} [IntModule α] [Preorder α] [IntModule.IsOrdered α] {a b : α}
+private theorem le_add_le {α} [IntModule α] [Preorder α] [OrderedAdd α] {a b : α}
     (h₁ : a ≤ 0) (h₂ : b ≤ 0) : a + b ≤ 0 := by
   replace h₁ := add_le_left h₁ b; simp at h₁
   exact Preorder.le_trans h₁ h₂
 
-private theorem le_add_lt {α} [IntModule α] [Preorder α] [IntModule.IsOrdered α] {a b : α}
+private theorem le_add_lt {α} [IntModule α] [Preorder α] [OrderedAdd α] {a b : α}
     (h₁ : a ≤ 0) (h₂ : b < 0) : a + b < 0 := by
   replace h₁ := add_le_left h₁ b; simp at h₁
   exact Preorder.lt_of_le_of_lt h₁ h₂
 
-private theorem lt_add_lt {α} [IntModule α] [Preorder α] [IntModule.IsOrdered α] {a b : α}
+private theorem lt_add_lt {α} [IntModule α] [Preorder α] [OrderedAdd α] {a b : α}
     (h₁ : a < 0) (h₂ : b < 0) : a + b < 0 := by
   replace h₁ := add_lt_left h₁ b; simp at h₁
   exact Preorder.lt_trans h₁ h₂
@@ -270,11 +275,11 @@ def le_le_combine_cert (p₁ p₂ p₃ : Poly) : Bool :=
   let a₂ := p₂.leadCoeff.natAbs
   p₃ == (p₁.mul a₂ |>.combine (p₂.mul a₁))
 
-theorem le_le_combine {α} [IntModule α] [Preorder α] [IntModule.IsOrdered α] (ctx : Context α) (p₁ p₂ p₃ : Poly)
+theorem le_le_combine {α} [IntModule α] [Preorder α] [OrderedAdd α] (ctx : Context α) (p₁ p₂ p₃ : Poly)
     : le_le_combine_cert p₁ p₂ p₃ → p₁.denote' ctx ≤ 0 → p₂.denote' ctx ≤ 0 → p₃.denote' ctx ≤ 0 := by
   simp [le_le_combine_cert]; intro _ h₁ h₂; subst p₃; simp
-  replace h₁ := hmul_nonpos (coe_natAbs_nonneg p₂.leadCoeff) h₁
-  replace h₂ := hmul_nonpos (coe_natAbs_nonneg p₁.leadCoeff) h₂
+  replace h₁ := hmul_int_nonpos (coe_natAbs_nonneg p₂.leadCoeff) h₁
+  replace h₂ := hmul_int_nonpos (coe_natAbs_nonneg p₁.leadCoeff) h₂
   exact le_add_le h₁ h₂
 
 def le_lt_combine_cert (p₁ p₂ p₃ : Poly) : Bool :=
@@ -282,11 +287,11 @@ def le_lt_combine_cert (p₁ p₂ p₃ : Poly) : Bool :=
   let a₂ := p₂.leadCoeff.natAbs
   a₁ > (0 : Int) && p₃ == (p₁.mul a₂ |>.combine (p₂.mul a₁))
 
-theorem le_lt_combine {α} [IntModule α] [Preorder α] [IntModule.IsOrdered α] (ctx : Context α) (p₁ p₂ p₃ : Poly)
+theorem le_lt_combine {α} [IntModule α] [Preorder α] [OrderedAdd α] (ctx : Context α) (p₁ p₂ p₃ : Poly)
     : le_lt_combine_cert p₁ p₂ p₃ → p₁.denote' ctx ≤ 0 → p₂.denote' ctx < 0 → p₃.denote' ctx < 0 := by
   simp [-Int.natAbs_pos, -Int.ofNat_pos, le_lt_combine_cert]; intro hp _ h₁ h₂; subst p₃; simp
-  replace h₁ := hmul_nonpos (coe_natAbs_nonneg p₂.leadCoeff) h₁
-  replace h₂ := hmul_neg_iff (↑p₁.leadCoeff.natAbs) h₂ |>.mpr hp
+  replace h₁ := hmul_int_nonpos (coe_natAbs_nonneg p₂.leadCoeff) h₁
+  replace h₂ := hmul_int_neg_iff (↑p₁.leadCoeff.natAbs) h₂ |>.mpr hp
   exact le_add_lt h₁ h₂
 
 def lt_lt_combine_cert (p₁ p₂ p₃ : Poly) : Bool :=
@@ -294,18 +299,18 @@ def lt_lt_combine_cert (p₁ p₂ p₃ : Poly) : Bool :=
   let a₂ := p₂.leadCoeff.natAbs
   a₂ > (0 : Int) && a₁ > (0 : Int) && p₃ == (p₁.mul a₂ |>.combine (p₂.mul a₁))
 
-theorem lt_lt_combine {α} [IntModule α] [Preorder α] [IntModule.IsOrdered α] (ctx : Context α) (p₁ p₂ p₃ : Poly)
+theorem lt_lt_combine {α} [IntModule α] [Preorder α] [OrderedAdd α] (ctx : Context α) (p₁ p₂ p₃ : Poly)
     : lt_lt_combine_cert p₁ p₂ p₃ → p₁.denote' ctx < 0 → p₂.denote' ctx < 0 → p₃.denote' ctx < 0 := by
   simp [-Int.natAbs_pos, -Int.ofNat_pos, lt_lt_combine_cert]; intro hp₁ hp₂ _ h₁ h₂; subst p₃; simp
-  replace h₁ := hmul_neg_iff (↑p₂.leadCoeff.natAbs) h₁ |>.mpr hp₁
-  replace h₂ := hmul_neg_iff (↑p₁.leadCoeff.natAbs) h₂ |>.mpr hp₂
+  replace h₁ := hmul_int_neg_iff (↑p₂.leadCoeff.natAbs) h₁ |>.mpr hp₁
+  replace h₂ := hmul_int_neg_iff (↑p₁.leadCoeff.natAbs) h₂ |>.mpr hp₂
   exact lt_add_lt h₁ h₂
 
 def diseq_split_cert (p₁ p₂ : Poly) : Bool :=
   p₂ == p₁.mul (-1)
 
 -- We need `LinearOrder` to use `trichotomy`
-theorem diseq_split {α} [IntModule α] [LinearOrder α] [IntModule.IsOrdered α] (ctx : Context α) (p₁ p₂ : Poly)
+theorem diseq_split {α} [IntModule α] [LinearOrder α] [OrderedAdd α] (ctx : Context α) (p₁ p₂ : Poly)
     : diseq_split_cert p₁ p₂ → p₁.denote' ctx ≠ 0 → p₁.denote' ctx < 0 ∨ p₂.denote' ctx < 0 := by
   simp [diseq_split_cert]; intro _ h₁; subst p₂; simp
   cases LinearOrder.trichotomy (p₁.denote ctx) 0
@@ -315,7 +320,7 @@ theorem diseq_split {α} [IntModule α] [LinearOrder α] [IntModule.IsOrdered α
     simp [h₁] at h
     rw [← neg_pos_iff, neg_hmul, neg_neg, one_hmul]; assumption
 
-theorem diseq_split_resolve {α} [IntModule α] [LinearOrder α] [IntModule.IsOrdered α] (ctx : Context α) (p₁ p₂ : Poly)
+theorem diseq_split_resolve {α} [IntModule α] [LinearOrder α] [OrderedAdd α] (ctx : Context α) (p₁ p₂ : Poly)
     : diseq_split_cert p₁ p₂ → p₁.denote' ctx ≠ 0 → ¬p₁.denote' ctx < 0 → p₂.denote' ctx < 0 := by
   intro h₁ h₂ h₃
   exact (diseq_split ctx p₁ p₂ h₁ h₂).resolve_left h₃
@@ -331,7 +336,7 @@ theorem eq_norm {α} [IntModule α] (ctx : Context α) (lhs rhs : Expr) (p : Pol
     : norm_cert lhs rhs p → lhs.denote ctx = rhs.denote ctx → p.denote' ctx = 0 := by
   simp [norm_cert]; intro _ h₁; subst p; simp [Expr.denote, h₁, sub_self]
 
-theorem le_of_eq {α} [IntModule α] [Preorder α] [IntModule.IsOrdered α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
+theorem le_of_eq {α} [IntModule α] [Preorder α] [OrderedAdd α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
     : norm_cert lhs rhs p → lhs.denote ctx = rhs.denote ctx → p.denote' ctx ≤ 0 := by
   simp [norm_cert]; intro _ h₁; subst p; simp [Expr.denote, h₁, sub_self]
   apply Preorder.le_refl
@@ -344,21 +349,21 @@ theorem diseq_norm {α} [IntModule α] (ctx : Context α) (lhs rhs : Expr) (p :
   rw [add_left_comm, ← sub_eq_add_neg, sub_self, add_zero] at h
   contradiction
 
-theorem le_norm {α} [IntModule α] [Preorder α] [IntModule.IsOrdered α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
+theorem le_norm {α} [IntModule α] [Preorder α] [OrderedAdd α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
     : norm_cert lhs rhs p → lhs.denote ctx ≤ rhs.denote ctx → p.denote' ctx ≤ 0 := by
   simp [norm_cert]; intro _ h₁; subst p; simp [Expr.denote]
   replace h₁ := add_le_left h₁ (-rhs.denote ctx)
   simp [← sub_eq_add_neg, sub_self] at h₁
   assumption
 
-theorem lt_norm {α} [IntModule α] [Preorder α] [IntModule.IsOrdered α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
+theorem lt_norm {α} [IntModule α] [Preorder α] [OrderedAdd α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
     : norm_cert lhs rhs p → lhs.denote ctx < rhs.denote ctx → p.denote' ctx < 0 := by
   simp [norm_cert]; intro _ h₁; subst p; simp [Expr.denote]
   replace h₁ := add_lt_left h₁ (-rhs.denote ctx)
   simp [← sub_eq_add_neg, sub_self] at h₁
   assumption
 
-theorem not_le_norm {α} [IntModule α] [LinearOrder α] [IntModule.IsOrdered α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
+theorem not_le_norm {α} [IntModule α] [LinearOrder α] [OrderedAdd α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
     : norm_cert rhs lhs p → ¬ lhs.denote ctx ≤ rhs.denote ctx → p.denote' ctx < 0 := by
   simp [norm_cert]; intro _ h₁; subst p; simp [Expr.denote]
   replace h₁ := LinearOrder.lt_of_not_le h₁
@@ -366,7 +371,7 @@ theorem not_le_norm {α} [IntModule α] [LinearOrder α] [IntModule.IsOrdered α
   simp [← sub_eq_add_neg, sub_self] at h₁
   assumption
 
-theorem not_lt_norm {α} [IntModule α] [LinearOrder α] [IntModule.IsOrdered α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
+theorem not_lt_norm {α} [IntModule α] [LinearOrder α] [OrderedAdd α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
     : norm_cert rhs lhs p → ¬ lhs.denote ctx < rhs.denote ctx → p.denote' ctx ≤ 0 := by
   simp [norm_cert]; intro _ h₁; subst p; simp [Expr.denote]
   replace h₁ := LinearOrder.le_of_not_lt h₁
@@ -376,14 +381,14 @@ theorem not_lt_norm {α} [IntModule α] [LinearOrder α] [IntModule.IsOrdered α
 
 -- If the module does not have a linear order, we can still put the expressions in polynomial forms
 
-theorem not_le_norm' {α} [IntModule α] [Preorder α] [IntModule.IsOrdered α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
+theorem not_le_norm' {α} [IntModule α] [Preorder α] [OrderedAdd α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
     : norm_cert lhs rhs p → ¬ lhs.denote ctx ≤ rhs.denote ctx → ¬ p.denote' ctx ≤ 0 := by
   simp [norm_cert]; intro _ h₁; subst p; simp [Expr.denote]; intro h
   replace h := add_le_right (rhs.denote ctx) h
   rw [sub_eq_add_neg, add_left_comm, ← sub_eq_add_neg, sub_self] at h; simp at h
   contradiction
 
-theorem not_lt_norm' {α} [IntModule α] [Preorder α] [IntModule.IsOrdered α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
+theorem not_lt_norm' {α} [IntModule α] [Preorder α] [OrderedAdd α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
     : norm_cert lhs rhs p → ¬ lhs.denote ctx < rhs.denote ctx → ¬ p.denote' ctx < 0 := by
   simp [norm_cert]; intro _ h₁; subst p; simp [Expr.denote]; intro h
   replace h := add_lt_right (rhs.denote ctx) h
@@ -396,7 +401,7 @@ Equality detection
 def eq_of_le_ge_cert (p₁ p₂ : Poly) : Bool :=
   p₂ == p₁.mul (-1)
 
-theorem eq_of_le_ge {α} [IntModule α] [PartialOrder α] [IntModule.IsOrdered α] (ctx : Context α) (p₁ : Poly) (p₂ : Poly)
+theorem eq_of_le_ge {α} [IntModule α] [PartialOrder α] [OrderedAdd α] (ctx : Context α) (p₁ : Poly) (p₂ : Poly)
     : eq_of_le_ge_cert p₁ p₂ → p₁.denote' ctx ≤ 0 → p₂.denote' ctx ≤ 0 → p₁.denote' ctx = 0 := by
   simp [eq_of_le_ge_cert]
   intro; subst p₂; simp
@@ -420,18 +425,18 @@ theorem lt_unsat {α} [IntModule α] [Preorder α] (ctx : Context α) : (Poly.ni
 def zero_lt_one_cert (p : Poly) : Bool :=
   p == .add (-1) 0 .nil
 
-theorem zero_lt_one {α} [Ring α] [Preorder α] [Ring.IsOrdered α] (ctx : Context α) (p : Poly)
+theorem zero_lt_one {α} [Ring α] [Preorder α] [OrderedRing α] (ctx : Context α) (p : Poly)
     : zero_lt_one_cert p → (0 : Var).denote ctx = One.one → p.denote' ctx < 0 := by
   simp [zero_lt_one_cert]; intro _ h; subst p; simp [Poly.denote, h, One.one, neg_hmul]
-  rw [neg_lt_iff, neg_zero]; apply Ring.IsOrdered.zero_lt_one
+  rw [neg_lt_iff, neg_zero]; apply OrderedRing.zero_lt_one
 
 def zero_ne_one_cert (p : Poly) : Bool :=
   p == .add 1 0 .nil
 
-theorem zero_ne_one_of_ord_ring {α} [Ring α] [Preorder α] [Ring.IsOrdered α] (ctx : Context α) (p : Poly)
+theorem zero_ne_one_of_ord_ring {α} [Ring α] [Preorder α] [OrderedRing α] (ctx : Context α) (p : Poly)
     : zero_ne_one_cert p → (0 : Var).denote ctx = One.one → p.denote' ctx ≠ 0 := by
   simp [zero_ne_one_cert]; intro _ h; subst p; simp [Poly.denote, h, One.one]
-  intro h; have := Ring.IsOrdered.zero_lt_one (R := α); simp [h, Preorder.lt_irrefl] at this
+  intro h; have := OrderedRing.zero_lt_one (R := α); simp [h, Preorder.lt_irrefl] at this
 
 theorem zero_ne_one_of_field {α} [Field α] (ctx : Context α) (p : Poly)
     : zero_ne_one_cert p → (0 : Var).denote ctx = One.one → p.denote' ctx ≠ 0 := by
@@ -469,37 +474,30 @@ theorem eq_neg {α} [IntModule α] (ctx : Context α) (p₁ p₂ : Poly)
 def eq_coeff_cert (p₁ p₂ : Poly) (k : Nat) :=
   k != 0 && p₁ == p₂.mul k
 
-theorem no_nat_zero_divisors' [IntModule α] [NoNatZeroDivisors α] (k : Nat) (a : α)
-    : k ≠ 0 → k * a = 0 → a = 0 := by
-  intro h₁ h₂
-  have : k * a = (↑k : Int) * (0 : α) → a = 0 := no_nat_zero_divisors k a 0 h₁
-  rw [IntModule.hmul_zero] at this
-  exact this h₂
-
 theorem eq_coeff {α} [IntModule α] [NoNatZeroDivisors α] (ctx : Context α) (p₁ p₂ : Poly) (k : Nat)
     : eq_coeff_cert p₁ p₂ k → p₁.denote' ctx = 0 → p₂.denote' ctx = 0 := by
-  simp [eq_coeff_cert]; intro h _; subst p₁; simp [*]
-  exact no_nat_zero_divisors' k (p₂.denote ctx) h
+  simp [eq_coeff_cert]; intro h _; subst p₁; simp [*, hmul_nat]
+  exact NoNatZeroDivisors.eq_zero_of_mul_eq_zero h
 
 def coeff_cert (p₁ p₂ : Poly) (k : Nat) :=
   k > 0 && p₁ == p₂.mul k
 
-theorem le_coeff {α} [IntModule α] [LinearOrder α] [IntModule.IsOrdered α] (ctx : Context α) (p₁ p₂ : Poly) (k : Nat)
+theorem le_coeff {α} [IntModule α] [LinearOrder α] [OrderedAdd α] (ctx : Context α) (p₁ p₂ : Poly) (k : Nat)
     : coeff_cert p₁ p₂ k → p₁.denote' ctx ≤ 0 → p₂.denote' ctx ≤ 0 := by
   simp [coeff_cert]; intro h _; subst p₁; simp
   have : ↑k > (0 : Int) := Int.natCast_pos.mpr h
   intro h₁; apply Classical.byContradiction
   intro h₂; replace h₂ := LinearOrder.lt_of_not_le h₂
-  replace h₂ := IsOrdered.hmul_pos_iff (↑k) h₂ |>.mpr this
+  replace h₂ := hmul_int_pos_iff (↑k) h₂ |>.mpr this
   exact Preorder.lt_irrefl 0 (Preorder.lt_of_lt_of_le h₂ h₁)
 
-theorem lt_coeff {α} [IntModule α] [LinearOrder α] [IntModule.IsOrdered α] (ctx : Context α) (p₁ p₂ : Poly) (k : Nat)
+theorem lt_coeff {α} [IntModule α] [LinearOrder α] [OrderedAdd α] (ctx : Context α) (p₁ p₂ : Poly) (k : Nat)
     : coeff_cert p₁ p₂ k → p₁.denote' ctx < 0 → p₂.denote' ctx < 0 := by
   simp [coeff_cert]; intro h _; subst p₁; simp
   have : ↑k > (0 : Int) := Int.natCast_pos.mpr h
   intro h₁; apply Classical.byContradiction
   intro h₂; replace h₂ := LinearOrder.le_of_not_lt h₂
-  replace h₂ := IsOrdered.hmul_nonneg (Int.le_of_lt this) h₂
+  replace h₂ := hmul_int_nonneg (Int.le_of_lt this) h₂
   exact Preorder.lt_irrefl 0 (Preorder.lt_of_le_of_lt h₂ h₁)
 
 theorem diseq_neg {α} [IntModule α] (ctx : Context α) (p p' : Poly) : p' == p.mul (-1) → p.denote' ctx ≠ 0 → p'.denote' ctx ≠ 0 := by
@@ -523,8 +521,8 @@ theorem eq_diseq_subst {α} [IntModule α] [NoNatZeroDivisors α] (ctx : Context
       cases Int.natAbs_eq_iff.mp (Eq.refl k₁.natAbs)
       next h => rw [← h]; assumption
       next h => replace h := congrArg (- ·) h; simp at h; rw [← h, IntModule.neg_hmul, h₃, IntModule.neg_zero]
-    exact this
-  have := no_nat_zero_divisors' (k₁.natAbs) (p₂.denote ctx) hne this
+    simpa [hmul_nat] using this
+  have := NoNatZeroDivisors.eq_zero_of_mul_eq_zero hne this
   contradiction
 
 def eq_diseq_subst1_cert (k : Int) (p₁ p₂ p₃ : Poly) : Bool :=
@@ -544,20 +542,20 @@ def eq_le_subst_cert (x : Var) (p₁ p₂ p₃ : Poly) :=
   let b := p₂.coeff x
   a ≥ 0 && p₃ == (p₂.mul a |>.combine (p₁.mul (-b)))
 
-theorem eq_le_subst {α} [IntModule α] [Preorder α] [IntModule.IsOrdered α] (ctx : Context α) (x : Var) (p₁ p₂ p₃ : Poly)
+theorem eq_le_subst {α} [IntModule α] [Preorder α] [OrderedAdd α] (ctx : Context α) (x : Var) (p₁ p₂ p₃ : Poly)
     : eq_le_subst_cert x p₁ p₂ p₃ → p₁.denote' ctx = 0 → p₂.denote' ctx ≤ 0 → p₃.denote' ctx ≤ 0 := by
   simp [eq_le_subst_cert]; intro h _ h₁ h₂; subst p₃; simp [h₁]
-  exact hmul_nonpos h h₂
+  exact hmul_int_nonpos h h₂
 
 def eq_lt_subst_cert (x : Var) (p₁ p₂ p₃ : Poly) :=
   let a := p₁.coeff x
   let b := p₂.coeff x
   a > 0 && p₃ == (p₂.mul a |>.combine (p₁.mul (-b)))
 
-theorem eq_lt_subst {α} [IntModule α] [Preorder α] [IntModule.IsOrdered α] (ctx : Context α) (x : Var) (p₁ p₂ p₃ : Poly)
+theorem eq_lt_subst {α} [IntModule α] [Preorder α] [OrderedAdd α] (ctx : Context α) (x : Var) (p₁ p₂ p₃ : Poly)
     : eq_lt_subst_cert x p₁ p₂ p₃ → p₁.denote' ctx = 0 → p₂.denote' ctx < 0 → p₃.denote' ctx < 0 := by
   simp [eq_lt_subst_cert]; intro h _ h₁ h₂; subst p₃; simp [h₁]
-  exact IsOrdered.hmul_neg_iff (p₁.coeff x) h₂ |>.mpr h
+  exact hmul_int_neg_iff (p₁.coeff x) h₂ |>.mpr h
 
 def eq_eq_subst_cert (x : Var) (p₁ p₂ p₃ : Poly) :=
   let a := p₁.coeff x

src/Init/Grind/Ordered/Module.lean

@@ -13,35 +13,22 @@ import Init.Grind.Ordered.Order
 namespace Lean.Grind
 
 /--
-A module over the natural numbers which is also equipped with a preorder is considered an
-ordered module if addition is compatible with the preorder.
+Addition is compatible with a preorder if `a ≤ b ↔ a + c ≤ b + c`.
 -/
-class NatModule.IsOrdered (M : Type u) [Preorder M] [NatModule M] where
+class OrderedAdd (M : Type u) [HAdd M M M] [Preorder M] where
   /-- `a + c ≤ b + c` iff `a ≤ b`. -/
   add_le_left_iff : ∀ {a b : M} (c : M), a ≤ b ↔ a + c ≤ b + c
 
--- This class is actually redundant; it is available automatically when we have an
--- `IntModule` satisfying `NatModule.IsOrdered`.
--- Replace with a custom constructor?
-/--
-A module over the integers which is also equipped with a preorder is considered an
-ordered module if addition and negation are compatible with the preorder.
--/
-class IntModule.IsOrdered (M : Type u) [Preorder M] [IntModule M] where
-  /-- `-a ≤ b` iff `-b ≤ a`. -/
-  neg_le_iff : ∀ a b : M, -a ≤ b ↔ -b ≤ a
-  /-- `a + c ≤ b + c` iff `a ≤ b`. -/
-  add_le_left : ∀ {a b : M}, a ≤ b → (c : M) → a + c ≤ b + c
-  /-- -/
-  hmul_pos_iff : ∀ (k : Int) {a : M}, 0 < a → (0 < k * a ↔ 0 < k)
-  /-- -/
-  hmul_nonneg : ∀ {k : Int} {a : M}, 0 ≤ k → 0 ≤ a → 0 ≤ k * a
+class ExistsAddOfLT (α : Type u) [LT α] [Zero α] [Add α] where
+  exists_add_of_le : ∀ {a b : α}, a < b → ∃ c, 0 < c ∧ b = a + c
 
-namespace NatModule.IsOrdered
+namespace OrderedAdd
+
+open NatModule
 
 section
 
-variable {M : Type u} [Preorder M] [NatModule M] [NatModule.IsOrdered M]
+variable {M : Type u} [Preorder M] [NatModule M] [OrderedAdd M]
 
 theorem add_le_right_iff {a b : M} (c : M) : a ≤ b ↔ c + a ≤ c + b := by
   rw [add_comm c a, add_comm c b, add_le_left_iff]
@@ -121,52 +108,44 @@ end
 
 section
 
-variable {M : Type u} [Preorder M] [IntModule M] [NatModule.IsOrdered M]
+variable {M : Type u} [Preorder M] [IntModule M] [OrderedAdd M]
 
 theorem neg_le_iff {a b : M} : -a ≤ b ↔ -b ≤ a := by
-  rw [NatModule.IsOrdered.add_le_left_iff a, IntModule.neg_add_cancel]
-  conv => rhs; rw [NatModule.IsOrdered.add_le_left_iff b, IntModule.neg_add_cancel]
+  rw [OrderedAdd.add_le_left_iff a, IntModule.neg_add_cancel]
+  conv => rhs; rw [OrderedAdd.add_le_left_iff b, IntModule.neg_add_cancel]
   rw [add_comm]
 
 end
-
-end NatModule.IsOrdered
-
-namespace IntModule.IsOrdered
-
 section
 
-variable {M : Type u} [Preorder M] [IntModule M] [NatModule.IsOrdered M]
+variable {M : Type u} [Preorder M] [IntModule M] [OrderedAdd M]
 
-open NatModule.IsOrdered in
-instance : IntModule.IsOrdered M where
-  neg_le_iff a b := NatModule.IsOrdered.neg_le_iff
-  add_le_left := NatModule.IsOrdered.add_le_left
-  hmul_pos_iff k x :=
-    match k with
-    | (k + 1 : Nat) => by
-      intro h
-      have := hmul_lt_hmul_iff (k := k + 1) h
-      simpa [NatModule.hmul_zero] using hmul_lt_hmul_iff (k := k + 1) h
-    | (0 : Nat) => by simp [zero_hmul]; intro h; exact Preorder.lt_irrefl 0
-    | -(k + 1 : Nat) => by
-      intro h
-      have : ¬ (k : Int) + 1 < 0 := by omega
-      simp [this]; clear this
-      rw [neg_hmul]
-      rw [Preorder.lt_iff_le_not_le]
-      simp
-      intro h'
-      rw [NatModule.IsOrdered.neg_le_iff, neg_zero]
-      simpa [NatModule.hmul_zero] using hmul_le_hmul (k := k + 1) (Preorder.le_of_lt h)
-  hmul_nonneg {k a} h :=
-    match k, h with
-    | (k : Nat), _ => by
-      simpa using NatModule.IsOrdered.hmul_nonneg
+theorem hmul_int_pos_iff (k : Int) {x : M} (h : 0 < x) : 0 < k * x ↔ 0 < k :=
+  match k with
+  | (k + 1 : Nat) => by
+    simpa [IntModule.hmul_zero, ← IntModule.hmul_nat] using hmul_lt_hmul_iff (k := k + 1) h
+  | (0 : Nat) => by simp [IntModule.zero_hmul]; exact Preorder.lt_irrefl 0
+  | -(k + 1 : Nat) => by
+    have : ¬ (k : Int) + 1 < 0 := by omega
+    simp [this]; clear this
+    rw [IntModule.neg_hmul]
+    rw [Preorder.lt_iff_le_not_le]
+    simp
+    intro h'
+    rw [OrderedAdd.neg_le_iff, IntModule.neg_zero]
+    simpa [IntModule.hmul_zero, ← IntModule.hmul_nat] using
+      hmul_le_hmul (k := k + 1) (Preorder.le_of_lt h)
+
+theorem hmul_int_nonneg {k : Int} {x : M} (h : 0 ≤ k) (hx : 0 ≤ x) : 0 ≤ k * x :=
+  match k, h with
+  | (k : Nat), _ => by
+    simpa [IntModule.hmul_nat] using OrderedAdd.hmul_nonneg hx
 
 end
 
-variable {M : Type u} [Preorder M] [IntModule M] [IntModule.IsOrdered M]
+variable {M : Type u} [Preorder M] [IntModule M] [OrderedAdd M]
+
+open IntModule
 
 theorem le_neg_iff {a b : M} : a ≤ -b ↔ b ≤ -a := by
   conv => lhs; rw [← neg_neg a]
@@ -186,89 +165,33 @@ theorem neg_nonneg_iff {a : M} : 0 ≤ -a ↔ a ≤ 0 := by
 theorem neg_pos_iff {a : M} : 0 < -a ↔ a < 0 := by
   rw [lt_neg_iff, neg_zero]
 
-theorem add_lt_left {a b : M} (h : a < b) (c : M) : a + c < b + c := by
-  simp only [Preorder.lt_iff_le_not_le] at h ⊢
-  constructor
-  · exact add_le_left h.1 _
-  · intro w
-    apply h.2
-    replace w := add_le_left w (-c)
-    rw [add_assoc, add_assoc, add_neg_cancel, add_zero, add_zero] at w
-    exact w
-
-theorem add_le_right (a : M) {b c : M} (h : b ≤ c) : a + b ≤ a + c := by
-  rw [add_comm a b, add_comm a c]
-  exact add_le_left h a
-
-theorem add_lt_right (a : M) {b c : M} (h : b < c) : a + b < a + c := by
-  rw [add_comm a b, add_comm a c]
-  exact add_lt_left h a
-
-theorem add_le_left_iff {a b : M} (c : M) : a ≤ b ↔ a + c ≤ b + c := by
-  constructor
-  · intro w
-    exact add_le_left w c
-  · intro w
-    have := add_le_left w (-c)
-    rwa [add_assoc, add_neg_cancel, add_zero, add_assoc, add_neg_cancel, add_zero] at this
-
-theorem add_le_right_iff {a b : M} (c : M) : a ≤ b ↔ c + a ≤ c + b := by
-  constructor
-  · intro w
-    exact add_le_right c w
-  · intro w
-    have := add_le_right (-c) w
-    rwa [← add_assoc, neg_add_cancel, zero_add, ← add_assoc, neg_add_cancel, zero_add] at this
-
-theorem add_lt_left_iff {a b : M} (c : M) : a < b ↔ a + c < b + c := by
-  constructor
-  · intro w
-    exact add_lt_left w c
-  · intro w
-    have := add_lt_left w (-c)
-    rwa [add_assoc, add_neg_cancel, add_zero, add_assoc, add_neg_cancel, add_zero] at this
-
-theorem add_lt_right_iff {a b : M} (c : M) : a < b ↔ c + a < c + b := by
-  constructor
-  · intro w
-    exact add_lt_right c w
-  · intro w
-    have := add_lt_right (-c) w
-    rwa [← add_assoc, neg_add_cancel, zero_add, ← add_assoc, neg_add_cancel, zero_add] at this
-
 theorem sub_nonneg_iff {a b : M} : 0 ≤ a - b ↔ b ≤ a := by
-  rw [add_le_left_iff b, zero_add, sub_add_cancel]
+  rw [add_le_left_iff b, IntModule.zero_add, sub_add_cancel]
 
 theorem sub_pos_iff {a b : M} : 0 < a - b ↔ b < a := by
-  rw [add_lt_left_iff b, zero_add, sub_add_cancel]
+  rw [add_lt_left_iff b, IntModule.zero_add, sub_add_cancel]
 
-theorem hmul_neg_iff (k : Int) {a : M} (h : a < 0) : k * a < 0 ↔ 0 < k := by
-  simpa [IntModule.hmul_neg, neg_pos_iff] using hmul_pos_iff k (neg_pos_iff.mpr h)
+theorem hmul_int_neg_iff (k : Int) {a : M} (h : a < 0) : k * a < 0 ↔ 0 < k := by
+  simpa [IntModule.hmul_neg, neg_pos_iff] using hmul_int_pos_iff k (neg_pos_iff.mpr h)
 
-theorem hmul_nonpos {k : Int} {a : M} (hk : 0 ≤ k) (ha : a ≤ 0) : k * a ≤ 0 := by
-  simpa [IntModule.hmul_neg, neg_nonneg_iff] using hmul_nonneg hk (neg_nonneg_iff.mpr ha)
+theorem hmul_int_nonpos {k : Int} {a : M} (hk : 0 ≤ k) (ha : a ≤ 0) : k * a ≤ 0 := by
+  simpa [IntModule.hmul_neg, neg_nonneg_iff] using hmul_int_nonneg hk (neg_nonneg_iff.mpr ha)
 
-theorem hmul_le_hmul {a b : M} {k : Int} (hk : 0 ≤ k) (h : a ≤ b) : k * a ≤ k * b := by
-  simpa [hmul_sub, sub_nonneg_iff] using hmul_nonneg hk (sub_nonneg_iff.mpr h)
+theorem hmul_int_le_hmul_int {a b : M} {k : Int} (hk : 0 ≤ k) (h : a ≤ b) : k * a ≤ k * b := by
+  simpa [hmul_sub, sub_nonneg_iff] using hmul_int_nonneg hk (sub_nonneg_iff.mpr h)
 
-theorem hmul_lt_hmul_iff (k : Int) {a b : M} (h : a < b) : k * a < k * b ↔ 0 < k := by
-  simpa [hmul_sub, sub_pos_iff] using hmul_pos_iff k (sub_pos_iff.mpr h)
+theorem hmul_int_lt_hmul_int_iff (k : Int) {a b : M} (h : a < b) : k * a < k * b ↔ 0 < k := by
+  simpa [hmul_sub, sub_pos_iff] using hmul_int_pos_iff k (sub_pos_iff.mpr h)
 
-theorem hmul_le_hmul_of_le_of_le_of_nonneg_of_nonneg
+theorem hmul_int_le_hmul_int_of_le_of_le_of_nonneg_of_nonneg
     {k₁ k₂ : Int} {x y : M} (hk : k₁ ≤ k₂) (h : x ≤ y) (w : 0 ≤ k₁) (w' : 0 ≤ x) :
     k₁ * x ≤ k₂ * y := by
   apply Preorder.le_trans
-  · have : 0 ≤ k₁ * (y - x) := hmul_nonneg w (sub_nonneg_iff.mpr h)
+  · have : 0 ≤ k₁ * (y - x) := hmul_int_nonneg w (sub_nonneg_iff.mpr h)
     rwa [IntModule.hmul_sub, sub_nonneg_iff] at this
-  · have : 0 ≤ (k₂ - k₁) * y := hmul_nonneg (Int.sub_nonneg.mpr hk) (Preorder.le_trans w' h)
+  · have : 0 ≤ (k₂ - k₁) * y := hmul_int_nonneg (Int.sub_nonneg.mpr hk) (Preorder.le_trans w' h)
     rwa [IntModule.sub_hmul, sub_nonneg_iff] at this
 
-theorem add_le_add {a b c d : M} (hab : a ≤ b) (hcd : c ≤ d) : a + c ≤ b + d :=
-  Preorder.le_trans (add_le_right a hcd) (add_le_left hab d)
-
-instance : NatModule.IsOrdered M where
-  add_le_left_iff := add_le_left_iff
-
-end IntModule.IsOrdered
+end OrderedAdd
 
 end Lean.Grind

src/Init/Grind/Ordered/Ring.lean

@@ -15,7 +15,7 @@ namespace Lean.Grind
 A ring which is also equipped with a preorder is considered a strict ordered ring if addition, negation,
 and multiplication are compatible with the preorder, and `0 < 1`.
 -/
-class Ring.IsOrdered (R : Type u) [Ring R] [Preorder R] extends IntModule.IsOrdered R where
+class OrderedRing (R : Type u) [Semiring R] [Preorder R] extends OrderedAdd R where
   /-- In a strict ordered semiring, we have `0 < 1`. -/
   zero_lt_one : (0 : R) < 1
   /-- In a strict ordered semiring, we can multiply an inequality `a < b` on the left
@@ -25,17 +25,17 @@ class Ring.IsOrdered (R : Type u) [Ring R] [Preorder R] extends IntModule.IsOrde
   by a positive element `0 < c` to obtain `a * c < b * c`. -/
   mul_lt_mul_of_pos_right : ∀ {a b c : R}, a < b → 0 < c → a * c < b * c
 
-namespace Ring.IsOrdered
+namespace OrderedRing
 
 variable {R : Type u} [Ring R]
 
 section Preorder
 
-variable [Preorder R] [Ring.IsOrdered R]
+variable [Preorder R] [OrderedRing R]
 
 theorem neg_one_lt_zero : (-1 : R) < 0 := by
   have h := zero_lt_one (R := R)
-  have := IntModule.IsOrdered.add_lt_left h (-1)
+  have := OrderedAdd.add_lt_left h (-1)
   rw [Semiring.zero_add, Ring.add_neg_cancel] at this
   assumption
 
@@ -43,14 +43,14 @@ theorem ofNat_nonneg (x : Nat) : (OfNat.ofNat x : R) ≥ 0 := by
   induction x
   next => simp [OfNat.ofNat, Zero.zero]; apply Preorder.le_refl
   next n ih =>
-    have := Ring.IsOrdered.zero_lt_one (R := R)
+    have := OrderedRing.zero_lt_one (R := R)
     rw [Semiring.ofNat_succ]
-    replace ih := IntModule.IsOrdered.add_le_left ih 1
+    replace ih := OrderedAdd.add_le_left ih 1
     rw [Semiring.zero_add] at ih
     have := Preorder.lt_of_lt_of_le this ih
     exact Preorder.le_of_lt this
 
-instance [Ring α] [Preorder α] [Ring.IsOrdered α] : IsCharP α 0 := IsCharP.mk' _ _ <| by
+instance [Ring α] [Preorder α] [OrderedRing α] : IsCharP α 0 := IsCharP.mk' _ _ <| by
   intro x
   simp only [Nat.mod_zero]; constructor
   next =>
@@ -63,9 +63,9 @@ instance [Ring α] [Preorder α] [Ring.IsOrdered α] : IsCharP α 0 := IsCharP.m
       rw [Ring.sub_eq_add_neg, Semiring.add_assoc, Ring.add_neg_cancel,
           Ring.sub_eq_add_neg, Semiring.zero_add, Semiring.add_zero] at h
       have h₁ : (OfNat.ofNat x : α) < 0 := by
-        have := Ring.IsOrdered.neg_one_lt_zero (R := α)
+        have := OrderedRing.neg_one_lt_zero (R := α)
         rw [h]; assumption
-      have h₂ := Ring.IsOrdered.ofNat_nonneg (R := α) x
+      have h₂ := OrderedRing.ofNat_nonneg (R := α) x
       have : (0 : α) < 0 := Preorder.lt_of_le_of_lt h₂ h₁
       simp
       exact (Preorder.lt_irrefl 0) this
@@ -75,7 +75,7 @@ end Preorder
 
 section PartialOrder
 
-variable [PartialOrder R] [Ring.IsOrdered R]
+variable [PartialOrder R] [OrderedRing R]
 
 theorem zero_le_one : (0 : R) ≤ 1 := Preorder.le_of_lt zero_lt_one
 
@@ -104,57 +104,59 @@ theorem mul_le_mul_of_nonneg_right {a b c : R} (h : a ≤ b) (h' : 0 ≤ c) : a
     | inr h => subst h; exact Preorder.le_refl (a * c)
   | inr h' => subst h'; simp [Semiring.mul_zero, Preorder.le_refl]
 
+open OrderedAdd
+
 theorem mul_le_mul_of_nonpos_left {a b c : R} (h : a ≤ b) (h' : c ≤ 0) : c * b ≤ c * a := by
-  have := mul_le_mul_of_nonneg_left h (IntModule.IsOrdered.neg_nonneg_iff.mpr h')
-  rwa [Ring.neg_mul, Ring.neg_mul, IntModule.IsOrdered.neg_le_iff, IntModule.neg_neg] at this
+  have := mul_le_mul_of_nonneg_left h (neg_nonneg_iff.mpr h')
+  rwa [Ring.neg_mul, Ring.neg_mul, neg_le_iff, IntModule.neg_neg] at this
 
 theorem mul_le_mul_of_nonpos_right {a b c : R} (h : a ≤ b) (h' : c ≤ 0) : b * c ≤ a * c := by
-  have := mul_le_mul_of_nonneg_right h (IntModule.IsOrdered.neg_nonneg_iff.mpr h')
-  rwa [Ring.mul_neg, Ring.mul_neg, IntModule.IsOrdered.neg_le_iff, IntModule.neg_neg] at this
+  have := mul_le_mul_of_nonneg_right h (neg_nonneg_iff.mpr h')
+  rwa [Ring.mul_neg, Ring.mul_neg, neg_le_iff, IntModule.neg_neg] at this
 
 theorem mul_lt_mul_of_neg_left {a b c : R} (h : a < b) (h' : c < 0) : c * b < c * a := by
-  have := mul_lt_mul_of_pos_left h (IntModule.IsOrdered.neg_pos_iff.mpr h')
-  rwa [Ring.neg_mul, Ring.neg_mul, IntModule.IsOrdered.neg_lt_iff, IntModule.neg_neg] at this
+  have := mul_lt_mul_of_pos_left h (neg_pos_iff.mpr h')
+  rwa [Ring.neg_mul, Ring.neg_mul, neg_lt_iff, IntModule.neg_neg] at this
 
 theorem mul_lt_mul_of_neg_right {a b c : R} (h : a < b) (h' : c < 0) : b * c < a * c := by
-  have := mul_lt_mul_of_pos_right h (IntModule.IsOrdered.neg_pos_iff.mpr h')
-  rwa [Ring.mul_neg, Ring.mul_neg, IntModule.IsOrdered.neg_lt_iff, IntModule.neg_neg] at this
+  have := mul_lt_mul_of_pos_right h (neg_pos_iff.mpr h')
+  rwa [Ring.mul_neg, Ring.mul_neg, neg_lt_iff, IntModule.neg_neg] at this
 
 theorem mul_nonneg {a b : R} (h₁ : 0 ≤ a) (h₂ : 0 ≤ b) : 0 ≤ a * b := by
   simpa [Semiring.zero_mul] using mul_le_mul_of_nonneg_right h₁ h₂
 
 theorem mul_nonneg_of_nonpos_of_nonpos {a b : R} (h₁ : a ≤ 0) (h₂ : b ≤ 0) : 0 ≤ a * b := by
-  have := mul_nonneg (IntModule.IsOrdered.neg_nonneg_iff.mpr h₁) (IntModule.IsOrdered.neg_nonneg_iff.mpr h₂)
+  have := mul_nonneg (neg_nonneg_iff.mpr h₁) (neg_nonneg_iff.mpr h₂)
   simpa [Ring.neg_mul, Ring.mul_neg, Ring.neg_neg] using this
 
 theorem mul_nonpos_of_nonneg_of_nonpos {a b : R} (h₁ : 0 ≤ a) (h₂ : b ≤ 0) : a * b ≤ 0 := by
-  rw [← IntModule.IsOrdered.neg_nonneg_iff, ← Ring.mul_neg]
-  apply mul_nonneg h₁ (IntModule.IsOrdered.neg_nonneg_iff.mpr h₂)
+  rw [← neg_nonneg_iff, ← Ring.mul_neg]
+  apply mul_nonneg h₁ (neg_nonneg_iff.mpr h₂)
 
 theorem mul_nonpos_of_nonpos_of_nonneg {a b : R} (h₁ : a ≤ 0) (h₂ : 0 ≤ b) : a * b ≤ 0 := by
-  rw [← IntModule.IsOrdered.neg_nonneg_iff, ← Ring.neg_mul]
-  apply mul_nonneg (IntModule.IsOrdered.neg_nonneg_iff.mpr h₁) h₂
+  rw [← neg_nonneg_iff, ← Ring.neg_mul]
+  apply mul_nonneg (neg_nonneg_iff.mpr h₁) h₂
 
 theorem mul_pos {a b : R} (h₁ : 0 < a) (h₂ : 0 < b) : 0 < a * b := by
   simpa [Semiring.zero_mul] using mul_lt_mul_of_pos_right h₁ h₂
 
 theorem mul_pos_of_neg_of_neg {a b : R} (h₁ : a < 0) (h₂ : b < 0) : 0 < a * b := by
-  have := mul_pos (IntModule.IsOrdered.neg_pos_iff.mpr h₁) (IntModule.IsOrdered.neg_pos_iff.mpr h₂)
+  have := mul_pos (neg_pos_iff.mpr h₁) (neg_pos_iff.mpr h₂)
   simpa [Ring.neg_mul, Ring.mul_neg, Ring.neg_neg] using this
 
 theorem mul_neg_of_pos_of_neg {a b : R} (h₁ : 0 < a) (h₂ : b < 0) : a * b < 0 := by
-  rw [← IntModule.IsOrdered.neg_pos_iff, ← Ring.mul_neg]
-  apply mul_pos h₁ (IntModule.IsOrdered.neg_pos_iff.mpr h₂)
+  rw [← neg_pos_iff, ← Ring.mul_neg]
+  apply mul_pos h₁ (neg_pos_iff.mpr h₂)
 
 theorem mul_neg_of_neg_of_pos {a b : R} (h₁ : a < 0) (h₂ : 0 < b) : a * b < 0 := by
-  rw [← IntModule.IsOrdered.neg_pos_iff, ← Ring.neg_mul]
-  apply mul_pos (IntModule.IsOrdered.neg_pos_iff.mpr h₁) h₂
+  rw [← neg_pos_iff, ← Ring.neg_mul]
+  apply mul_pos (neg_pos_iff.mpr h₁) h₂
 
 end PartialOrder
 
 section LinearOrder
 
-variable [LinearOrder R] [Ring.IsOrdered R]
+variable [LinearOrder R] [OrderedRing R]
 
 theorem mul_nonneg_iff {a b : R} : 0 ≤ a * b ↔ 0 ≤ a ∧ 0 ≤ b ∨ a ≤ 0 ∧ b ≤ 0 := by
   rcases LinearOrder.trichotomy 0 a with (ha | rfl | ha)
@@ -203,6 +205,6 @@ theorem sq_pos {a : R} (h : a ≠ 0) : 0 < a^2 := by
 
 end LinearOrder
 
-end Ring.IsOrdered
+end OrderedRing
 
 end Lean.Grind

src/Init/Grind/Ring/Basic.lean

@@ -125,6 +125,9 @@ attribute [instance 100] Semiring.ofNat
 
 attribute [local instance] Semiring.natCast Ring.intCast
 
+-- Verify that the diamond from `CommRing` to `Semiring` via either `CommSemiring` or `Ring` is defeq.
+example [CommRing α] : (CommSemiring.toSemiring : Semiring α) = (Ring.toSemiring : Semiring α) := rfl
+
 namespace Semiring
 
 variable {α : Type u} [Semiring α]
@@ -167,6 +170,11 @@ theorem pow_add (a : α) (k₁ k₂ : Nat) : a ^ (k₁ + k₂) = a^k₁ * a^k₂
   next => simp [pow_zero, mul_one]
   next k₂ ih => rw [Nat.add_succ, pow_succ, pow_succ, ih, mul_assoc]
 
+theorem natCast_pow (x : Nat) (k : Nat) : ((x ^ k : Nat) : α) = (x : α) ^ k := by
+  induction k
+  next => simp [pow_zero, Nat.pow_zero, natCast_one]
+  next k ih => simp [pow_succ, Nat.pow_succ, natCast_mul, *]
+
 instance : NatModule α where
   hMul a x := a * x
   add_zero := by simp [add_zero]
@@ -334,7 +342,11 @@ theorem intCast_pow (x : Int) (k : Nat) : ((x ^ k : Int) : α) = (x : α) ^ k :=
   next k ih => simp [pow_succ, Int.pow_succ, intCast_mul, *]
 
 instance : IntModule α where
-  hMul a x := a * x
+  hmulInt := ⟨fun a x => a * x⟩
+  hmulNat := ⟨fun a x => a * x⟩
+  hmul_nat n x := by
+    change ((n : Int) : α) * x = (n : α) * x
+    rw [intCast_natCast]
   add_zero := by simp [add_zero]
   add_assoc := by simp [add_assoc]
   add_comm := by simp [add_comm]
@@ -348,6 +360,9 @@ instance : IntModule α where
 
 theorem hmul_eq_intCast_mul {α} [Ring α] {k : Int} {a : α} : HMul.hMul (α := Int) k a = (k : α) * a := rfl
 
+-- Verify that the diamond from `Ring` to `NatModule` via either `Semiring` or `IntModule` is defeq.
+example [Ring R] : (Semiring.instNatModule : NatModule R) = (IntModule.toNatModule R) := rfl
+
 end Ring
 
 namespace CommSemiring
@@ -517,23 +532,22 @@ end Ring
 
 end IsCharP
 
--- TODO: This should be generalizable to any `IntModule α`, not just `Ring α`.
-theorem no_int_zero_divisors {α : Type u} [Ring α] [NoNatZeroDivisors α] {k : Int} {a : α}
+theorem no_int_zero_divisors {α : Type u} [IntModule α] [NoNatZeroDivisors α] {k : Int} {a : α}
     : k ≠ 0 → k * a = 0 → a = 0 := by
   match k with
   | (k : Nat) =>
-    simp [intCast_natCast]
+    simp only [ne_eq, Int.natCast_eq_zero]
     intro h₁ h₂
     replace h₁ : k ≠ 0 := by intro h; simp [h] at h₁
-    replace h₂ : k * a = k * 0 := by simp [mul_zero, h₂]
-    exact no_nat_zero_divisors k a 0 h₁ h₂
+    rw [IntModule.hmul_nat] at h₂
+    exact NoNatZeroDivisors.eq_zero_of_mul_eq_zero h₁ h₂
   | -(k+1 : Nat) =>
-    rw [Int.natCast_add, ← Int.natCast_add, intCast_neg, intCast_natCast]
+    rw [IntModule.neg_hmul]
     intro _ h
-    replace h := congrArg (-·) h; simp at h
-    rw [← neg_mul, neg_neg, neg_zero, ← hmul_eq_natCast_mul] at h
-    replace h : (k + 1 : Nat) * a = (k + 1 : Nat) * 0 := by
-      simp [mul_zero]; exact h
-    exact no_nat_zero_divisors (k+1) a 0 (Nat.succ_ne_zero _) h
+    replace h := congrArg (-·) h
+    dsimp only at h
+    rw [IntModule.neg_neg, IntModule.neg_zero] at h
+    rw [IntModule.hmul_nat] at h
+    exact NoNatZeroDivisors.eq_zero_of_mul_eq_zero (Nat.succ_ne_zero _) h
 
 end Lean.Grind

src/Init/Grind/Ring/Envelope.lean

@@ -7,6 +7,7 @@ module
 
 prelude
 import Init.Grind.Ring.Basic
+import Init.Grind.Ordered.Ring
 import all Init.Data.AC
 
 namespace Lean.Grind.Ring
@@ -98,6 +99,9 @@ def Q.liftOn₂ (q₁ q₂ : Q α)
 
 attribute [local simp] Q.mk Q.liftOn₂
 
+def Q.ind {β : Q α → Prop} (mk : ∀ (a : α × α), β (Q.mk a)) (q : Q α) : β q :=
+  Quot.ind mk q
+
 @[local simp] def natCast (n : Nat) : Q α :=
   Q.mk (n, 0)
 
@@ -242,18 +246,28 @@ def ofSemiring : Ring (Q α) := {
   intCast_neg, ofNat_succ
 }
 
-attribute [local instance] ofSemiring
+attribute [instance] ofSemiring
+
+@[local simp] private theorem mk_add_mk {a₁ a₂ b₁ b₂ : α} :
+    Q.mk (a₁, a₂) + Q.mk (b₁, b₂) = Q.mk (a₁ + b₁, a₂ + b₂) := by
+  rfl
+
+@[local simp] private theorem mk_mul_mk {a₁ a₂ b₁ b₂ : α} :
+    Q.mk (a₁, a₂) * Q.mk (b₁, b₂) = Q.mk (a₁*b₁ + a₂*b₂, a₁*b₂ + a₂*b₁) := by
+  rfl
 
 @[local simp] def toQ (a : α) : Q α :=
   Q.mk (a, 0)
 
+attribute [-simp] Q.mk
+
 /-! Embedding theorems -/
 
 theorem toQ_add (a b : α) : toQ (a + b) = toQ a + toQ b := by
-  simp; apply Quot.sound; simp
+  simp
 
 theorem toQ_mul (a b : α) : toQ (a * b) = toQ a * toQ b := by
-  simp; apply Quot.sound; simp
+  simp
 
 theorem toQ_natCast (n : Nat) : toQ (natCast (α := α) n) = natCast n := by
   simp; apply Quot.sound; simp; refine ⟨0, ?_⟩; rfl
@@ -298,6 +312,159 @@ theorem toQ_inj [AddRightCancel α] {a b : α} : toQ a = toQ b → a = b := by
   obtain ⟨k, h₁⟩ := h₁
   exact AddRightCancel.add_right_cancel a b k h₁
 
+instance [Semiring α] [AddRightCancel α] [NoNatZeroDivisors α] : NoNatZeroDivisors (OfSemiring.Q α) where
+  no_nat_zero_divisors := by
+    intro k a b h₁ h₂
+    replace h₂ : mul (natCast k) a = mul (natCast k) b := h₂
+    induction a using Quot.ind
+    induction b using Quot.ind
+    next a b =>
+    rcases a with ⟨a₁, a₂⟩
+    rcases b with ⟨b₁, b₂⟩
+    simp [mul] at h₂
+    replace h₂ := Q.exact h₂
+    simp [r] at h₂
+    rcases h₂ with ⟨k', h₂⟩
+    replace h₂ := AddRightCancel.add_right_cancel _ _ _ h₂
+    simp [← Semiring.left_distrib] at h₂
+    replace h₂ := NoNatZeroDivisors.no_nat_zero_divisors k (a₁ + b₂) (a₂ + b₁) h₁ h₂
+    apply Quot.sound; simp [r]; exists 0; simp [h₂]
+
+instance {p} [Semiring α] [AddRightCancel α] [IsCharP α p] : IsCharP (OfSemiring.Q α) p where
+  ofNat_ext_iff := by
+    intro x y
+    constructor
+    next =>
+      intro h
+      replace h : natCast x = natCast y := h; simp at h
+      replace h := Q.exact h; simp [r] at h
+      rcases h with ⟨k, h⟩
+      replace h : OfNat.ofNat (α := α) x = OfNat.ofNat y := by
+        replace h := AddRightCancel.add_right_cancel _ _ _ h
+        simp [Semiring.ofNat_eq_natCast, h]
+      have := IsCharP.ofNat_ext_iff p |>.mp h
+      simp at this; assumption
+    next =>
+      intro h
+      have := IsCharP.ofNat_ext_iff (α := α) p |>.mpr h
+      apply Quot.sound
+      exists 0; simp [← Semiring.ofNat_eq_natCast, this]
+
+instance [Preorder α] [OrderedAdd α] : LE (OfSemiring.Q α) where
+  le a b := Q.liftOn₂ a b (fun (a, b) (c, d) => a + d ≤ b + c)
+    (by intro (a₁, b₁) (a₂, b₂) (a₃, b₃) (a₄, b₄)
+        simp; intro k₁ h₁ k₂ h₂
+        rw [OrderedAdd.add_le_left_iff (b₃ + k₁)]
+        have : a₁ + b₂ + (b₃ + k₁) = a₁ + b₃ + k₁ + b₂ := by ac_rfl
+        rw [this, h₁]; clear this
+        rw [OrderedAdd.add_le_left_iff (a₄ + k₂)]
+        have : b₁ + a₃ + k₁ + b₂ + (a₄ + k₂) = b₂ + a₄ + k₂ + b₁ + a₃ + k₁ := by ac_rfl
+        rw [this, ← h₂]; clear this
+        have : a₂ + b₄ + k₂ + b₁ + a₃ + k₁ = a₃ + b₄ + (a₂ + b₁ + k₁ + k₂) := by ac_rfl
+        rw [this]; clear this
+        have : b₁ + a₂ + (b₃ + k₁) + (a₄ + k₂) = b₃ + a₄ + (a₂ + b₁ + k₁ + k₂) := by ac_rfl
+        rw [this]; clear this
+        rw [← OrderedAdd.add_le_left_iff])
+
+@[local simp] theorem mk_le_mk [Preorder α] [OrderedAdd α] {a₁ a₂ b₁ b₂ : α}  :
+    Q.mk (a₁, a₂) ≤ Q.mk (b₁, b₂) ↔ a₁ + b₂ ≤ a₂ + b₁ := by
+  rfl
+
+instance [Preorder α] [OrderedAdd α] : Preorder (OfSemiring.Q α) where
+  le_refl a := by
+    induction a using Quot.ind
+    next a =>
+    rcases a with ⟨a₁, a₂⟩
+    change Q.mk _ ≤ Q.mk _
+    simp only [mk_le_mk]
+    simp [Semiring.add_comm]; exact Preorder.le_refl (a₁ + a₂)
+  le_trans {a b c} h₁ h₂ := by
+    induction a using Q.ind
+    induction b using Q.ind
+    induction c using Q.ind
+    next a b c =>
+    rcases a with ⟨a₁, a₂⟩; rcases b with ⟨b₁, b₂⟩; rcases c with ⟨c₁, c₂⟩
+    simp only [mk_le_mk] at h₁ h₂ ⊢
+    rw [OrderedAdd.add_le_left_iff (b₁ + b₂)]
+    have : a₁ + c₂ + (b₁ + b₂) = a₁ + b₂ + (b₁ + c₂) := by ac_rfl
+    rw [this]; clear this
+    have : a₂ + c₁ + (b₁ + b₂) = a₂ + b₁ + (b₂ + c₁) := by ac_rfl
+    rw [this]; clear this
+    exact OrderedAdd.add_le_add h₁ h₂
+
+@[local simp] private theorem mk_lt_mk [Preorder α] [OrderedAdd α] {a₁ a₂ b₁ b₂ : α}  :
+    Q.mk (a₁, a₂) < Q.mk (b₁, b₂) ↔ a₁ + b₂ < a₂ + b₁ := by
+  simp [Preorder.lt_iff_le_not_le, Semiring.add_comm]
+
+@[local simp] private theorem mk_pos [Preorder α] [OrderedAdd α] {a₁ a₂ : α} :
+    0 < Q.mk (a₁, a₂) ↔ a₂ < a₁ := by
+  simp [← toQ_ofNat, toQ, mk_lt_mk, Semiring.zero_add]
+
+@[local simp]
+theorem toQ_le [Preorder α] [OrderedAdd α] {a b : α} : toQ a ≤ toQ b ↔ a ≤ b := by
+  simp
+
+@[local simp]
+theorem toQ_lt [Preorder α] [OrderedAdd α] {a b : α} : toQ a < toQ b ↔ a < b := by
+  simp [Preorder.lt_iff_le_not_le]
+
+instance [Preorder α] [OrderedAdd α] : OrderedAdd (OfSemiring.Q α) where
+  add_le_left_iff := by
+    intro a b c
+    induction a using Quot.ind
+    induction b using Quot.ind
+    induction c using Quot.ind
+    next a b c =>
+    rcases a with ⟨a₁, a₂⟩; rcases b with ⟨b₁, b₂⟩; rcases c with ⟨c₁, c₂⟩
+    change a₁ + b₂ ≤ a₂ + b₁ ↔ (a₁ + c₁) + _ ≤ _
+    have : a₁ + c₁ + (b₂ + c₂) = a₁ + b₂ + (c₁ + c₂) := by ac_rfl
+    rw [this]; clear this
+    have : a₂ + c₂ + (b₁ + c₁) = a₂ + b₁ + (c₁ + c₂) := by ac_rfl
+    rw [this]; clear this
+    rw [← OrderedAdd.add_le_left_iff]
+
+-- This perhaps works in more generality than `ExistsAddOfLT`?
+instance [Preorder α] [OrderedRing α] [ExistsAddOfLT α] : OrderedRing (OfSemiring.Q α) where
+  zero_lt_one := by
+    rw [← toQ_ofNat, ← toQ_ofNat, toQ_lt]
+    exact OrderedRing.zero_lt_one
+  mul_lt_mul_of_pos_left := by
+    intro a b c h₁ h₂
+    induction a using Q.ind
+    induction b using Q.ind
+    induction c using Q.ind
+    next a b c =>
+    rcases a with ⟨a₁, a₂⟩; rcases b with ⟨b₁, b₂⟩; rcases c with ⟨c₁, c₂⟩
+    simp at h₁ h₂ ⊢
+    obtain ⟨d, d_pos, rfl⟩ := ExistsAddOfLT.exists_add_of_le h₂
+    simp [Semiring.right_distrib]
+    have : c₂ * a₁ + d * a₁ + c₂ * a₂ + (c₂ * b₂ + d * b₂ + c₂ * b₁) =
+      c₂ * a₁ + c₂ * a₂ + c₂ * b₁ + c₂ * b₂ + (d * a₁ + d * b₂) := by ac_rfl
+    rw [this]; clear this
+    have : c₂ * a₂ + d * a₂ + c₂ * a₁ + (c₂ * b₁ + d * b₁ + c₂ * b₂) =
+      c₂ * a₁ + c₂ * a₂ + c₂ * b₁ + c₂ * b₂ + (d * a₂ + d * b₁) := by ac_rfl
+    rw [this]; clear this
+    rw [← OrderedAdd.add_lt_right_iff]
+    simpa [Semiring.left_distrib] using OrderedRing.mul_lt_mul_of_pos_left h₁ d_pos
+  mul_lt_mul_of_pos_right := by
+    intro a b c h₁ h₂
+    induction a using Q.ind
+    induction b using Q.ind
+    induction c using Q.ind
+    next a b c =>
+    rcases a with ⟨a₁, a₂⟩; rcases b with ⟨b₁, b₂⟩; rcases c with ⟨c₁, c₂⟩
+    simp at h₁ h₂ ⊢
+    obtain ⟨d, d_pos, rfl⟩ := ExistsAddOfLT.exists_add_of_le h₂
+    simp [Semiring.left_distrib]
+    have : a₁ * c₂ + a₁ * d + a₂ * c₂ + (b₁ * c₂ + (b₂ * c₂ + b₂ * d)) =
+      a₁ * c₂ + a₂ * c₂ + b₁ * c₂ + b₂ * c₂ + (a₁ * d + b₂ * d) := by ac_rfl
+    rw [this]; clear this
+    have : a₁ * c₂ + (a₂ * c₂ + a₂ * d) + (b₁ * c₂ + b₁ * d + b₂ * c₂) =
+      a₁ * c₂ + a₂ * c₂ + b₁ * c₂ + b₂ * c₂ + (a₂ * d + b₁ * d) := by ac_rfl
+    rw [this]; clear this
+    rw [← OrderedAdd.add_lt_right_iff]
+    simpa [Semiring.right_distrib] using OrderedRing.mul_lt_mul_of_pos_right h₁ d_pos
+
 end OfSemiring
 end Lean.Grind.Ring
 
@@ -332,6 +499,8 @@ def ofCommSemiring : CommRing (OfSemiring.Q α) :=
   { OfSemiring.ofSemiring with
     mul_comm := mul_comm }
 
+attribute [instance] ofCommSemiring
+
 end OfCommSemiring
 
 end Lean.Grind.CommRing

src/Init/Grind/Ring/Field.lean

@@ -71,24 +71,19 @@ theorem inv_eq_zero_iff {a : α} : a⁻¹ = 0 ↔ a = 0 := by
 theorem zero_eq_inv_iff {a : α} : 0 = a⁻¹ ↔ 0 = a := by
   rw [eq_comm, inv_eq_zero_iff, eq_comm]
 
-attribute [local instance] Semiring.natCast
-
-instance [IsCharP α 0] : NoNatZeroDivisors α where
-  no_nat_zero_divisors := by
-    intro k a b h₁ h₂
-    replace h₂ : (↑k) * a = (↑k : α) * b := h₂
-    have := IsCharP.natCast_eq_zero_iff (α := α) 0 k
-    simp only [Nat.mod_zero, h₁, iff_false] at this
-    replace h₂ := congrArg (· - k * b) h₂;
-    simp [Ring.sub_self] at h₂
-    rw [Ring.sub_eq_add_neg, CommRing.mul_comm _  b, ←Ring.neg_mul,
-        CommRing.mul_comm (-b), ←Semiring.left_distrib,
-        ← Ring.sub_eq_add_neg] at h₂
-    replace h₂ := congrArg (fun x => x * (↑k:α)⁻¹) h₂
-    simp [Semiring.zero_mul] at h₂
-    rw [Semiring.mul_assoc, CommRing.mul_comm (a - b), ← Semiring.mul_assoc,
-        Field.mul_inv_cancel this, Semiring.one_mul] at h₂
-    exact Ring.sub_eq_zero_iff.mp h₂
+instance [IsCharP α 0] : NoNatZeroDivisors α := NoNatZeroDivisors.mk' <| by
+  intro a b h w
+  have := IsCharP.natCast_eq_zero_iff (α := α) 0 a
+  simp only [Nat.mod_zero, h, iff_false] at this
+  if h : b = 0 then
+    exact h
+  else
+    rw [Semiring.ofNat_eq_natCast] at w
+    replace w := congrArg (fun x => x * b⁻¹) w
+    dsimp only [] at w
+    rw [Semiring.hmul_eq_ofNat_mul, Semiring.mul_assoc, Field.mul_inv_cancel h, Semiring.mul_one,
+      Semiring.natCast_zero, Semiring.zero_mul, Semiring.ofNat_eq_natCast] at w
+    contradiction
 
 end Field
 

src/Init/Grind/Ring/OfSemiring.lean

@@ -9,6 +9,7 @@ prelude
 import Init.Grind.Ring.Envelope
 import Init.Data.Hashable
 import Init.Data.RArray
+import all Init.Grind.Ring.Poly
 
 namespace Lean.Grind.Ring.OfSemiring
 /-!
@@ -62,4 +63,333 @@ theorem of_diseq {α} [Semiring α] [AddRightCancel α] (ctx : Context α) (lhs
   replace h₂ := toQ_inj h₂
   contradiction
 
+def Expr.toPoly : Expr → CommRing.Poly
+  | .num n   => .num n
+  | .var x   => CommRing.Poly.ofVar x
+  | .add a b => a.toPoly.combine b.toPoly
+  | .mul a b => a.toPoly.mul b.toPoly
+  | .pow a k =>
+    match a with
+    | .num n => .num (n^k)
+    | .var x => CommRing.Poly.ofMon (.mult {x, k} .unit)
+    | _ => a.toPoly.pow k
+
+end Ring.OfSemiring
+
+namespace CommRing
+attribute [local instance] Semiring.natCast Ring.intCast
+open Semiring Ring CommSemiring
+
+inductive Poly.NonnegCoeffs : Poly → Prop
+  | num (c : Int) : c ≥ 0 → NonnegCoeffs (.num c)
+  | add (a : Int) (m : Mon) (p : Poly) : a ≥ 0 → NonnegCoeffs p → NonnegCoeffs (.add a m p)
+
+def denoteSInt {α} [Semiring α] (k : Int) : α :=
+  bif k < 0 then
+    0
+  else
+    OfNat.ofNat (α := α) k.natAbs
+
+theorem denoteSInt_eq {α} [Semiring α] (k : Int) : denoteSInt (α := α) k = k.toNat := by
+  simp [denoteSInt, cond_eq_if] <;> split
+  next h => rw [ofNat_eq_natCast, Int.toNat_of_nonpos (Int.le_of_lt h)]
+  next h =>
+    have : (k.natAbs : Int) = k.toNat := by
+      rw [Int.toNat_of_nonneg (Int.le_of_not_gt h), Int.natAbs_of_nonneg (Int.le_of_not_gt h)]
+    rw [ofNat_eq_natCast, Int.ofNat_inj.mp this]
+
+def Poly.denoteS [Semiring α] (ctx : Context α) (p : Poly) : α :=
+  match p with
+  | .num k => denoteSInt k
+  | .add k m p => denoteSInt k * m.denote ctx + denoteS ctx p
+
+attribute [local simp] natCast_one natCast_zero zero_mul mul_zero one_mul mul_one add_zero zero_add denoteSInt_eq
+
+theorem Poly.denoteS_ofMon {α} [CommSemiring α] (ctx : Context α) (m : Mon)
+    : denoteS ctx (ofMon m) = m.denote ctx := by
+  simp [ofMon, denoteS]
+
+theorem Poly.denoteS_ofVar {α} [CommSemiring α] (ctx : Context α) (x : Var)
+    : denoteS ctx (ofVar x) = x.denote ctx := by
+  simp [ofVar, denoteS_ofMon, Mon.denote_ofVar]
+
+theorem Poly.denoteS_addConst {α} [CommSemiring α] (ctx : Context α) (p : Poly) (k : Int)
+    : k ≥ 0 → p.NonnegCoeffs → (addConst p k).denoteS ctx = p.denoteS ctx + k.toNat := by
+  simp [addConst, cond_eq_if]; split
+  next => subst k; simp
+  next =>
+    fun_induction addConst.go <;> simp [denoteS, *]
+    next c =>
+      intro _ h; cases h
+      rw [Int.toNat_add, natCast_add] <;> assumption
+    next ih =>
+      intro _ h; cases h
+      next h₁ h₂ => simp [*, add_assoc]
+
+theorem Poly.denoteS_insert {α} [CommSemiring α] (ctx : Context α) (k : Int) (m : Mon) (p : Poly)
+    : k ≥ 0 → p.NonnegCoeffs → (insert k m p).denoteS ctx = k.toNat * m.denote ctx + p.denoteS ctx := by
+  simp [insert, cond_eq_if] <;> split
+  next => simp [*]
+  next =>
+    split
+    next h =>
+      intro _ hn
+      simp at h <;> simp [*, Mon.denote, denoteS_addConst, add_comm]
+    next =>
+      fun_induction insert.go <;> simp_all +zetaDelta [denoteS]
+      next h₁ h₂ =>
+        intro _ hn; cases hn
+        next a m p _ _ hk hn₁ hn₂ =>
+        replace h₂ : k.toNat + a.toNat = 0 := by
+          apply Int.ofNat_inj.mp
+          rw [Int.natCast_add, Int.toNat_of_nonneg hn₁,
+              Int.toNat_of_nonneg hk, h₂]; rfl
+        rw [← add_assoc, Mon.eq_of_grevlex h₁, ← right_distrib, ← natCast_add, h₂]
+        simp
+      next h₁ _ =>
+        intro _ hn; cases hn
+        rw [Int.toNat_add, natCast_add, right_distrib, add_assoc, Mon.eq_of_grevlex h₁] <;> assumption
+      next ih =>
+        intro hk hn; cases hn
+        next hn₁ hn₂ =>
+        rw [ih hk hn₂, add_left_comm]
+
+theorem Poly.denoteS_concat {α} [CommSemiring α] (ctx : Context α) (p₁ p₂ : Poly)
+    : p₁.NonnegCoeffs → p₂.NonnegCoeffs → (concat p₁ p₂).denoteS ctx = p₁.denoteS ctx + p₂.denoteS ctx := by
+  fun_induction concat <;> intro h₁ h₂; simp [*, denoteS]
+  next => cases h₁; rw [add_comm, denoteS_addConst] <;> assumption
+  next ih => cases h₁; next hn₁ hn₂ => rw [denoteS, denoteS, ih hn₂ h₂, add_assoc]
+
+theorem Poly.denoteS_mulConst {α} [CommSemiring α] (ctx : Context α) (k : Int) (p : Poly)
+    : k ≥ 0 → p.NonnegCoeffs → (mulConst k p).denoteS ctx = k.toNat * p.denoteS ctx := by
+  simp [mulConst, cond_eq_if] <;> split
+  next => simp [denoteS, *, zero_mul]
+  next =>
+    split <;> try simp [*]
+    fun_induction mulConst.go <;> simp [denoteS, *]
+    next =>
+      intro _ h₂; cases h₂
+      rw [Int.toNat_mul, natCast_mul] <;> assumption
+    next =>
+      intro _ h₂; cases h₂
+      next ih h₁ h₂ h₃ =>
+      rw [Int.toNat_mul, natCast_mul, left_distrib, mul_assoc, ih h₁ h₃] <;> assumption
+
+theorem Poly.denoteS_mulMon {α} [CommSemiring α] (ctx : Context α) (k : Int) (m : Mon) (p : Poly)
+    : k ≥ 0 → p.NonnegCoeffs → (mulMon k m p).denoteS ctx = k.toNat * m.denote ctx * p.denoteS ctx := by
+  simp [mulMon, cond_eq_if] <;> split
+  next => simp [denoteS, *]
+  next =>
+    split
+    next h =>
+      intro h₁ h₂
+      simp at h; simp [*, Mon.denote, denoteS_mulConst _ _ _ h₁ h₂]
+    next =>
+      fun_induction mulMon.go <;> simp [denoteS, *]
+      next h => simp +zetaDelta at h; simp [*]
+      next =>
+        intro h₁ h₂; cases h₂
+        rw [Int.toNat_mul]
+        simp [natCast_mul, CommSemiring.mul_comm, CommSemiring.mul_left_comm, mul_assoc]
+        assumption; assumption
+      next =>
+        intro h₁ h₂; cases h₂
+        next ih h₂ h₃ =>
+        rw [Int.toNat_mul]
+        simp [Mon.denote_mul, natCast_mul, left_distrib, CommSemiring.mul_left_comm, mul_assoc, ih h₁ h₃]
+        assumption; assumption
+
+theorem Poly.denoteS_combine {α} [CommSemiring α] (ctx : Context α) (p₁ p₂ : Poly)
+    : p₁.NonnegCoeffs → p₂.NonnegCoeffs → (combine p₁ p₂).denoteS ctx = p₁.denoteS ctx + p₂.denoteS ctx := by
+  unfold combine; generalize hugeFuel = fuel
+  fun_induction combine.go
+  case case1 => intros; apply denoteS_concat <;> assumption
+  case case2 => intros h₁ h₂; cases h₁; cases h₂; simp [denoteS, Int.toNat_add, natCast_add, *]
+  case case3 => intro h₁ h₂; cases h₁; simp [denoteS, denoteS_addConst, add_comm, *]
+  case case4 => intro h₁ h₂; cases h₂; simp [denoteS, denoteS_addConst, *]
+  case case5 k₁ _ _ k₂ _ _ hg _ h _ =>
+    intro h₁ h₂
+    cases h₁; cases h₂
+    simp +zetaDelta at h
+    next ih h₁ h₂ h₃ h₄ =>
+    simp [ih h₂ h₄, denoteS, Mon.eq_of_grevlex hg]
+    replace h : k₂.toNat + k₁.toNat = 0 := by
+      rw [← Int.toNat_add, Int.add_comm, h]; rfl; assumption; assumption
+    rw [add_left_comm, ← add_assoc, ← add_assoc, ← right_distrib, ← natCast_add, h]
+    simp
+  case case6 hg k h _ =>
+    intro h₁ h₂
+    cases h₁; cases h₂
+    simp +zetaDelta
+    next ih h₁ h₂ h₃ h₄ =>
+    simp [denoteS, Int.toNat_add, natCast_add, right_distrib, Mon.eq_of_grevlex hg,
+      add_left_comm, add_assoc, *]
+  case case7 =>
+    intro h₁ h₂; cases h₁
+    next ih _ h₁ =>
+    simp [denoteS, ih h₁ h₂, add_left_comm, add_assoc]
+  case case8 =>
+    intro h₁ h₂; cases h₂
+    next ih _ h₂ =>
+    simp [denoteS, ih h₁ h₂, add_left_comm, add_assoc]
+
+theorem Poly.mulConst_NonnegCoeffs {p : Poly} {k : Int} : k ≥ 0 → p.NonnegCoeffs → (p.mulConst k).NonnegCoeffs := by
+  simp [mulConst, cond_eq_if]; split
+  next => intros; constructor; decide
+  split; intros; assumption
+  fun_induction mulConst.go
+  next =>
+    intro h₁ h₂; cases h₂; constructor
+    apply Int.mul_nonneg <;> assumption
+  next =>
+    intro h₁ h₂; cases h₂; constructor
+    apply Int.mul_nonneg <;> assumption
+    next ih _ h => exact ih h₁ h
+
+theorem Poly.mulMon_NonnegCoeffs {p : Poly} {k : Int} (m : Mon) : k ≥ 0 → p.NonnegCoeffs → (p.mulMon k m).NonnegCoeffs := by
+  simp [mulMon, cond_eq_if]; split
+  next => intros; constructor; decide
+  split
+  next => intros; apply mulConst_NonnegCoeffs <;> assumption
+  fun_induction mulMon.go
+  next => intros; constructor; decide
+  next => intro _ h; cases h; constructor; apply Int.mul_nonneg <;> assumption; constructor; decide
+  next ih =>
+    intro h₁ h₂; cases h₂; constructor
+    apply Int.mul_nonneg <;> assumption
+    apply ih <;> assumption
+
+theorem Poly.addConst_NonnegCoeffs {p : Poly} {k : Int} : k ≥ 0 → p.NonnegCoeffs → (p.addConst k).NonnegCoeffs := by
+  simp [addConst, cond_eq_if]; split
+  next => intros; assumption
+  fun_induction addConst.go
+  next h _ => intro _ h; cases h; constructor; apply Int.add_nonneg <;> assumption
+  next ih => intro h₁ h₂; cases h₂; constructor; assumption; apply ih <;> assumption
+
+theorem Poly.concat_NonnegCoeffs {p₁ p₂ : Poly} : p₁.NonnegCoeffs → p₂.NonnegCoeffs → (p₁.concat p₂).NonnegCoeffs := by
+  fun_induction Poly.concat
+  next => intro h₁ h₂; cases h₁; apply addConst_NonnegCoeffs <;> assumption
+  next ih => intro h₁ h₂; cases h₁; constructor; assumption; apply ih <;> assumption
+
+theorem Poly.combine_NonnegCoeffs {p₁ p₂ : Poly} : p₁.NonnegCoeffs → p₂.NonnegCoeffs → (p₁.combine p₂).NonnegCoeffs := by
+  unfold combine; generalize hugeFuel = fuel
+  fun_induction combine.go
+  next => intros; apply Poly.concat_NonnegCoeffs <;> assumption
+  next => intro h₁ h₂; cases h₁; cases h₂; constructor; apply Int.add_nonneg <;> assumption
+  next => intro h₁ h₂; apply addConst_NonnegCoeffs; cases h₁; assumption; assumption
+  next => intro h₁ h₂; apply addConst_NonnegCoeffs; cases h₂; assumption; assumption
+  next ih => intro h₁ h₂; cases h₁; cases h₂; apply ih <;> assumption
+  next ih =>
+    simp +zetaDelta; intro h₁ h₂; cases h₁; cases h₂; constructor; apply Int.add_nonneg <;> assumption
+    apply ih <;> assumption
+  next ih =>
+    intro h₁ h₂; cases h₁; cases h₂; constructor; assumption
+    apply ih; assumption
+    constructor <;> assumption
+  next ih =>
+    intro h₁ h₂; cases h₁; cases h₂; constructor; assumption
+    apply ih
+    constructor <;> assumption
+    assumption
+
+theorem Poly.mul_go_NonnegCoeffs (p₁ p₂ acc : Poly)
+    : p₁.NonnegCoeffs → p₂.NonnegCoeffs → acc.NonnegCoeffs → (mul.go p₂ p₁ acc).NonnegCoeffs := by
+  fun_induction mul.go
+  next =>
+    intro h₁ h₂ h₃
+    cases h₁; next h₁ =>
+    have := mulConst_NonnegCoeffs h₁ h₂
+    apply combine_NonnegCoeffs <;> assumption
+  next ih =>
+    intro h₁ h₂ h₃
+    cases h₁
+    apply ih
+    assumption; assumption
+    apply Poly.combine_NonnegCoeffs; assumption
+    apply Poly.mulMon_NonnegCoeffs <;> assumption
+
+theorem Poly.mul_NonnegCoeffs {p₁ p₂ : Poly} : p₁.NonnegCoeffs → p₂.NonnegCoeffs → (p₁.mul p₂).NonnegCoeffs := by
+  unfold mul; intros; apply mul_go_NonnegCoeffs
+  assumption; assumption; constructor; decide
+
+theorem Poly.pow_NonnegCoeffs {p : Poly} (k : Nat) : p.NonnegCoeffs → (p.pow k).NonnegCoeffs := by
+  fun_induction Poly.pow
+  next => intros; constructor; decide
+  next => intros; assumption
+  next ih => intro h; apply mul_NonnegCoeffs; assumption; apply ih; assumption
+
+theorem Poly.num_zero_NonnegCoeffs : (num 0).NonnegCoeffs := by
+  apply NonnegCoeffs.num; simp
+
+theorem Poly.denoteS_mul_go {α} [CommSemiring α] (ctx : Context α) (p₁ p₂ acc : Poly)
+    : p₁.NonnegCoeffs → p₂.NonnegCoeffs → acc.NonnegCoeffs → (mul.go p₂ p₁ acc).denoteS ctx = acc.denoteS ctx + p₁.denoteS ctx * p₂.denoteS ctx := by
+  fun_induction mul.go <;> intro h₁ h₂ h₃
+  next k =>
+    cases h₁; next h₁ =>
+    have := p₂.mulConst_NonnegCoeffs h₁ h₂
+    simp [denoteS, denoteS_combine, denoteS_mulConst, *]
+  next acc a m p ih =>
+    cases h₁; next h₁ h₁' =>
+    have := p₂.mulMon_NonnegCoeffs m h₁ h₂
+    have := acc.combine_NonnegCoeffs h₃ this
+    replace ih := ih h₁' h₂ this
+    rw [ih, denoteS_combine, denoteS_mulMon]
+    simp [denoteS, add_assoc, right_distrib]
+    all_goals assumption
+
+theorem Poly.denoteS_mul {α} [CommSemiring α] (ctx : Context α) (p₁ p₂ : Poly)
+    : p₁.NonnegCoeffs → p₂.NonnegCoeffs → (mul p₁ p₂).denoteS ctx = p₁.denoteS ctx * p₂.denoteS ctx := by
+  intro h₁ h₂
+  simp [mul, denoteS_mul_go, denoteS, Poly.num_zero_NonnegCoeffs, *]
+
+theorem Poly.denoteS_pow {α} [CommSemiring α] (ctx : Context α) (p : Poly) (k : Nat)
+   : p.NonnegCoeffs → (pow p k).denoteS ctx = p.denoteS ctx ^ k := by
+ fun_induction pow <;> intro h₁
+ next => simp [denoteS, pow_zero]
+ next => simp [pow_succ, pow_zero]
+ next ih =>
+  replace ih := ih h₁
+  rw [denoteS_mul, ih, pow_succ, CommSemiring.mul_comm]
+  assumption
+  apply Poly.pow_NonnegCoeffs; assumption
+
+end CommRing
+
+namespace Ring.OfSemiring
+open CommRing
+
+theorem Expr.toPoly_NonnegCoeffs {e : Expr} : e.toPoly.NonnegCoeffs := by
+  fun_induction toPoly
+  next => constructor; apply Int.natCast_nonneg
+  next => simp [Poly.ofVar, Poly.ofMon]; constructor; decide; constructor; decide
+  next => apply Poly.combine_NonnegCoeffs <;> assumption
+  next => apply Poly.mul_NonnegCoeffs <;> assumption
+  next => constructor; apply Int.pow_nonneg; apply Int.natCast_nonneg
+  next => constructor; decide; constructor; decide
+  next => apply Poly.pow_NonnegCoeffs; assumption
+
+theorem Expr.denoteS_toPoly {α} [CommSemiring α] (ctx : Context α) (e : Expr)
+   : e.toPoly.denoteS ctx = e.denote ctx := by
+  fun_induction toPoly
+    <;> simp [denote, Poly.denoteS, Poly.denoteS_ofVar, denoteSInt_eq, Semiring.ofNat_eq_natCast]
+  next => simp [CommRing.Var.denote, Var.denote]
+  next ih₁ ih₂ => rw [Poly.denoteS_combine, ih₁, ih₂] <;> apply toPoly_NonnegCoeffs
+  next ih₁ ih₂ => rw [Poly.denoteS_mul, ih₁, ih₂] <;> apply toPoly_NonnegCoeffs
+  next => rw [Int.toNat_pow_of_nonneg, Semiring.natCast_pow, Int.toNat_natCast]; apply Int.natCast_nonneg
+  next =>
+    simp [Poly.ofMon, Poly.denoteS, denoteSInt_eq, Power.denote_eq, Mon.denote,
+          Semiring.natCast_zero, Semiring.natCast_one, Semiring.one_mul, Semiring.add_zero,
+          CommRing.Var.denote, Var.denote, Semiring.mul_one]
+  next ih => rw [Poly.denoteS_pow, ih]; apply toPoly_NonnegCoeffs
+
+def eq_normS_cert (lhs rhs : Expr) : Bool :=
+  lhs.toPoly == rhs.toPoly
+
+theorem eq_normS {α} [CommSemiring α] (ctx : Context α) (lhs rhs : Expr)
+    : eq_normS_cert lhs rhs → lhs.denote ctx = rhs.denote ctx := by
+  simp [eq_normS_cert]; intro h
+  replace h := congrArg (Poly.denoteS ctx) h
+  simp [Expr.denoteS_toPoly, *] at h
+  assumption
+
 end Lean.Grind.Ring.OfSemiring

src/Init/Grind/Ring/Poly.lean

@@ -28,7 +28,7 @@ inductive Expr where
   | sub  (a b : Expr)
   | mul (a b : Expr)
   | pow (a : Expr) (k : Nat)
-  deriving Inhabited, BEq, Hashable
+  deriving Inhabited, BEq, Hashable, Repr
 
 abbrev Context (α : Type u) := RArray α
 
@@ -62,7 +62,7 @@ instance : LawfulBEq Power where
 def Power.varLt (p₁ p₂ : Power) : Bool :=
   p₁.x.blt p₂.x
 
-def Power.denote {α} [CommRing α] (ctx : Context α) : Power → α
+def Power.denote {α} [Semiring α] (ctx : Context α) : Power → α
   | {x, k} =>
     match k with
     | 0 => 1
@@ -85,7 +85,7 @@ instance : LawfulBEq Mon where
     induction a <;> simp! [BEq.beq]
     assumption
 
-def Mon.denote {α} [CommRing α] (ctx : Context α) : Mon → α
+def Mon.denote {α} [Semiring α] (ctx : Context α) : Mon → α
   | unit => 1
   | .mult p m => p.denote ctx * denote ctx m
 
@@ -208,7 +208,7 @@ instance : LawfulBEq Poly where
     change m == m ∧ p == p
     simp [ih]
 
-def Poly.denote [CommRing α] (ctx : Context α) (p : Poly) : α :=
+def Poly.denote [Ring α] (ctx : Context α) (p : Poly) : α :=
   match p with
   | .num k => Int.cast k
   | .add k m p => Int.cast k * m.denote ctx + denote ctx p
@@ -518,15 +518,15 @@ theorem denoteInt_eq {α} [CommRing α] (k : Int) : denoteInt (α := α) k = k :
   next h => rw [ofNat_eq_natCast, ← intCast_natCast, ← intCast_neg, ← Int.eq_neg_natAbs_of_nonpos (Int.le_of_lt h)]
   next h => rw [ofNat_eq_natCast, ← intCast_natCast, ← Int.eq_natAbs_of_nonneg (Int.le_of_not_gt h)]
 
-theorem Power.denote_eq {α} [CommRing α] (ctx : Context α) (p : Power)
+theorem Power.denote_eq {α} [Semiring α] (ctx : Context α) (p : Power)
     : p.denote ctx = p.x.denote ctx ^ p.k := by
   cases p <;> simp [Power.denote] <;> split <;> simp [pow_zero, pow_succ, one_mul]
 
-theorem Mon.denote_ofVar {α} [CommRing α] (ctx : Context α) (x : Var)
+theorem Mon.denote_ofVar {α} [Semiring α] (ctx : Context α) (x : Var)
     : denote ctx (ofVar x) = x.denote ctx := by
   simp [denote, ofVar, Power.denote_eq, pow_succ, pow_zero, one_mul, mul_one]
 
-theorem Mon.denote_concat {α} [CommRing α] (ctx : Context α) (m₁ m₂ : Mon)
+theorem Mon.denote_concat {α} [Semiring α] (ctx : Context α) (m₁ m₂ : Mon)
     : denote ctx (concat m₁ m₂) = m₁.denote ctx * m₂.denote ctx := by
   induction m₁ <;> simp [concat, denote, one_mul, *]
   next p₁ m₁ ih => rw [mul_assoc]
@@ -541,20 +541,20 @@ private theorem eq_of_blt_false {a b : Nat} : a.blt b = false → b.blt a = fals
   replace h₂ := le_of_blt_false h₂
   exact Nat.le_antisymm h₂ h₁
 
-theorem Mon.denote_mulPow {α} [CommRing α] (ctx : Context α) (p : Power) (m : Mon)
+theorem Mon.denote_mulPow {α} [CommSemiring α] (ctx : Context α) (p : Power) (m : Mon)
     : denote ctx (mulPow p m) = p.denote ctx * m.denote ctx := by
-  fun_induction mulPow <;> simp [denote, mul_assoc, mul_comm, mul_left_comm, *]
+  fun_induction mulPow <;> simp [denote, mul_left_comm, *]
   next h₁ h₂ =>
     have := eq_of_blt_false h₁ h₂
-    simp [Power.denote_eq, pow_add, this]
+    simp [Power.denote_eq, pow_add, mul_assoc, this]
 
-theorem Mon.denote_mul {α} [CommRing α] (ctx : Context α) (m₁ m₂ : Mon)
+theorem Mon.denote_mul {α} [CommSemiring α] (ctx : Context α) (m₁ m₂ : Mon)
     : denote ctx (mul m₁ m₂) = m₁.denote ctx * m₂.denote ctx := by
   unfold mul
   generalize hugeFuel = fuel
   fun_induction mul.go
-    <;> simp [denote, denote_concat, one_mul, 
-      mul_assoc, mul_left_comm, mul_comm, *]
+    <;> simp [denote, denote_concat, one_mul,
+      mul_assoc, mul_left_comm, CommSemiring.mul_comm, *]
   next h₁ h₂ _ =>
     have := eq_of_blt_false h₁ h₂
     simp [Power.denote_eq, pow_add, this]
@@ -1178,23 +1178,23 @@ theorem diseq_norm {α} [CommRing α] (ctx : Context α) (lhs rhs : Expr) (p : P
   simp [core_cert, Poly.denoteAsIntModule_eq_denote]; intro _ h; subst p; simp [Expr.denote_toPoly, Expr.denote]
   intro h; rw [sub_eq_zero_iff] at h; contradiction
 
-open IntModule.IsOrdered
+open OrderedAdd
 
-theorem le_norm {α} [CommRing α] [Preorder α] [Ring.IsOrdered α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
+theorem le_norm {α} [CommRing α] [Preorder α] [OrderedRing α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
     : core_cert lhs rhs p → lhs.denote ctx ≤ rhs.denote ctx → p.denoteAsIntModule ctx ≤ 0 := by
   simp [core_cert, Poly.denoteAsIntModule_eq_denote]; intro _ h; subst p; simp [Expr.denote_toPoly, Expr.denote]
   replace h := add_le_left h ((-1) * rhs.denote ctx)
   rw [neg_mul, ← sub_eq_add_neg, one_mul, ← sub_eq_add_neg, sub_self] at h
   assumption
 
-theorem lt_norm {α} [CommRing α] [Preorder α] [Ring.IsOrdered α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
+theorem lt_norm {α} [CommRing α] [Preorder α] [OrderedRing α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
     : core_cert lhs rhs p → lhs.denote ctx < rhs.denote ctx → p.denoteAsIntModule ctx < 0 := by
   simp [core_cert, Poly.denoteAsIntModule_eq_denote]; intro _ h; subst p; simp [Expr.denote_toPoly, Expr.denote]
   replace h := add_lt_left h ((-1) * rhs.denote ctx)
   rw [neg_mul, ← sub_eq_add_neg, one_mul, ← sub_eq_add_neg, sub_self] at h
   assumption
 
-theorem not_le_norm {α} [CommRing α] [LinearOrder α] [Ring.IsOrdered α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
+theorem not_le_norm {α} [CommRing α] [LinearOrder α] [OrderedRing α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
     : core_cert rhs lhs p → ¬ lhs.denote ctx ≤ rhs.denote ctx → p.denoteAsIntModule ctx < 0 := by
   simp [core_cert, Poly.denoteAsIntModule_eq_denote]; intro _ h₁; subst p; simp [Expr.denote_toPoly, Expr.denote]
   replace h₁ := LinearOrder.lt_of_not_le h₁
@@ -1202,7 +1202,7 @@ theorem not_le_norm {α} [CommRing α] [LinearOrder α] [Ring.IsOrdered α] (ctx
   simp [← sub_eq_add_neg, sub_self] at h₁
   assumption
 
-theorem not_lt_norm {α} [CommRing α] [LinearOrder α] [Ring.IsOrdered α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
+theorem not_lt_norm {α} [CommRing α] [LinearOrder α] [OrderedRing α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
     : core_cert rhs lhs p → ¬ lhs.denote ctx < rhs.denote ctx → p.denoteAsIntModule ctx ≤ 0 := by
   simp [core_cert, Poly.denoteAsIntModule_eq_denote]; intro _ h₁; subst p; simp [Expr.denote_toPoly, Expr.denote]
   replace h₁ := LinearOrder.le_of_not_lt h₁
@@ -1210,14 +1210,14 @@ theorem not_lt_norm {α} [CommRing α] [LinearOrder α] [Ring.IsOrdered α] (ctx
   simp [← sub_eq_add_neg, sub_self] at h₁
   assumption
 
-theorem not_le_norm' {α} [CommRing α] [Preorder α] [Ring.IsOrdered α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
+theorem not_le_norm' {α} [CommRing α] [Preorder α] [OrderedRing α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
     : core_cert lhs rhs p → ¬ lhs.denote ctx ≤ rhs.denote ctx → ¬ p.denoteAsIntModule ctx ≤ 0 := by
   simp [core_cert, Poly.denoteAsIntModule_eq_denote]; intro _ h₁; subst p; simp [Expr.denote_toPoly, Expr.denote]; intro h
   replace h := add_le_right (rhs.denote ctx) h
   rw [sub_eq_add_neg, add_left_comm, ← sub_eq_add_neg, sub_self] at h; simp [add_zero] at h
   contradiction
 
-theorem not_lt_norm' {α} [CommRing α] [Preorder α] [Ring.IsOrdered α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
+theorem not_lt_norm' {α} [CommRing α] [Preorder α] [OrderedRing α] (ctx : Context α) (lhs rhs : Expr) (p : Poly)
     : core_cert lhs rhs p → ¬ lhs.denote ctx < rhs.denote ctx → ¬ p.denoteAsIntModule ctx < 0 := by
   simp [core_cert, Poly.denoteAsIntModule_eq_denote]; intro _ h₁; subst p; simp [Expr.denote_toPoly, Expr.denote]; intro h
   replace h := add_lt_right (rhs.denote ctx) h
@@ -1270,5 +1270,4 @@ theorem diseq0_to_eq {α} [Field α] (a : α) : a ≠ 0 → a*a⁻¹ = 1 := by
   exact Field.mul_inv_cancel
 
 end CommRing
-
 end Lean.Grind

src/Init/GrindInstances/Nat.lean

@@ -6,11 +6,15 @@ Authors: Kim Morrison
 module
 prelude
 
-import Init.Grind.Module.Basic
+import Init.Grind.Ordered.Module
+import Init.Grind.Ring.Basic
 
 namespace Lean.Grind
 
 instance : AddRightCancel Nat where
   add_right_cancel _ _ _ := Nat.add_right_cancel
 
+instance : ExistsAddOfLT Nat where
+  exists_add_of_le {a b} h := ⟨b - a, by omega⟩
+
 end Lean.Grind

src/Init/GrindInstances/Ring.lean

@@ -6,6 +6,7 @@ Authors: Kim Morrison
 module
 
 prelude
+import Init.GrindInstances.Ring.Nat
 import Init.GrindInstances.Ring.Int
 import Init.GrindInstances.Ring.UInt
 import Init.GrindInstances.Ring.SInt

src/Init/GrindInstances/Ring/BitVec.lean

@@ -32,7 +32,7 @@ instance : CommRing (BitVec w) where
   intCast_neg _ := BitVec.ofInt_neg
 
 instance : IsCharP (BitVec w) (2 ^ w) := IsCharP.mk' _ _
-  (ofNat_eq_zero_iff := fun x => by simp [BitVec.ofInt, BitVec.toNat_eq])
+  (ofNat_eq_zero_iff := fun x => by simp [BitVec.toNat_eq])
 
 -- Verify we can derive the instances showing how `toInt` interacts with operations:
 example : ToInt.Add (BitVec w) (some 0) (some (2^w)) := inferInstance

src/Init/GrindInstances/Ring/Nat.lean

@@ -0,0 +1,47 @@
+/-
+Copyright (c) 2025 Lean FRO, LLC. or its affiliates. All Rights Reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Kim Morrison
+-/
+module
+
+prelude
+import Init.Grind.Ordered.Ring
+import Init.Data.Int.Lemmas
+
+namespace Lean.Grind
+
+instance : CommSemiring Nat where
+  add_assoc := Nat.add_assoc
+  add_comm := Nat.add_comm
+  add_zero := Nat.add_zero
+  mul_assoc := Nat.mul_assoc
+  mul_comm := Nat.mul_comm
+  mul_one := Nat.mul_one
+  one_mul := Nat.one_mul
+  left_distrib := Nat.mul_add
+  right_distrib := Nat.add_mul
+  zero_mul := Nat.zero_mul
+  mul_zero := Nat.mul_zero
+  pow_zero _ := by rfl
+  pow_succ _ _ := by rfl
+  ofNat_succ _ := by rfl
+
+instance : Preorder Nat where
+  le_refl := by omega
+  le_trans := by omega
+  lt_iff_le_not_le := by omega
+
+instance : OrderedRing Nat where
+  add_le_left_iff := by omega
+  zero_lt_one := by omega
+  mul_lt_mul_of_pos_left h₁ h₂ := Nat.mul_lt_mul_of_pos_left h₁ h₂
+  mul_lt_mul_of_pos_right h₁ h₂ := Nat.mul_lt_mul_of_pos_right h₁ h₂
+
+instance : IsCharP Nat 0 where
+  ofNat_ext_iff {x y} := by simp [OfNat.ofNat]
+
+instance : NoNatZeroDivisors Nat where
+  no_nat_zero_divisors _ _ _ h₁ h₂ := (Nat.mul_right_inj h₁).mp h₂
+
+end Lean.Grind

src/Init/Internal/Order/Basic.lean

@@ -959,9 +959,48 @@ instance ReverseImplicationOrder.instCompleteLattice : CompleteLattice ReverseIm
     match h with
     | Or.inl hfx₁ => Or.inl (h₁ x y hxy hfx₁)
     | Or.inr hfx₂ => Or.inr (h₂ x y hxy hfx₂)
-
 end reverse_implication_order
 
+section antitone
+@[partial_fixpoint_monotone] theorem coind_not
+    {α} [PartialOrder α] (f₁ : α → Prop)
+    (h₁ : @monotone _ _ _ ReverseImplicationOrder.instOrder f₁) :
+    @monotone _ _ _ ImplicationOrder.instOrder (fun x => ¬f₁ x) := by
+  intro x y hxy hfx h
+  exact hfx (h₁ x y hxy h)
+
+@[partial_fixpoint_monotone] theorem ind_not
+    {α} [PartialOrder α] (f₁ : α → Prop)
+    (h₁ : @monotone _ _ _ ImplicationOrder.instOrder f₁) :
+    @monotone _ _ _ ReverseImplicationOrder.instOrder (fun x => ¬f₁ x) := by
+  intro x y hxy hfx h
+  exact hfx (h₁ x y hxy h)
+
+@[partial_fixpoint_monotone] theorem ind_impl
+    {α} [PartialOrder α] (f₁ : α → Prop) (f₂ : α → Prop)
+    (h₁ : @monotone _ _ _ ReverseImplicationOrder.instOrder f₁)
+    (h₂ : @monotone _ _ _ ImplicationOrder.instOrder f₂):
+    @monotone _ _ _ ImplicationOrder.instOrder (fun x => f₁ x → f₂ x) := by
+  intro x y hxy himp hf1
+  specialize h₁ x y hxy hf1
+  specialize h₂ x y hxy
+  apply h₂
+  apply himp
+  exact h₁
+
+@[partial_fixpoint_monotone] theorem coind_impl
+    {α} [PartialOrder α] (f₁ : α → Prop) (f₂ : α → Prop)
+    (h₁ : @monotone _ _ _ ImplicationOrder.instOrder f₁)
+    (h₂ : @monotone _ _ _ ReverseImplicationOrder.instOrder f₂):
+    @monotone _ _ _ ReverseImplicationOrder.instOrder (fun x => f₁ x → f₂ x) := by
+  intro x y hxy himp hf1
+  specialize h₁ x y hxy hf1
+  specialize h₂ x y hxy
+  apply h₂
+  apply himp
+  exact h₁
+end antitone
+
 namespace Example
 
 def findF (P : Nat → Bool) (rec : Nat → Option Nat) (x : Nat) : Option Nat :=

src/Init/NotationExtra.lean

@@ -313,23 +313,6 @@ macro_rules
     `($mods:declModifiers class $id $params* $[: $ty:term]? extends $[$parents:term],*
       attribute [instance] $ctor)
 
-macro_rules
-  | `(haveI $hy:hygieneInfo $bs* $[: $ty]? := $val; $body) =>
-    `(haveI $(HygieneInfo.mkIdent hy `this (canonical := true)) $bs* $[: $ty]? := $val; $body)
-  | `(haveI _ $bs* := $val; $body) => `(haveI x $bs* : _ := $val; $body)
-  | `(haveI _ $bs* : $ty := $val; $body) => `(haveI x $bs* : $ty := $val; $body)
-  | `(haveI $x:ident $bs* := $val; $body) => `(haveI $x $bs* : _ := $val; $body)
-  | `(haveI $_:ident $_* : $_ := $_; $_) => Lean.Macro.throwUnsupported -- handled by elab
-
-macro_rules
-  | `(letI $hy:hygieneInfo $bs* $[: $ty]? := $val; $body) =>
-    `(letI $(HygieneInfo.mkIdent hy `this (canonical := true)) $bs* $[: $ty]? := $val; $body)
-  | `(letI _ $bs* := $val; $body) => `(letI x $bs* : _ := $val; $body)
-  | `(letI _ $bs* : $ty := $val; $body) => `(letI x $bs* : $ty := $val; $body)
-  | `(letI $x:ident $bs* := $val; $body) => `(letI $x $bs* : _ := $val; $body)
-  | `(letI $_:ident $_* : $_ := $_; $_) => Lean.Macro.throwUnsupported -- handled by elab
-
-
 namespace Lean
 syntax cdotTk := patternIgnore("· " <|> ". ")
 /-- `· tac` focuses on the main goal and tries to solve it using `tac`, or else fails. -/

src/Init/Prelude.lean

@@ -4245,7 +4245,9 @@ def defaultMaxRecDepth := 512
 
 /-- The message to display on stack overflow. -/
 def maxRecDepthErrorMessage : String :=
-  "maximum recursion depth has been reached\nuse `set_option maxRecDepth <num>` to increase limit\nuse `set_option diagnostics true` to get diagnostic information"
+  "maximum recursion depth has been reached\n\
+   use `set_option maxRecDepth <num>` to increase limit\n\
+   use `set_option diagnostics true` to get diagnostic information"
 
 /-! # Syntax -/
 

src/Init/System/IO.lean

@@ -940,7 +940,7 @@ encountered.
 The underlying file is not automatically closed upon encountering an EOF, and subsequent reads from
 the handle may block and/or return data.
 -/
-partial def Handle.readBinToEnd (h : Handle) : IO ByteArray := do
+def Handle.readBinToEnd (h : Handle) : IO ByteArray := do
   h.readBinToEndInto .empty
 
 /--
@@ -957,12 +957,14 @@ def Handle.readToEnd (h : Handle) : IO String := do
   | none => throw <| .userError s!"Tried to read from handle containing non UTF-8 data."
 
 /--
-Returns the contents of a UTF-8-encoded text file as an array of lines.
+Reads the entire remaining contents of the file handle as a UTF-8-encoded array of lines.
 
 Newline markers are not included in the lines.
+
+The underlying file is not automatically closed, and subsequent reads from the handle may block
+and/or return data.
 -/
-partial def lines (fname : FilePath) : IO (Array String) := do
-  let h ← Handle.mk fname Mode.read
+partial def Handle.lines (h : Handle) : IO (Array String) := do
   let rec read (lines : Array String) := do
     let line ← h.getLine
     if line.length == 0 then
@@ -975,6 +977,15 @@ partial def lines (fname : FilePath) : IO (Array String) := do
       pure <| lines.push line
   read #[]
 
+/--
+Returns the contents of a UTF-8-encoded text file as an array of lines.
+
+Newline markers are not included in the lines.
+-/
+def lines (fname : FilePath) : IO (Array String) := do
+  let h ← Handle.mk fname Mode.read
+  h.lines
+
 /--
 Write the provided bytes to a binary file at the specified path.
 -/
@@ -1666,6 +1677,66 @@ def ofBuffer (r : Ref Buffer) : Stream where
     { b with data := data.copySlice 0 b.data b.pos data.size false, pos := b.pos + data.size }
   isTty   := pure false
 
+/--
+Reads the entire remaining contents of the stream until an end-of-file marker (EOF) is
+encountered.
+
+The underlying stream is not automatically closed upon encountering an EOF, and subsequent reads from
+the stream may block and/or return data.
+-/
+partial def readBinToEndInto (s : Stream) (buf : ByteArray) : IO ByteArray := do
+  let rec loop (acc : ByteArray) : IO ByteArray := do
+    let buf ← s.read 1024
+    if buf.isEmpty then
+      return acc
+    else
+      loop (acc ++ buf)
+  loop buf
+
+/--
+Reads the entire remaining contents of the stream until an end-of-file marker (EOF) is
+encountered.
+
+The underlying stream is not automatically closed upon encountering an EOF, and subsequent reads from
+the stream may block and/or return data.
+-/
+def readBinToEnd (s : Stream) : IO ByteArray := do
+  s.readBinToEndInto .empty
+
+/--
+Reads the entire remaining contents of the stream as a UTF-8-encoded string. An exception is
+thrown if the contents are not valid UTF-8.
+
+The underlying stream is not automatically closed, and subsequent reads from the stream may block
+and/or return data.
+-/
+def readToEnd (s : Stream) : IO String := do
+  let data ← s.readBinToEnd
+  match String.fromUTF8? data with
+  | some s => return s
+  | none => throw <| .userError s!"Tried to read from stream containing non UTF-8 data."
+  
+/--
+Reads the entire remaining contents of the stream as a UTF-8-encoded array of lines.
+
+Newline markers are not included in the lines.
+
+The underlying stream is not automatically closed, and subsequent reads from the stream may block
+and/or return data.
+-/
+partial def lines (s : Stream) : IO (Array String) := do
+  let rec read (lines : Array String) := do
+    let line ← s.getLine
+    if line.length == 0 then
+      pure lines
+    else if line.back == '\n' then
+      let line := line.dropRight 1
+      let line := if line.back == '\r' then line.dropRight 1 else line
+      read <| lines.push line
+    else
+      pure <| lines.push line
+  read #[]
+
 end Stream
 
 /--

src/Init/Tactics.lean

@@ -573,6 +573,13 @@ example : (let x := 1; x) = 1 := by
 -/
 syntax (name := liftLets) "lift_lets " optConfig (location)? : tactic
 
+/--
+Transforms `let` expressions into `have` expressions when possible.
+- `let_to_have` transforms `let`s in the target.
+- `let_to_have at h` transforms `let`s in the given local hypothesis.
+-/
+syntax (name := letToHave) "let_to_have" (location)? : tactic
+
 /--
 If `thm` is a theorem `a = b`, then as a rewrite rule,
 * `thm` means to replace `a` with `b`, and
@@ -818,16 +825,16 @@ The `have` tactic is for adding hypotheses to the local context of the main goal
   For example, given `h : p ∧ q ∧ r`, `have ⟨h₁, h₂, h₃⟩ := h` produces the
   hypotheses `h₁ : p`, `h₂ : q`, and `h₃ : r`.
 -/
-syntax "have " haveDecl : tactic
+syntax "have " letConfig letDecl : tactic
 macro_rules
   -- special case: when given a nested `by` block, move it outside of the `refine` to enable
   -- incrementality
-  | `(tactic| have%$haveTk $id:haveId $bs* : $type := by%$byTk $tacs*) => do
+  | `(tactic| have%$haveTk $id:letId $bs* : $type := by%$byTk $tacs*) => do
     /-
     We want to create the syntax
     ```
     focus
-      refine no_implicit_lambda% (have $id:haveId $bs* : $type := ?body; ?_)
+      refine no_implicit_lambda% (have $id:letId $bs* : $type := ?body; ?_)
       case body => $tacs*
     ```
     However, we need to be very careful with the syntax infos involved:
@@ -846,9 +853,11 @@ macro_rules
     let tac ← `(tacticSeq| $tac:tactic)
     let tac ← Lean.withRef byTk `(tactic| case body => $(.mk tac):tacticSeq)
     Lean.withRef haveTk `(tactic| focus
-      refine no_implicit_lambda% (have $id:haveId $bs* : $type := ?body; ?_)
+      refine no_implicit_lambda% (have $id:letId $bs* : $type := ?body; ?_)
       $tac)
-  | `(tactic| have $d:haveDecl) => `(tactic| refine_lift have $d:haveDecl; ?_)
+  | `(tactic| have $c:letConfig $d:letDecl) => `(tactic| refine_lift have $c:letConfig $d:letDecl; ?_)
+/-- TODO(kmill): remove after stage0 update -/
+macro (priority := low) "have " d:letDecl : tactic => `(tactic| have $d:letDecl)
 
 /--
 Given a main goal `ctx ⊢ t`, `suffices h : t' from e` replaces the main goal with `ctx ⊢ t'`,
@@ -869,7 +878,9 @@ The `let` tactic is for adding definitions to the local context of the main goal
   For example, given `p : α × β × γ`, `let ⟨x, y, z⟩ := p` produces the
   local variables `x : α`, `y : β`, and `z : γ`.
 -/
-macro "let " d:letDecl : tactic => `(tactic| refine_lift let $d:letDecl; ?_)
+macro "let " c:letConfig d:letDecl : tactic => `(tactic| refine_lift let $c:letConfig $d:letDecl; ?_)
+/-- TODO(kmill): remove after stage0 update -/
+macro (priority := low) "let " d:letDecl : tactic => `(tactic| let $d:letDecl)
 /-- `let rec f : t := e` adds a recursive definition `f` to the current goal.
 The syntax is the same as term-mode `let rec`. -/
 syntax (name := letrec) withPosition(atomic("let " &"rec ") letRecDecls) : tactic
@@ -879,12 +890,12 @@ macro_rules
 /-- Similar to `refine_lift`, but using `refine'` -/
 macro "refine_lift' " e:term : tactic => `(tactic| focus (refine' no_implicit_lambda% $e; rotate_right))
 /-- Similar to `have`, but using `refine'` -/
-macro "have' " d:haveDecl : tactic => `(tactic| refine_lift' have $d:haveDecl; ?_)
+macro (name := tacticHave') "have' " c:letConfig d:letDecl : tactic => `(tactic| refine_lift' have $c:letConfig $d:letDecl; ?_)
 set_option linter.missingDocs false in -- OK, because `tactic_alt` causes inheritance of docs
 macro (priority := high) "have'" x:ident " := " p:term : tactic => `(tactic| have' $x:ident : _ := $p)
-attribute [tactic_alt tacticHave'_] «tacticHave'_:=_»
+attribute [tactic_alt tacticHave'] «tacticHave'_:=_»
 /-- Similar to `let`, but using `refine'` -/
-macro "let' " d:letDecl : tactic => `(tactic| refine_lift' let $d:letDecl; ?_)
+macro "let' " c:letConfig d:letDecl : tactic => `(tactic| refine_lift' let $c:letConfig $d:letDecl; ?_)
 
 /--
 The left hand side of an induction arm, `| foo a b c` or `| @foo a b c`
@@ -1255,7 +1266,7 @@ h : β
 
 This can be used to simulate the `specialize` and `apply at` tactics of Coq.
 -/
-syntax (name := replace) "replace" haveDecl : tactic
+syntax (name := replace) "replace" letDecl : tactic
 
 /-- `and_intros` applies `And.intro` until it does not make progress. -/
 syntax "and_intros" : tactic
@@ -1271,10 +1282,10 @@ syntax (name := substEqs) "subst_eqs" : tactic
 syntax (name := runTac) "run_tac " doSeq : tactic
 
 /-- `haveI` behaves like `have`, but inlines the value instead of producing a `let_fun` term. -/
-macro "haveI" d:haveDecl : tactic => `(tactic| refine_lift haveI $d:haveDecl; ?_)
+macro "haveI" c:letConfig d:letDecl : tactic => `(tactic| refine_lift haveI $c:letConfig $d:letDecl; ?_)
 
 /-- `letI` behaves like `let`, but inlines the value instead of producing a `let_fun` term. -/
-macro "letI" d:haveDecl : tactic => `(tactic| refine_lift letI $d:haveDecl; ?_)
+macro "letI" c:letConfig d:letDecl : tactic => `(tactic| refine_lift letI $c:letConfig $d:letDecl; ?_)
 
 /--
 Configuration for the `decide` tactic family.
@@ -1790,307 +1801,6 @@ macro (name := bvNormalizeMacro) (priority:=low) "bv_normalize" optConfig : tact
   Macro.throwError "to use `bv_normalize`, please include `import Std.Tactic.BVDecide`"
 
 
-/--
-`massumption` is like `assumption`, but operating on a stateful `Std.Do.SPred` goal.
-```lean
-example (P Q : SPred σs) : Q ⊢ₛ P → Q := by
-  mintro _ _
-  massumption
-```
--/
-macro (name := massumptionMacro) (priority:=low) "massumption" : tactic =>
-  Macro.throwError "to use `massumption`, please include `import Std.Tactic.Do`"
-
-
-/--
-`mclear` is like `clear`, but operating on a stateful `Std.Do.SPred` goal.
-```lean
-example (P Q : SPred σs) : P ⊢ₛ Q → Q := by
-  mintro HP
-  mintro HQ
-  mclear HP
-  mexact HQ
-```
--/
-macro (name := mclearMacro) (priority:=low) "mclear" : tactic =>
-  Macro.throwError "to use `mclear`, please include `import Std.Tactic.Do`"
-
-
-/--
-`mconstructor` is like `constructor`, but operating on a stateful `Std.Do.SPred` goal.
-```lean
-example (Q : SPred σs) : Q ⊢ₛ Q ∧ Q := by
-  mintro HQ
-  mconstructor <;> mexact HQ
-```
--/
-macro (name := mconstructorMacro) (priority:=low) "mconstructor" : tactic =>
-  Macro.throwError "to use `mconstructor`, please include `import Std.Tactic.Do`"
-
-
-/--
-`mexact` is like `exact`, but operating on a stateful `Std.Do.SPred` goal.
-```lean
-example (Q : SPred σs) : Q ⊢ₛ Q := by
-  mstart
-  mintro HQ
-  mexact HQ
-```
--/
-macro (name := mexactMacro) (priority:=low) "mexact" : tactic =>
-  Macro.throwError "to use `mexact`, please include `import Std.Tactic.Do`"
-
-
-/--
-`mexfalso` is like `exfalso`, but operating on a stateful `Std.Do.SPred` goal.
-```lean
-example (P : SPred σs) : ⌜False⌝ ⊢ₛ P := by
-  mintro HP
-  mexfalso
-  mexact HP
-```
--/
-macro (name := mexfalsoMacro) (priority:=low) "mexfalso" : tactic =>
-  Macro.throwError "to use `mexfalso`, please include `import Std.Tactic.Do`"
-
-
-/--
-`mexists` is like `exists`, but operating on a stateful `Std.Do.SPred` goal.
-```lean
-example (ψ : Nat → SPred σs) : ψ 42 ⊢ₛ ∃ x, ψ x := by
-  mintro H
-  mexists 42
-```
--/
-macro (name := mexistsMacro) (priority:=low) "mexists" : tactic =>
-  Macro.throwError "to use `mexists`, please include `import Std.Tactic.Do`"
-
-
-/--
-`mframe` infers which hypotheses from the stateful context can be moved into the pure context.
-This is useful because pure hypotheses "survive" the next application of modus ponens
-(`Std.Do.SPred.mp`) and transitivity (`Std.Do.SPred.entails.trans`).
-
-It is used as part of the `mspec` tactic.
-
-```lean
-example (P Q : SPred σs) : ⊢ₛ ⌜p⌝ ∧ Q ∧ ⌜q⌝ ∧ ⌜r⌝ ∧ P ∧ ⌜s⌝ ∧ ⌜t⌝ → Q := by
-  mintro _
-  mframe
-  /- `h : p ∧ q ∧ r ∧ s ∧ t` in the pure context -/
-  mcases h with hP
-  mexact h
-```
--/
-macro (name := mframeMacro) (priority:=low) "mframe" : tactic =>
-  Macro.throwError "to use `mframe`, please include `import Std.Tactic.Do`"
-
-
-/--
-`mhave` is like `have`, but operating on a stateful `Std.Do.SPred` goal.
-```lean
-example (P Q : SPred σs) : P ⊢ₛ (P → Q) → Q := by
-  mintro HP HPQ
-  mhave HQ : Q := by mspecialize HPQ HP; mexact HPQ
-  mexact HQ
-```
--/
-macro (name := mhaveMacro) (priority:=low) "mhave" : tactic =>
-  Macro.throwError "to use `mhave`, please include `import Std.Tactic.Do`"
-
-
-/--
-`mreplace` is like `replace`, but operating on a stateful `Std.Do.SPred` goal.
-```lean
-example (P Q : SPred σs) : P ⊢ₛ (P → Q) → Q := by
-  mintro HP HPQ
-  mreplace HPQ : Q := by mspecialize HPQ HP; mexact HPQ
-  mexact HPQ
-```
--/
-macro (name := mreplaceMacro) (priority:=low) "mreplace" : tactic =>
-  Macro.throwError "to use `mreplace`, please include `import Std.Tactic.Do`"
-
-
-/--
-`mleft` is like `left`, but operating on a stateful `Std.Do.SPred` goal.
-```lean
-example (P Q : SPred σs) : P ⊢ₛ P ∨ Q := by
-  mintro HP
-  mleft
-  mexact HP
-```
--/
-macro (name := mleftMacro) (priority:=low) "mleft" : tactic =>
-  Macro.throwError "to use `mleft`, please include `import Std.Tactic.Do`"
-
-
-/--
-`mright` is like `right`, but operating on a stateful `Std.Do.SPred` goal.
-```lean
-example (P Q : SPred σs) : P ⊢ₛ Q ∨ P := by
-  mintro HP
-  mright
-  mexact HP
-```
--/
-macro (name := mrightMacro) (priority:=low) "mright" : tactic =>
-  Macro.throwError "to use `mright`, please include `import Std.Tactic.Do`"
-
-
-/--
-`mpure` moves a pure hypothesis from the stateful context into the pure context.
-```lean
-example (Q : SPred σs) (ψ : φ → ⊢ₛ Q): ⌜φ⌝ ⊢ₛ Q := by
-  mintro Hφ
-  mpure Hφ
-  mexact (ψ Hφ)
-```
--/
-macro (name := mpureMacro) (priority:=low) "mpure" : tactic =>
-  Macro.throwError "to use `mpure`, please include `import Std.Tactic.Do`"
-
-
-/--
-`mpure_intro` operates on a stateful `Std.Do.SPred` goal of the form `P ⊢ₛ ⌜φ⌝`.
-It leaves the stateful proof mode (thereby discarding `P`), leaving the regular goal `φ`.
-```lean
-theorem simple : ⊢ₛ (⌜True⌝ : SPred σs) := by
-  mpure_intro
-  exact True.intro
-```
--/
-macro (name := mpureIntroMacro) (priority:=low) "mpure_intro" : tactic =>
-  Macro.throwError "to use `mpure_intro`, please include `import Std.Tactic.Do`"
-
-
-/--
-`mrevert` is like `revert`, but operating on a stateful `Std.Do.SPred` goal.
-```lean
-example (P Q R : SPred σs) : P ∧ Q ∧ R ⊢ₛ P → R := by
-  mintro ⟨HP, HQ, HR⟩
-  mrevert HR
-  mrevert HP
-  mintro HP'
-  mintro HR'
-  mexact HR'
-```
--/
-macro (name := mrevertMacro) (priority:=low) "mrevert" : tactic =>
-  Macro.throwError "to use `mrevert`, please include `import Std.Tactic.Do`"
-
-
-/--
-`mspecialize` is like `specialize`, but operating on a stateful `Std.Do.SPred` goal.
-It specializes a hypothesis from the stateful context with hypotheses from either the pure
-or stateful context or pure terms.
-```lean
-example (P Q : SPred σs) : P ⊢ₛ (P → Q) → Q := by
-  mintro HP HPQ
-  mspecialize HPQ HP
-  mexact HPQ
-
-example (y : Nat) (P Q : SPred σs) (Ψ : Nat → SPred σs) (hP : ⊢ₛ P) : ⊢ₛ Q → (∀ x, P → Q → Ψ x) → Ψ (y + 1) := by
-  mintro HQ HΨ
-  mspecialize HΨ (y + 1) hP HQ
-  mexact HΨ
-```
--/
-macro (name := mspecializeMacro) (priority:=low) "mspecialize" : tactic =>
-  Macro.throwError "to use `mspecialize`, please include `import Std.Tactic.Do`"
-
-
-/--
-`mspecialize_pure` is like `mspecialize`, but it specializes a hypothesis from the
-*pure* context with hypotheses from either the pure or stateful context or pure terms.
-```lean
-example (y : Nat) (P Q : SPred σs) (Ψ : Nat → SPred σs) (hP : ⊢ₛ P) (hΨ : ∀ x, ⊢ₛ P → Q → Ψ x) : ⊢ₛ Q → Ψ (y + 1) := by
-  mintro HQ
-  mspecialize_pure (hΨ (y + 1)) hP HQ => HΨ
-  mexact HΨ
-```
--/
-macro (name := mspecializePureMacro) (priority:=low) "mspecialize_pure" : tactic =>
-  Macro.throwError "to use `mspecialize_pure`, please include `import Std.Tactic.Do`"
-
-
-/--
-Start the stateful proof mode of `Std.Do.SPred`.
-This will transform a stateful goal of the form `H ⊢ₛ T` into `⊢ₛ H → T`
-upon which `mintro` can be used to re-introduce `H` and give it a name.
-It is often more convenient to use `mintro` directly, which will
-try `mstart` automatically if necessary.
--/
-macro (name := mstartMacro) (priority:=low) "mstart" : tactic =>
-  Macro.throwError "to use `mstart`, please include `import Std.Tactic.Do`"
-
-
-/--
-Stops the stateful proof mode of `Std.Do.SPred`.
-This will simply forget all the names given to stateful hypotheses and pretty-print
-a bit differently.
--/
-macro (name := mstopMacro) (priority:=low) "mstop" : tactic =>
-  Macro.throwError "to use `mstop`, please include `import Std.Tactic.Do`"
-
-
-/--
-Like `rcases`, but operating on stateful `Std.Do.SPred` goals.
-Example: Given a goal `h : (P ∧ (Q ∨ R) ∧ (Q → R)) ⊢ₛ R`,
-`mcases h with ⟨-, ⟨hq | hr⟩, hqr⟩` will yield two goals:
-`(hq : Q, hqr : Q → R) ⊢ₛ R` and `(hr : R) ⊢ₛ R`.
-
-That is, `mcases h with pat` has the following semantics, based on `pat`:
-* `pat=□h'` renames `h` to `h'` in the stateful context, regardless of whether `h` is pure
-* `pat=⌜h'⌝` introduces `h' : φ`  to the pure local context if `h : ⌜φ⌝`
-  (c.f. `Lean.Elab.Tactic.Do.ProofMode.IsPure`)
-* `pat=h'` is like `pat=⌜h'⌝` if `h` is pure
-  (c.f. `Lean.Elab.Tactic.Do.ProofMode.IsPure`), otherwise it is like `pat=□h'`.
-* `pat=_` renames `h` to an inaccessible name
-* `pat=-` discards `h`
-* `⟨pat₁, pat₂⟩` matches on conjunctions and existential quantifiers and recurses via
-  `pat₁` and `pat₂`.
-* `⟨pat₁ | pat₂⟩` matches on disjunctions, matching the left alternative via `pat₁` and the right
-  alternative via `pat₂`.
--/
-macro (name := mcasesMacro) (priority:=low) "mcases" : tactic =>
-  Macro.throwError "to use `mcases`, please include `import Std.Tactic.Do`"
-
-
-/--
-Like `refine`, but operating on stateful `Std.Do.SPred` goals.
-```lean
-example (P Q R : SPred σs) : (P ∧ Q ∧ R) ⊢ₛ P ∧ R := by
-  mintro ⟨HP, HQ, HR⟩
-  mrefine ⟨HP, HR⟩
-
-example (ψ : Nat → SPred σs) : ψ 42 ⊢ₛ ∃ x, ψ x := by
-  mintro H
-  mrefine ⟨⌜42⌝, H⟩
-```
--/
-macro (name := mrefineMacro) (priority:=low) "mrefine" : tactic =>
-  Macro.throwError "to use `mrefine`, please include `import Std.Tactic.Do`"
-
-
-/--
-Like `intro`, but introducing stateful hypotheses into the stateful context of the `Std.Do.SPred`
-proof mode.
-That is, given a stateful goal `(hᵢ : Hᵢ)* ⊢ₛ P → T`, `mintro h` transforms
-into `(hᵢ : Hᵢ)*, (h : P) ⊢ₛ T`.
-
-Furthermore, `mintro ∀s` is like `intro s`, but preserves the stateful goal.
-That is, `mintro ∀s` brings the topmost state variable `s:σ` in scope and transforms
-`(hᵢ : Hᵢ)* ⊢ₛ T` (where the entailment is in `Std.Do.SPred (σ::σs)`) into
-`(hᵢ : Hᵢ s)* ⊢ₛ T s` (where the entailment is in `Std.Do.SPred σs`).
-
-Beyond that, `mintro` supports the full syntax of `mcases` patterns
-(`mintro pat = (mintro h; mcases h with pat`), and can perform multiple
-introductions in sequence.
--/
-macro (name := mintroMacro) (priority:=low) "mintro" : tactic =>
-  Macro.throwError "to use `mintro`, please include `import Std.Tactic.Do`"
-
 end Tactic
 
 namespace Attr

src/Lean.lean

@@ -42,5 +42,6 @@ import Lean.PremiseSelection
 import Lean.Namespace
 import Lean.EnvExtension
 import Lean.ErrorExplanation
+import Lean.ErrorExplanations
 import Lean.DefEqAttrib
 import Lean.Shell

src/Lean/Compiler/IR/ToIR.lean

@@ -197,9 +197,9 @@ partial def lowerCode (c : LCNF.Code) : M FnBody := do
     match (← get).fvars[cases.discr]? with
     | some (.var varId) =>
       return .case cases.typeName
-                  varId
-                  (← lowerType cases.resultType)
-                  (← cases.alts.mapM (lowerAlt varId))
+                   varId
+                   (← lowerType cases.resultType)
+                   (← cases.alts.mapM (lowerAlt varId))
     | some (.joinPoint ..) | some .erased | none => panic! "unexpected value"
   | .return fvarId =>
     let arg := match (← get).fvars[fvarId]? with
@@ -346,7 +346,7 @@ partial def lowerLet (decl : LCNF.LetDecl) (k : LCNF.Code) : M FnBody := do
             let restArgs := irArgs.extract numParams irArgs.size
             mkPartialApp (.fap name firstArgs) restArgs
         else
-          throwError f!"axiom '{name}' not supported by code generator; consider marking definition as 'noncomputable'"
+          throwNamedError lean.dependsOnNoncomputable f!"axiom '{name}' not supported by code generator; consider marking definition as 'noncomputable'"
       | some (.quotInfo ..) =>
         if name == ``Quot.mk then
           match irArgs[2]! with

src/Lean/Compiler/LCNF/CSE.lean

@@ -7,6 +7,7 @@ prelude
 import Lean.Compiler.LCNF.CompilerM
 import Lean.Compiler.LCNF.ToExpr
 import Lean.Compiler.LCNF.PassManager
+import Lean.Compiler.NeverExtractAttr
 
 namespace Lean.Compiler.LCNF
 
@@ -44,6 +45,13 @@ def replaceFun (decl : FunDecl) (fvarId : FVarId) : M Unit := do
   eraseFunDecl decl
   addFVarSubst decl.fvarId fvarId
 
+def hasNeverExtract (v : LetValue) : CompilerM Bool :=
+  match v with
+  | .const declName .. =>
+    return hasNeverExtractAttribute (← getEnv) declName
+  | .lit _ | .erased | .proj .. | .fvar .. =>
+    return false
+
 partial def _root_.Lean.Compiler.LCNF.Code.cse (shouldElimFunDecls : Bool) (code : Code) : CompilerM Code :=
   go code |>.run' {}
 where
@@ -57,18 +65,21 @@ where
     match code with
     | .let decl k =>
       let decl ← normLetDecl decl
-      -- We only apply CSE to pure code
-      let key := decl.value.toExpr
-      match (← get).map.find? key with
-      | some fvarId =>
-        replaceLet decl fvarId
-        go k
-      | none =>
-        addEntry key decl.fvarId
+      if (← hasNeverExtract decl.value) then
         return code.updateLet! decl (← go k)
+      else
+        -- We only apply CSE to pure code
+        let key := decl.value.toExpr
+        match (← get).map.find? key with
+        | some fvarId =>
+          replaceLet decl fvarId
+          go k
+        | none =>
+          addEntry key decl.fvarId
+          return code.updateLet! decl (← go k)
     | .fun decl k =>
+      let decl ← goFunDecl decl
       if shouldElimFunDecls then
-        let decl ← goFunDecl decl
         let value := decl.toExpr
         match (← get).map.find? value with
         | some fvarId' =>
@@ -78,7 +89,6 @@ where
           addEntry value decl.fvarId
           return code.updateFun! decl (← go k)
       else
-        let decl ← goFunDecl decl
         return code.updateFun! decl (← go k)
     | .jp decl k =>
       let decl ← goFunDecl decl

src/Lean/Compiler/LCNF/CompilerM.lean

@@ -19,8 +19,6 @@ inductive Phase where
   | base
   /-- In this phase polymorphism has been eliminated. -/
   | mono
-  /-- In this phase impure stuff such as RC or efficient BaseIO transformations happen. -/
-  | impure
   deriving Inhabited
 
 /--

src/Lean/Compiler/LCNF/OtherDecl.lean

@@ -16,6 +16,5 @@ def getOtherDeclType (declName : Name) (us : List Level := []) : CompilerM Expr
   match (← getPhase) with
   | .base => getOtherDeclBaseType declName us
   | .mono => getOtherDeclMonoType declName
-  | _ => unreachable! -- TODO
 
 end Lean.Compiler.LCNF

src/Lean/Compiler/LCNF/PassManager.lean

@@ -14,7 +14,6 @@ namespace Lean.Compiler.LCNF
 def Phase.toNat : Phase → Nat
   | .base => 0
   | .mono => 1
-  | .impure => 2
 
 instance : LT Phase where
   lt l r := l.toNat < r.toNat
@@ -90,7 +89,6 @@ instance : ToString Phase where
   toString
     | .base => "base"
     | .mono => "mono"
-    | .impure => "impure"
 
 namespace Pass
 

src/Lean/Compiler/LCNF/PhaseExt.lean

@@ -76,13 +76,11 @@ def Decl.save (decl : Decl) : CompilerM Unit := do
   match (← getPhase) with
   | .base => decl.saveBase
   | .mono => decl.saveMono
-  | _ => unreachable!
 
 def getDeclAt? (declName : Name) (phase : Phase) : CoreM (Option Decl) :=
   match phase with
   | .base => getBaseDecl? declName
   | .mono => getMonoDecl? declName
-  | _  => return none -- TODO
 
 def getDecl? (declName : Name) : CompilerM (Option Decl) := do
   getDeclAt? declName (← getPhase)
@@ -91,7 +89,6 @@ def getExt (phase : Phase) : DeclExt :=
   match phase with
   | .base => baseExt
   | .mono => monoExt
-  | _ => unreachable!
 
 def forEachDecl (f : Decl → CoreM Unit) (phase := Phase.base) : CoreM Unit := do
   let ext := getExt phase

src/Lean/Compiler/LCNF/ToLCNF.lean

@@ -13,6 +13,7 @@ import Lean.Compiler.LCNF.Types
 import Lean.Compiler.LCNF.Bind
 import Lean.Compiler.LCNF.InferType
 import Lean.Compiler.LCNF.Util
+import Lean.Compiler.NeverExtractAttr
 
 namespace Lean.Compiler.LCNF
 namespace ToLCNF
@@ -200,6 +201,11 @@ structure State where
   lctx : LocalContext := {}
   /-- Cache from Lean regular expression to LCNF argument. -/
   cache : PHashMap Expr Arg := {}
+  /--
+  Determines whether caching has been disabled due to finding a use of
+  a constant marked with `never_extract`.
+  -/
+  shouldCache : Bool := true
   /-- `toLCNFType` cache -/
   typeCache : Std.HashMap Expr Expr := {}
   /-- isTypeFormerType cache -/
@@ -433,7 +439,7 @@ where
       | .lit lit     => visitLit lit
       | .fvar fvarId => if (← get).toAny.contains fvarId then pure .erased else pure (.fvar fvarId)
       | .forallE .. | .mvar .. | .bvar .. | .sort ..  => unreachable!
-    modify fun s => { s with cache := s.cache.insert e r }
+    modify fun s => if s.shouldCache then { s with cache := s.cache.insert e r } else s
     return r
 
   visit (e : Expr) : M Arg := withIncRecDepth do
@@ -474,8 +480,11 @@ where
 
   /-- Giving `f` a constant `.const declName us`, convert `args` into `args'`, and return `.const declName us args'` -/
   visitAppDefaultConst (f : Expr) (args : Array Expr) : M Arg := do
-    let .const declName us := CSimp.replaceConstants (← getEnv) f | unreachable!
+    let env ← getEnv
+    let .const declName us := CSimp.replaceConstants env f | unreachable!
     let args ← args.mapM visitAppArg
+    if hasNeverExtractAttribute env declName then
+      modify fun s => {s with shouldCache := false }
     letValueToArg <| .const declName us args
 
   /-- Eta expand if under applied, otherwise apply k -/

src/Lean/Compiler/LCNF/ToMono.lean

@@ -30,7 +30,7 @@ def isTrivialConstructorApp? (declName : Name) (args : Array Arg) : ToMonoM (Opt
 
 def checkFVarUse (fvarId : FVarId) : ToMonoM Unit := do
   if let some declName := (← get).noncomputableVars.get? fvarId then
-    throwError f!"failed to compile definition, consider marking it as 'noncomputable' because it depends on '{declName}', which is 'noncomputable'"
+    throwNamedError lean.dependsOnNoncomputable f!"failed to compile definition, consider marking it as 'noncomputable' because it depends on '{declName}', which is 'noncomputable'"
 
 def checkFVarUseDeferred (resultFVar fvarId : FVarId) : ToMonoM Unit := do
   if let some declName := (← get).noncomputableVars.get? fvarId then
@@ -247,6 +247,37 @@ partial def casesStringToMono (c : Cases) (_ : c.typeName == ``String) : ToMonoM
   let k ← k.toMono
   return .let decl k
 
+/-- Eliminate `cases` for `Thunk. -/
+partial def casesThunkToMono (c : Cases) (_ : c.typeName == ``Thunk) : ToMonoM Code := do
+  assert! c.alts.size == 1
+  let .alt _ ps k := c.alts[0]! | unreachable!
+  eraseParams ps
+  let p := ps[0]!
+  let letValue := .const ``Thunk.get [] #[.erased, .fvar c.discr]
+  let letDecl ← mkLetDecl (← mkFreshBinderName `_x) anyExpr letValue
+  let paramType := .const `PUnit []
+  let decl := {
+    fvarId := p.fvarId
+    binderName := p.binderName
+    type := (← mkArrow paramType anyExpr)
+    params := #[← mkAuxParam paramType]
+    value := .let letDecl (.return letDecl.fvarId)
+  }
+  modifyLCtx fun lctx => lctx.addFunDecl decl
+  let k ← k.toMono
+  return .fun decl k
+
+/-- Eliminate `cases` for `Task. -/
+partial def casesTaskToMono (c : Cases) (_ : c.typeName == ``Task) : ToMonoM Code := do
+  assert! c.alts.size == 1
+  let .alt _ ps k := c.alts[0]! | unreachable!
+  eraseParams ps
+  let p := ps[0]!
+  let decl := { fvarId := p.fvarId, binderName := p.binderName, type := anyExpr, value := .const ``Task.get [] #[.erased, .fvar c.discr] }
+  modifyLCtx fun lctx => lctx.addLetDecl decl
+  let k ← k.toMono
+  return .let decl k
+
 /-- Eliminate `cases` for trivial structure. See `hasTrivialStructure?` -/
 partial def trivialStructToMono (info : TrivialStructureInfo) (c : Cases) : ToMonoM Code := do
   assert! c.alts.size == 1
@@ -294,6 +325,10 @@ partial def Code.toMono (code : Code) : ToMonoM Code := do
       casesFloatArrayToMono c h
     else if h : c.typeName == ``String then
       casesStringToMono c h
+    else if h : c.typeName == ``Thunk then
+      casesThunkToMono c h
+    else if h : c.typeName == ``Task then
+      casesTaskToMono c h
     else if let some info ← hasTrivialStructure? c.typeName then
       trivialStructToMono info c
     else

src/Lean/Data/RArray.lean

@@ -37,13 +37,12 @@ theorem RArray.get_ofFn {n : Nat} (f : Fin n → α) (h : 0 < n) (i : Fin n) :
   go 0 n h (Nat.le_refl _) (Nat.zero_le _) i.2
 where
   go lb ub h1 h2 (h3 : lb ≤ i.val) (h3 : i.val < ub) : (ofFn.go f lb ub h1 h2).get i = f i := by
-    induction lb, ub, h1, h2 using RArray.ofFn.go.induct (n := n)
+    fun_induction RArray.ofFn.go
     case case1 =>
-      simp [ofFn.go, RArray.get_eq_getImpl, RArray.getImpl]
+      simp only [get_eq_getImpl, getImpl]
       congr
       omega
     case case2 ih1 ih2 hiu =>
-      rw [ofFn.go]; simp only [↓reduceDIte, *]
       simp [RArray.get_eq_getImpl, RArray.getImpl] at *
       split
       · rw [ih1] <;> omega
@@ -55,9 +54,9 @@ theorem RArray.size_ofFn {n : Nat} (f : Fin n → α) (h : 0 < n) :
   go 0 n h (Nat.le_refl _)
 where
   go lb ub h1 h2 : (ofFn.go f lb ub h1 h2).size = ub - lb := by
-    induction lb, ub, h1, h2 using RArray.ofFn.go.induct (n := n)
-    case case1 => simp [ofFn.go, size]
-    case case2 ih1 ih2 hiu => rw [ofFn.go]; simp +zetaDelta [size, *]; omega
+    fun_induction ofFn.go
+    case case1 => simp [size]
+    case case2 ih1 ih2 hiu => simp[size]; omega
 
 open Meta in
 def RArray.toExpr (ty : Expr) (f : α → Expr) (a : RArray α) : MetaM Expr := do

src/Lean/Elab/Binders.lean

@@ -687,13 +687,64 @@ open Lean.Elab.Term.Quotation in
       mkLambdaFVars xs e
   | _ => throwUnsupportedSyntax
 
-/-- If `useLetExpr` is true, then a kernel let-expression `let x : type := val; body` is created.
-   Otherwise, we create a term of the form `letFun val (fun (x : type) => body)`
+/--
+Configuration for `let` elaboration.
+-/
+structure LetConfig where
+  /-- Elaborate as a nondependent `let` (a `have`). -/
+  nondep : Bool := false
+  /-- Eliminate the `let` if it is unused by the body. -/
+  usedOnly : Bool := false
+  /-- Zeta reduces (inlines) the `let`. -/
+  zeta : Bool := false
+  /-- Postpone elaboration of the value until after the body is elaborated. -/
+  postponeValue : Bool := false
+  /-- Generalize the value from the expected type when elaborating the body. -/
+  generalize : Bool := false
+  /-- For `let x := v; b`, adds `eq : x = v` to the context. -/
+  eq? : Option Ident := none
 
-   The default elaboration order is `binders`, `typeStx`, `valStx`, and `body`.
-   If `elabBodyFirst == true`, then we use the order `binders`, `typeStx`, `body`, and `valStx`. -/
+def LetConfig.setFrom (config : LetConfig) (key : Syntax) (val : Bool) : LetConfig :=
+  if key.isOfKind ``Parser.Term.letOptNondep then
+    { config with nondep := val }
+  else if key.isOfKind ``Parser.Term.letOptUsedOnly then
+    { config with usedOnly := val }
+  else if key.isOfKind ``Parser.Term.letOptZeta then
+    { config with zeta := val }
+  else if key.isOfKind ``Parser.Term.letOptPostponeValue then
+    { config with postponeValue := val }
+  else if key.isOfKind ``Parser.Term.letOptGeneralize then
+    { config with generalize := val }
+  else
+    config
+
+/--
+Interprets a `Parser.Term.letConfig`.
+-/
+def mkLetConfig (letConfig : Syntax) (initConfig : LetConfig) : TermElabM LetConfig := do
+  let mut config := initConfig
+  unless letConfig.isOfKind ``Parser.Term.letConfig do
+    return config
+  for item in letConfig[0].getArgs do
+    match item with
+    | `(letPosOpt| +$opt:letOpts) => config := config.setFrom opt.raw[0] true
+    | `(letNegOpt| -$opt:letOpts) => config := config.setFrom opt.raw[0] false
+    | `(letOptEq| (eq := $n:ident)) => config := { config with eq? := n }
+    | `(letOptEq| (eq := $b)) => config := { config with eq? := mkIdentFrom b (canonical := true) (← mkFreshBinderNameForTactic `h) }
+    | _ => pure ()
+  return config
+
+/--
+The default elaboration order is `binders`, `typeStx`, `valStx`, and `body`.
+If `config.postponeValue == true`, then we use the order `binders`, `typeStx`, `body`, and `valStx`.
+If `config.generalize == true`, then the value is abstracted from the expected type when elaborating the body.
+-/
 def elabLetDeclAux (id : Syntax) (binders : Array Syntax) (typeStx : Syntax) (valStx : Syntax) (body : Syntax)
-    (expectedType? : Option Expr) (useLetExpr : Bool) (elabBodyFirst : Bool) (usedLetOnly : Bool) : TermElabM Expr := do
+    (expectedType? : Option Expr) (config : LetConfig) : TermElabM Expr := do
+  if config.generalize then
+    if config.postponeValue then
+      throwError "`+postponeValue` and `+generalize` are incompatible"
+    tryPostponeIfNoneOrMVar expectedType?
   let (type, val, binders) ← elabBindersEx binders fun xs => do
     let (binders, fvars) := xs.unzip
     /-
@@ -719,10 +770,10 @@ def elabLetDeclAux (id : Syntax) (binders : Array Syntax) (typeStx : Syntax) (va
     Recall that TC resolution does **not** produce synthetic opaque metavariables.
     -/
     let type ← withSynthesize (postpone := .partial) <| elabType typeStx
-    let letMsg := if useLetExpr then "let" else "have"
+    let letMsg := if config.nondep then "have" else "let"
     registerCustomErrorIfMVar type typeStx m!"failed to infer '{letMsg}' declaration type"
     registerLevelMVarErrorExprInfo type typeStx m!"failed to infer universe levels in '{letMsg}' declaration type"
-    if elabBodyFirst then
+    if config.postponeValue then
       let type ← mkForallFVars fvars type
       let val  ← mkFreshExprMVar type
       pure (type, val, binders)
@@ -742,19 +793,48 @@ def elabLetDeclAux (id : Syntax) (binders : Array Syntax) (typeStx : Syntax) (va
       pure (type, val, binders)
   let kind := kindOfBinderName id.getId
   trace[Elab.let.decl] "{id.getId} : {type} := {val}"
-  let result ← if useLetExpr then
-    withLetDecl id.getId (kind := kind) type val fun x => do
+  let result ←
+    withLetDecl id.getId (kind := kind) type val (nondep := config.nondep) fun x => do
+      let elabBody : TermElabM Expr := do
+        let mut expectedType? := expectedType?
+        if config.generalize then
+          let throwNoType := throwError "failed to elaborate with `+generalize`, expected type is not available"
+          let some expectedType := expectedType? | throwNoType
+          let expectedType ← instantiateMVars expectedType
+          if expectedType.getAppFn.isMVar then throwNoType
+          let motiveBody ← kabstract expectedType (← instantiateMVars val)
+          let motive := motiveBody.instantiate1 x
+          -- When `config.nondep` is false, then `motive` will be definitionally equal to `expectedType`.
+          -- Type correctness only needs to be checked in the `nondep` case:
+          if config.nondep then
+            unless (← isTypeCorrect motive) do
+              throwError "failed to elaborate with `+generalize`, generalized expected type is not type correct:{indentD motive}"
+          expectedType? := motive
+        elabTermEnsuringType body expectedType? >>= instantiateMVars
       addLocalVarInfo id x
-      let body ← elabTermEnsuringType body expectedType?
-      let body ← instantiateMVars body
-      mkLetFVars #[x] body (usedLetOnly := usedLetOnly)
-  else
-    withLocalDecl id.getId (kind := kind) .default type fun x => do
-      addLocalVarInfo id x
-      let body ← elabTermEnsuringType body expectedType?
-      let body ← instantiateMVars body
-      mkLetFun x val body
-  if elabBodyFirst then
+      match config.eq? with
+      | none =>
+        let body ← elabBody
+        if config.zeta then
+          pure <| (← body.abstractM #[x]).instantiate1 val
+        else
+          mkLetFVars #[x] body (usedLetOnly := config.usedOnly) (generalizeNondepLet := false)
+      | some h =>
+        let hTy ← mkEq x val
+        withLetDecl h.getId hTy (← mkEqRefl x) (nondep := true) fun h' => do
+          addLocalVarInfo h h'
+          let body ← elabBody
+          if config.zeta then
+            pure <| (← body.abstractM #[x, h']).instantiateRev #[val, ← mkEqRefl val]
+          else if config.nondep then
+            -- TODO(kmill): Think more about how to encode this case.
+            -- Currently we produce `(fun (x : α) (h : x = val) => b) val rfl`.
+            -- N.B. the nondep lets become lambdas here.
+            let f ← mkLambdaFVars #[x, h'] body
+            return mkApp2 f val (← mkEqRefl val)
+          else
+            mkLetFVars #[x, h'] body (usedLetOnly := config.usedOnly) (generalizeNondepLet := false)
+  if config.postponeValue then
     forallBoundedTelescope type binders.size fun xs type => do
       -- the original `fvars` from above are gone, so add back info manually
       for b in binders, x in xs do
@@ -772,8 +852,19 @@ structure LetIdDeclView where
   value   : Syntax
 
 def mkLetIdDeclView (letIdDecl : Syntax) : LetIdDeclView :=
-  -- `letIdDecl` is of the form `binderIdent >> many bracketedBinder >> optType >> " := " >> termParser
-  let id      := letIdDecl[0]
+  /-
+  def letId := leading_parser binderIdent <|> hygieneInfo
+  def letIdBinder := binderIdent <|> bracketedBinder
+  def letIdLhs := letId >> many letIdBinder >> optType
+  def letIdDecl := leading_parser letIdLhs >> " := " >> termParser
+  -/
+  let letId := letIdDecl[0]
+  let id :=
+    if letId[0].isOfKind hygieneInfoKind then
+      HygieneInfo.mkIdent letId[0] `this (canonical := true)
+    else
+      -- Assumed to be binderIdent
+      letId[0]
   let binders := letIdDecl[1].getArgs
   let optType := letIdDecl[2]
   let type    := expandOptType id optType
@@ -786,52 +877,74 @@ def expandLetEqnsDecl (letDecl : Syntax) (useExplicit := true) : MacroM Syntax :
   let val ← expandMatchAltsIntoMatch ref matchAlts (useExplicit := useExplicit)
   return mkNode `Lean.Parser.Term.letIdDecl #[letDecl[0], letDecl[1], letDecl[2], mkAtomFrom ref " := ", val]
 
-def elabLetDeclCore (stx : Syntax) (expectedType? : Option Expr) (useLetExpr : Bool) (elabBodyFirst : Bool) (usedLetOnly : Bool) : TermElabM Expr := do
-  let letDecl := stx[1][0]
-  let body    := stx[3]
+def elabLetDeclCore (stx : Syntax) (expectedType? : Option Expr) (initConfig : LetConfig) : TermElabM Expr := do
+  let (config, declIdx) ← if stx[1].isOfKind ``Parser.Term.letConfig then
+    pure (← mkLetConfig stx[1] initConfig, 2)
+  else
+    pure (initConfig, 1)
+  let letDecl   := stx[declIdx][0]
+  let body      := stx[declIdx + 2]
   if letDecl.getKind == ``Lean.Parser.Term.letIdDecl then
     let { id, binders, type, value } := mkLetIdDeclView letDecl
     let id ← if id.isIdent then pure id else mkFreshIdent id (canonical := true)
-    elabLetDeclAux id binders type value body expectedType? useLetExpr elabBodyFirst usedLetOnly
+    elabLetDeclAux id binders type value body expectedType? config
   else if letDecl.getKind == ``Lean.Parser.Term.letPatDecl then
     -- node `Lean.Parser.Term.letPatDecl  $ try (termParser >> pushNone >> optType >> " := ") >> termParser
-    if elabBodyFirst then
-      throwError "'let_delayed' with patterns is not allowed"
     let pat     := letDecl[0]
     let optType := letDecl[2]
     let val     := letDecl[4]
     if pat.getKind == ``Parser.Term.hole then
-      -- `let _ := ...` should not be treated as a `letIdDecl`
+      -- `let _ := ...` should be treated as a `letIdDecl`
       let id   ← mkFreshIdent pat (canonical := true)
       let type := expandOptType id optType
-      elabLetDeclAux id #[] type val body expectedType? useLetExpr elabBodyFirst usedLetOnly
+      elabLetDeclAux id #[] type val body expectedType? config
     else
-      -- We are currently treating `let_fun` and `let` the same way when patterns are used.
-      let stxNew ← if optType.isNone then
-        `(match $val:term with | $pat => $body)
+      if config.postponeValue then
+        throwError "`+deferValue` with patterns is not allowed"
+      if config.usedOnly then
+        throwError "`+usedOnly` with patterns is not allowed"
+      if config.zeta then
+        throwError "`+zeta` with patterns is not allowed"
+      -- We are currently ignore `config.nondep` when patterns are used.
+      -- We are also currently ignoring `config.generalize`.
+      let val ← if optType.isNone then
+        `($val:term)
       else
         let type := optType[0][1]
-        `(match ($val:term : $type) with | $pat => $body)
+        `(($val:term : $type))
+      let stxNew ← if let some h := config.eq? then
+        `(match $h:ident : $val:term with | $pat => $body)
+      else
+        `(match $val:term with | $pat => $body)
       withMacroExpansion stx stxNew <| elabTerm stxNew expectedType?
   else if letDecl.getKind == ``Lean.Parser.Term.letEqnsDecl then
     let letDeclIdNew ← liftMacroM <| expandLetEqnsDecl letDecl
-    let declNew := stx[1].setArg 0 letDeclIdNew
-    let stxNew  := stx.setArg 1 declNew
+    let declNew := stx[declIdx].setArg 0 letDeclIdNew
+    let stxNew  := stx.setArg declIdx declNew
     withMacroExpansion stx stxNew <| elabTerm stxNew expectedType?
   else
     throwUnsupportedSyntax
 
 @[builtin_term_elab «let»] def elabLetDecl : TermElab :=
-  fun stx expectedType? => elabLetDeclCore stx expectedType? (useLetExpr := true) (elabBodyFirst := false) (usedLetOnly := false)
+  fun stx expectedType? => elabLetDeclCore stx expectedType? {}
+
+@[builtin_term_elab «have»] def elabHaveDecl : TermElab :=
+  fun stx expectedType? => elabLetDeclCore stx expectedType? { nondep := true }
 
 @[builtin_term_elab «let_fun»] def elabLetFunDecl : TermElab :=
-  fun stx expectedType? => elabLetDeclCore stx expectedType? (useLetExpr := false) (elabBodyFirst := false) (usedLetOnly := false)
+  fun stx expectedType? => elabLetDeclCore stx expectedType? { nondep := true }
 
 @[builtin_term_elab «let_delayed»] def elabLetDelayedDecl : TermElab :=
-  fun stx expectedType? => elabLetDeclCore stx expectedType? (useLetExpr := true) (elabBodyFirst := true) (usedLetOnly := false)
+  fun stx expectedType? => elabLetDeclCore stx expectedType? { postponeValue := true }
 
 @[builtin_term_elab «let_tmp»] def elabLetTmpDecl : TermElab :=
-  fun stx expectedType? => elabLetDeclCore stx expectedType? (useLetExpr := true) (elabBodyFirst := false) (usedLetOnly := true)
+  fun stx expectedType? => elabLetDeclCore stx expectedType? { usedOnly := true }
+
+@[builtin_term_elab «letI»] def elabLetIDecl : TermElab :=
+  fun stx expectedType? => elabLetDeclCore stx expectedType? { zeta := true }
+
+@[builtin_term_elab «haveI»] def elabHaveIDecl : TermElab :=
+  fun stx expectedType? => elabLetDeclCore stx expectedType? { zeta := true, nondep := true }
 
 builtin_initialize
   registerTraceClass `Elab.let

src/Lean/Elab/BuiltinNotation.lean

@@ -117,32 +117,19 @@ open Meta
     ```
     -/
     let thisId := mkIdentFrom stx `this
-    let valNew ← `(let_fun $thisId : $(← exprToSyntax type) := $val; $thisId)
+    let valNew ← `(have $thisId:ident : $(← exprToSyntax type) := $val; $thisId)
     elabTerm valNew expectedType?
   | _ => throwUnsupportedSyntax
 
-@[builtin_macro Lean.Parser.Term.have] def expandHave : Macro := fun stx =>
-  match stx with
-  | `(have $hy:hygieneInfo $bs* $[: $type]? := $val; $body) =>
-    `(have $(HygieneInfo.mkIdent hy `this (canonical := true)) $bs* $[: $type]? := $val; $body)
-  | `(have $hy:hygieneInfo $bs* $[: $type]? $alts; $body)   =>
-    `(have $(HygieneInfo.mkIdent hy `this (canonical := true)) $bs* $[: $type]? $alts; $body)
-  | `(have $x:ident $bs* $[: $type]? := $val; $body) => `(let_fun $x $bs* $[: $type]? := $val; $body)
-  | `(have $x:ident $bs* $[: $type]? $alts; $body)   => `(let_fun $x $bs* $[: $type]? $alts; $body)
-  | `(have _%$x     $bs* $[: $type]? := $val; $body) => `(let_fun _%$x $bs* $[: $type]? := $val; $body)
-  | `(have _%$x     $bs* $[: $type]? $alts; $body)   => `(let_fun _%$x $bs* $[: $type]? $alts; $body)
-  | `(have $pattern:term $[: $type]? := $val; $body) => `(let_fun $pattern:term $[: $type]? := $val; $body)
-  | _                                                => Macro.throwUnsupported
-
 @[builtin_macro Lean.Parser.Term.suffices] def expandSuffices : Macro
-  | `(suffices%$tk $x:ident      : $type from $val; $body)   => `(have%$tk $x : $type := $body; $val)
+  | `(suffices%$tk $x:ident      : $type from $val; $body)   => `(have%$tk $x:ident : $type := $body; $val)
   | `(suffices%$tk _%$x          : $type from $val; $body)   => `(have%$tk _%$x : $type := $body; $val)
   | `(suffices%$tk $hy:hygieneInfo $type from $val; $body)   => `(have%$tk $hy:hygieneInfo : $type := $body; $val)
   | `(suffices%$tk $x:ident      : $type $b:byTactic'; $body) =>
     -- Pass on `SourceInfo` of `b` to `have`. This is necessary to display the goal state in the
     -- trailing whitespace of `by` and sound since `byTactic` and `byTactic'` are identical.
     let b := ⟨b.raw.setKind `Lean.Parser.Term.byTactic⟩
-    `(have%$tk $x : $type := $body; $b:byTactic)
+    `(have%$tk $x:ident : $type := $body; $b:byTactic)
   | `(suffices%$tk _%$x          : $type $b:byTactic'; $body) =>
     let b := ⟨b.raw.setKind `Lean.Parser.Term.byTactic⟩
     `(have%$tk _%$x : $type := $body; $b:byTactic)
@@ -544,28 +531,4 @@ def elabUnsafe : TermElab := fun stx expectedType? =>
       (← `(do $cmds)))
   | _ => throwUnsupportedSyntax
 
-@[builtin_term_elab Lean.Parser.Term.haveI] def elabHaveI : TermElab := fun stx expectedType? => do
-  match stx with
-  | `(haveI $x:ident $bs* : $ty := $val; $body) =>
-    withExpectedType expectedType? fun expectedType => do
-      let (ty, val) ← elabBinders bs fun bs => do
-        let ty ← elabType ty
-        let val ← elabTermEnsuringType val ty
-        pure (← mkForallFVars bs ty, ← mkLambdaFVars bs val)
-      withLocalDeclD x.getId ty fun x => do
-        return (← (← elabTerm body expectedType).abstractM #[x]).instantiate #[val]
-  | _ => throwUnsupportedSyntax
-
-@[builtin_term_elab Lean.Parser.Term.letI] def elabLetI : TermElab := fun stx expectedType? => do
-  match stx with
-  | `(letI $x:ident $bs* : $ty := $val; $body) =>
-    withExpectedType expectedType? fun expectedType => do
-      let (ty, val) ← elabBinders bs fun bs => do
-        let ty ← elabType ty
-        let val ← elabTermEnsuringType val ty
-        pure (← mkForallFVars bs ty, ← mkLambdaFVars bs val)
-      withLetDecl x.getId ty val fun x => do
-        return (← (← elabTerm body expectedType).abstractM #[x]).instantiate #[val]
-  | _ => throwUnsupportedSyntax
-
 end Lean.Elab.Term

src/Lean/Elab/Do.lean

@@ -648,12 +648,22 @@ def concat (terminal : CodeBlock) (kRef : Syntax) (y? : Option Var) (k : CodeBlo
   let terminal ← liftMacroM <| convertTerminalActionIntoJmp terminal.code jp xs
   return { code  := attachJP jpDecl terminal, uvars := k.uvars }
 
-def getLetIdDeclVars (letIdDecl : Syntax) : Array Var :=
-  if letIdDecl[0].isIdent then
-    #[letIdDecl[0]]
+def getLetIdVars (letId : Syntax) : Array Var :=
+  assert! letId.isOfKind ``Parser.Term.letId
+  -- def letId := leading_parser binderIdent <|> hygieneInfo
+  if letId[0].isIdent then
+    #[letId[0]]
+  else if letId[0].isOfKind hygieneInfoKind then
+    #[HygieneInfo.mkIdent letId[0] `this (canonical := true)]
   else
     #[]
 
+def getLetIdDeclVars (letIdDecl : Syntax) : Array Var :=
+  assert! letIdDecl.isOfKind ``Parser.Term.letIdDecl
+  -- def letIdLhs : Parser := letId >> many (ppSpace >> letIdBinder) >> optType
+  -- def letIdDecl := leading_parser letIdLhs >> " := " >> termParser
+  getLetIdVars letIdDecl[0]
+
 -- support both regular and syntax match
 def getPatternVarsEx (pattern : Syntax) : TermElabM (Array Var) :=
   getPatternVars pattern <|>
@@ -664,16 +674,18 @@ def getPatternsVarsEx (patterns : Array Syntax) : TermElabM (Array Var) :=
   Quotation.getPatternsVars patterns
 
 def getLetPatDeclVars (letPatDecl : Syntax) : TermElabM (Array Var) := do
+  -- def letPatDecl := leading_parser termParser >> pushNone >> optType >> " := " >> termParser
   let pattern := letPatDecl[0]
   getPatternVarsEx pattern
 
 def getLetEqnsDeclVars (letEqnsDecl : Syntax) : Array Var :=
-  if letEqnsDecl[0].isIdent then
-    #[letEqnsDecl[0]]
-  else
-    #[]
+  assert! letEqnsDecl.isOfKind ``Parser.Term.letEqnsDecl
+  -- def letIdLhs : Parser := letId >> many (ppSpace >> letIdBinder) >> optType
+  -- def letEqnsDecl := leading_parser letIdLhs >> matchAlts
+  getLetIdVars letEqnsDecl[0]
 
 def getLetDeclVars (letDecl : Syntax) : TermElabM (Array Var) := do
+  -- def letDecl := leading_parser letIdDecl <|> letPatDecl <|> letEqnsDecl
   let arg := letDecl[0]
   if arg.getKind == ``Parser.Term.letIdDecl then
     return getLetIdDeclVars arg
@@ -688,15 +700,9 @@ def getDoLetVars (doLet : Syntax) : TermElabM (Array Var) :=
   -- leading_parser "let " >> optional "mut " >> letDecl
   getLetDeclVars doLet[2]
 
-def getDoHaveVars : Syntax → TermElabM (Array Var)
-  -- NOTE: `hygieneInfo` case should come first as `id` will match anything else
-  | `(doElem| have $info:hygieneInfo $_params* $[$_:typeSpec]? := $_val)
-  | `(doElem| have $info:hygieneInfo $_params* $[$_:typeSpec]? $_eqns:matchAlts) =>
-    return #[HygieneInfo.mkIdent info `this]
-  | `(doElem| have $id $_params* $[$_:typeSpec]? := $_val)
-  | `(doElem| have $id $_params* $[$_:typeSpec]? $_eqns:matchAlts) => return #[id]
-  | `(doElem| have $pat:letPatDecl) => getLetPatDeclVars pat
-  | _ => throwError "unexpected kind of have declaration"
+def getDoHaveVars (doHave : Syntax) : TermElabM (Array Var) :=
+  -- leading_parser "have" >> letDecl
+  getLetDeclVars doHave[1]
 
 def getDoLetRecVars (doLetRec : Syntax) : TermElabM (Array Var) := do
   -- letRecDecls is an array of `(group (optional attributes >> letDecl))`
@@ -1067,7 +1073,7 @@ def declToTerm (decl : Syntax) (k : Syntax) : M Syntax := withRef decl <| withFr
     else
       Macro.throwErrorAt decl "unexpected kind of `do` declaration"
   else if kind == ``Parser.Term.doHave then
-    -- The `have` term is of the form  `"have " >> haveDecl >> optSemicolon termParser`
+    -- The `have` term is of the form  `"have " >> letDecl >> optSemicolon termParser`
     let args := decl.getArgs
     let args := args ++ #[mkNullNode /- optional ';' -/, k]
     return mkNode `Lean.Parser.Term.«have» args

src/Lean/Elab/Frontend.lean

@@ -158,10 +158,10 @@ def runFrontend
       return .ok {
         trustLevel
         mainModuleName := setup.name
-        isModule := setup.isModule
-        imports := setup.imports
+        isModule := strictOr setup.isModule stx.isModule
+        imports := setup.imports?.getD stx.imports
         plugins := plugins ++ setup.plugins
-        modules := setup.modules
+        importArts := setup.importArts
         -- override cmdline options with setup options
         opts := opts.mergeBy (fun _ _ hOpt => hOpt) setup.options.toOptions
       }

src/Lean/Elab/GuardMsgs.lean

@@ -189,7 +189,7 @@ def MessageOrdering.apply (mode : MessageOrdering) (msgs : List String) : List S
       -- Failed. Put all the messages back on the message log and add an error
       modify fun st => { st with messages := initMsgs ++ msgs }
       let feedback :=
-        if (← getOptions).getBool `guard_msgs.diff false then
+        if guard_msgs.diff.get (← getOptions) then
           let diff := Diff.diff (expected.split (· == '\n')).toArray (res.split (· == '\n')).toArray
           Diff.linesToString diff
         else res

src/Lean/Elab/Import.lean

@@ -5,7 +5,6 @@ Authors: Leonardo de Moura, Sebastian Ullrich
 -/
 prelude
 import Lean.Parser.Module
-import Lean.Util.Paths
 import Lean.CoreM
 
 namespace Lean.Elab
@@ -29,13 +28,17 @@ def HeaderSyntax.imports (stx : HeaderSyntax) (includeInit : Bool := true) : Arr
       | _ => unreachable!
   | _ => unreachable!
 
+def HeaderSyntax.toModuleHeader (stx : HeaderSyntax) : ModuleHeader where
+  isModule := stx.isModule
+  imports := stx.imports
+
 abbrev headerToImports := @HeaderSyntax.imports
 
 def processHeaderCore
     (startPos : String.Pos) (imports : Array Import) (isModule : Bool)
     (opts : Options) (messages : MessageLog) (inputCtx : Parser.InputContext)
     (trustLevel : UInt32 := 0) (plugins : Array System.FilePath := #[]) (leakEnv := false)
-    (mainModule := Name.anonymous) (arts : NameMap ModuleArtifacts := {})
+    (mainModule := Name.anonymous) (arts : NameMap ImportArtifacts := {})
     : IO (Environment × MessageLog) := do
   let level := if isModule then
     if Elab.inServer.get opts then
@@ -83,14 +86,12 @@ def parseImports (input : String) (fileName : Option String := none) : IO (Array
   let (header, parserState, messages) ← Parser.parseHeader inputCtx
   pure (headerToImports header, inputCtx.fileMap.toPosition parserState.pos, messages)
 
-@[export lean_print_imports]
 def printImports (input : String) (fileName : Option String) : IO Unit := do
   let (deps, _, _) ← parseImports input fileName
   for dep in deps do
     let fname ← findOLean dep.module
     IO.println fname
 
-@[export lean_print_import_srcs]
 def printImportSrcs (input : String) (fileName : Option String) : IO Unit := do
   let sp ← getSrcSearchPath
   let (deps, _, _) ← parseImports input fileName

src/Lean/Elab/Inductive.lean

@@ -249,7 +249,7 @@ where
               {indentExpr arg}\nis not definitionally equal to the expected parameter{indentExpr param}"
             let noteMsg := m!"The value of parameter '{param}' must be fixed throughout the inductive \
               declaration. Consider making this parameter an index if it must vary."
-            throwError msg ++ .note noteMsg
+            throwNamedError lean.inductiveParamMismatch (msg ++ .note noteMsg)
           args := args.set! i param
         unless args.size ≥ params.size do
           let expected := mkAppN f params
@@ -260,7 +260,7 @@ where
           let noteMsg :=
             m!"All occurrences of an inductive type in the types of its constructors must specify its \
               fixed parameters. Only indices can be omitted in a partial application of the type constructor."
-          throwError msg ++ .note noteMsg
+          throwNamedError lean.inductiveParamMissing (msg ++ .note noteMsg)
         return TransformStep.done (mkAppN f args)
       else
         modify fun es => e :: es
@@ -277,14 +277,14 @@ where
           if (← whnfD decl.type).isForall then
             return m!" an application of"
       return m!""
-    throwErrorAt ctorType "Unexpected resulting type for constructor '{declName}': \
+    throwNamedErrorAt ctorType lean.ctorResultingTypeMismatch "Unexpected resulting type for constructor '{declName}': \
       Expected{lazyAppMsg}{indentExpr indFVar}\nbut found{indentExpr resultingType}"
 
   throwUnexpectedResultingTypeNotType (resultingType : Expr) (declName : Name) (ctorType : Syntax) := do
     let lazyMsg := MessageData.ofLazyM do
       let resultingTypeType ← inferType resultingType
       return indentExpr resultingTypeType
-    throwErrorAt ctorType "Unexpected resulting type for constructor '{declName}': \
+    throwNamedErrorAt ctorType lean.ctorResultingTypeMismatch "Unexpected resulting type for constructor '{declName}': \
       Expected a type, but found{indentExpr resultingType}\nof type{lazyMsg}"
 
 @[builtin_inductive_elab Lean.Parser.Command.inductive, builtin_inductive_elab Lean.Parser.Command.classInductive]

src/Lean/Elab/LetRec.lean

@@ -41,7 +41,7 @@ private def mkLetRecDeclView (letRec : Syntax) : TermElabM LetRecView := do
     if decl.isOfKind `Lean.Parser.Term.letPatDecl then
       throwErrorAt decl "patterns are not allowed in 'let rec' expressions"
     else if decl.isOfKind ``Lean.Parser.Term.letIdDecl || decl.isOfKind ``Lean.Parser.Term.letEqnsDecl then
-      let declId := decl[0]
+      let declId := decl[0][0]
       unless declId.isIdent do
         throwErrorAt declId "'let rec' expressions must be named"
       let shortDeclName := declId.getId

src/Lean/Elab/Match.lean

@@ -19,7 +19,7 @@ open Meta
 open Lean.Parser.Term
 
 private def expandSimpleMatch (stx : Syntax) (discr : Term) (lhsVar : Ident) (rhs : Term) (expectedType? : Option Expr) : TermElabM Expr := do
-  let newStx ← `(let $lhsVar := $discr; $rhs)
+  let newStx ← `(let $lhsVar:ident := $discr; $rhs)
   withMacroExpansion stx newStx <| elabTerm newStx expectedType?
 
 private def mkUserNameFor (e : Expr) : TermElabM Name := do
@@ -670,7 +670,7 @@ where
     match p with
     | .forallE n d b bi  => withLocalDecl n bi (← go d) fun x => do mkForallFVars #[x] (← go (b.instantiate1 x))
     | .lam n d b bi      => withLocalDecl n bi (← go d) fun x => do mkLambdaFVars #[x] (← go (b.instantiate1 x))
-    | .letE n t v b ..  => withLetDecl n (← go t) (← go v) fun x => do mkLetFVars #[x] (← go (b.instantiate1 x))
+    | .letE n t v b nondep => mapLetDecl n (← go t) (← go v) (nondep := nondep) fun x => go (b.instantiate1 x)
     | .app f a          => return mkApp (← go f) (← go a)
     | .proj _ _ b       => return p.updateProj! (← go b)
     | .mdata k b        =>
@@ -1041,7 +1041,7 @@ def reportMatcherResultErrors (altLHSS : List AltLHS) (result : MatcherResult) :
         withRef alt.ref do withInPattern do withExistingLocalDecls alt.fvarDecls do
           let pats ← alt.patterns.mapM fun p => return toMessageData (← Pattern.toExpr p)
           let pats := MessageData.joinSep pats ", "
-          logError (mkRedundantAlternativeMsg none pats)
+          logNamedError lean.redundantMatchAlt (mkRedundantAlternativeMsg none pats)
       i := i + 1
 
 /--

src/Lean/Elab/MutualDef.lean

@@ -869,10 +869,11 @@ private partial def mkClosureForAux (toProcess : Array FVarId) : StateRefT Closu
     | .cdecl _ _ userName type bi k =>
       let toProcess ← pushLocalDecl toProcess fvarId userName type bi k
       mkClosureForAux toProcess
-    | .ldecl _ _ userName type val _ k =>
+    | .ldecl _ _ userName type val nondep k =>
       let zetaDeltaFVarIds ← getZetaDeltaFVarIds
-      if !zetaDeltaFVarIds.contains fvarId then
-        /- Non-dependent let-decl. See comment at src/Lean/Meta/Closure.lean -/
+      -- Note: If `nondep` is true then `zetaDeltaFVarIds.contains fvarId` must be false.
+      if nondep || !zetaDeltaFVarIds.contains fvarId then
+        /- Nondependent let-decl. See comment at src/Lean/Meta/Closure.lean -/
         let toProcess ← pushLocalDecl toProcess fvarId userName type .default k
         mkClosureForAux toProcess
       else

src/Lean/Elab/ParseImportsFast.lean

@@ -229,7 +229,6 @@ structure PrintImportsResult where
   imports : Array PrintImportResult
   deriving ToJson
 
-@[export lean_print_imports_json]
 def printImportsJson (fileNames : Array String) : IO Unit := do
   let rs ← fileNames.mapM fun fn => do
     try

src/Lean/Elab/PreDefinition/Main.lean

@@ -93,7 +93,7 @@ private partial def ensureNoUnassignedLevelMVarsAtPreDef (preDef : PreDefinition
           checkCache { val := e : ExprStructEq } fun _ => do
             match e with
             | .forallE n d b c | .lam n d b c => withExpr e do visit d; withLocalDecl n c d fun x => visit (b.instantiate1 x)
-            | .letE n t v b _ => withExpr e do visit t; visit v; withLetDecl n t v fun x => visit (b.instantiate1 x)
+            | .letE n t v b nondep => withExpr e do visit t; visit v; withLetDecl n t v (nondep := nondep) fun x => visit (b.instantiate1 x)
             | .mdata _ b     => withExpr e do visit b
             | .proj _ _ b    => withExpr e do visit b
             | .sort u        => visitLevel u (← read)
@@ -184,25 +184,25 @@ def checkTerminationByHints (preDefs : Array PreDefinition) : CoreM Unit := do
   let preDefsWithout := preDefs.filter (·.termination.terminationBy?.isNone)
   let structural :=
     preDefWith.termination.terminationBy? matches some {structural := true, ..}
-  -- Information whether the current one is partial, least or greatest
-  let partialFixpoint := preDefWith.termination.partialFixpoint?.any fun x => isPartial x.fixpointType
-  let leastFixpoint := preDefWith.termination.partialFixpoint?.any fun x => isLeast x.fixpointType
-  let greatestFixpoint := preDefWith.termination.partialFixpoint?.any fun x => isGreatest x.fixpointType
+  -- Information whether the current one is partial, inductive or coinductive
+  let partialFixpoint := preDefWith.termination.partialFixpoint?.any fun x => isPartialFixpoint x.fixpointType
+  let inductiveFixpoint := preDefWith.termination.partialFixpoint?.any fun x => isInductiveFixpoint x.fixpointType
+  let coinductiveFixpoint := preDefWith.termination.partialFixpoint?.any fun x => isCoinductiveFixpoint x.fixpointType
   for preDef in preDefs do
     -- if some has at termination by clause
     if let .some termBy := preDef.termination.terminationBy? then
-      -- but something in the clique is partial/least/greatest, then we report error
+      -- but something in the clique is partial/inductive/coinductive, then we report error
       if let .some partialFixpointStx := preDef.termination.partialFixpoint? then
         match partialFixpointStx.fixpointType with
         | .partialFixpoint => throwErrorAt partialFixpointStx.ref m!"conflicting annotations: this function cannot \
           be both terminating and a partial fixpoint"
-        | .leastFixpoint => throwErrorAt partialFixpointStx.ref m!"conflicting annotations: this function cannot \
-          be both terminating and a least fixpoint"
-        | .greatestFixpoint => throwErrorAt partialFixpointStx.ref m!"conflicting annotations: this function cannot \
-          be both terminating and a greatest fixpoint"
+        | .inductiveFixpoint => throwErrorAt partialFixpointStx.ref m!"conflicting annotations: this function cannot \
+          be both terminating and an inductive fixpoint"
+        | .coinductiveFixpoint => throwErrorAt partialFixpointStx.ref m!"conflicting annotations: this function cannot \
+          be both terminating and a coinductive fixpoint"
 
       -- if has no annotations
-      if !structural && !partialFixpoint && !leastFixpoint && !greatestFixpoint && !preDefsWithout.isEmpty then
+      if !structural && !partialFixpoint && !inductiveFixpoint && !coinductiveFixpoint && !preDefsWithout.isEmpty then
         let m := MessageData.andList (preDefsWithout.toList.map (m!"{·.declName}"))
         let doOrDoes := if preDefsWithout.size = 1 then "does" else "do"
         logErrorAt termBy.ref m!"incomplete set of termination hints:\n\
@@ -224,57 +224,57 @@ def checkTerminationByHints (preDefs : Array PreDefinition) : CoreM Unit := do
             structurally recursive, so no explicit termination proof is needed."
 
     -- If one is partial, but others are not
-    if partialFixpoint && !preDef.termination.partialFixpoint?.any fun x => isPartial x.fixpointType then
+    if partialFixpoint && !preDef.termination.partialFixpoint?.any fun x => isPartialFixpoint x.fixpointType then
       throwErrorAt preDef.ref m!"Incompatible termination hint; this function is mutually \
         recursive with {preDefWith.declName}, which is marked as \
         `partial_fixpoint` so this one also needs to be marked \
         `partial_fixpoint`."
 
     -- If one is least, but others are not
-    if leastFixpoint && !preDef.termination.partialFixpoint?.any fun x => isLatticeTheoretic x.fixpointType then
+    if inductiveFixpoint && !preDef.termination.partialFixpoint?.any fun x => isLatticeTheoretic x.fixpointType then
       throwErrorAt preDef.ref m!"Incompatible termination hint; this function is mutually \
         recursive with {preDefWith.declName}, which is marked as
-        `least_fixpoint` so this one also needs to be marked \
-        `least_fixpoint` or `greatest_fixpoint`."
+        `inductive_fixpoint` so this one also needs to be marked \
+        `inductive_fixpoint` or `coinductive_fixpoint`."
 
     -- If one is greatest, but others are not
-    if greatestFixpoint && !preDef.termination.partialFixpoint?.any fun x => isLatticeTheoretic x.fixpointType then
+    if coinductiveFixpoint && !preDef.termination.partialFixpoint?.any fun x => isLatticeTheoretic x.fixpointType then
       throwErrorAt preDef.ref m!"Incompatible termination hint; this function is mutually \
         recursive with {preDefWith.declName}, which is marked as \
-        `greatest_fixpoint` so this one also needs to be marked \
-        `least_fixpoint` or `greatest_fixpoint`."
+        `coinductive_fixpoint` so this one also needs to be marked \
+        `inductive_fixpoint` or `coinductive_fixpoint`."
 
     -- checking for unnecessary `decreasing_by` clause
-    if preDef.termination.partialFixpoint?.any fun x => isPartial x.fixpointType then
+    if preDef.termination.partialFixpoint?.any fun x => isPartialFixpoint x.fixpointType then
         if let .some decr := preDef.termination.decreasingBy? then
           logErrorAt decr.ref m!"Invalid `decreasing_by`; this function is marked as \
             partial_fixpoint, so no explicit termination proof is needed."
 
-    if preDef.termination.partialFixpoint?.any fun x => isLeast x.fixpointType then
+    if preDef.termination.partialFixpoint?.any fun x => isInductiveFixpoint x.fixpointType then
       if let .some decr := preDef.termination.decreasingBy? then
         logErrorAt decr.ref m!"Invalid `decreasing_by`; this function is marked as \
-          least_fixpoint, so no explicit termination proof is needed."
+          inductive_fixpoint, so no explicit termination proof is needed."
 
-    if preDef.termination.partialFixpoint?.any fun x => isLeast x.fixpointType then
+    if preDef.termination.partialFixpoint?.any fun x => isInductiveFixpoint x.fixpointType then
       if let .some decr := preDef.termination.decreasingBy? then
         logErrorAt decr.ref m!"Invalid `decreasing_by`; this function is marked as \
-          greatest_fixpoint, so no explicit termination proof is needed."
+          coinductive_fixpoint, so no explicit termination proof is needed."
 
     -- if the selected one is not marked as partial fixpoint
     if !partialFixpoint then
       if let some stx := preDef.termination.partialFixpoint? then
-        if isPartial stx.fixpointType then
+        if isPartialFixpoint stx.fixpointType then
           throwErrorAt stx.ref m!"Incompatible termination hint; this function is mutually \
             recursive with {preDefWith.declName}, which is not also marked as \
             `partial_fixpoint`, so this one cannot be either."
 
     -- if the selected one is not marked as partial fixpoint
-    unless leastFixpoint || greatestFixpoint do
+    unless inductiveFixpoint || coinductiveFixpoint do
       if let some stx := preDef.termination.partialFixpoint? then
         if isLatticeTheoretic stx.fixpointType then
           throwErrorAt stx.ref m!"Incompatible termination hint; this function is mutually \
             recursive with {preDefWith.declName}, which is not also marked as \
-            `least_fixpoint` or `greatest_fixpoint`, so this one cannot be either."
+            `inductive_fixpoint` or `coinductive_fixpoint`, so this one cannot be either."
 
 /--
 Elaborates the `TerminationHint` in the clique to `TerminationMeasures`

src/Lean/Elab/PreDefinition/PartialFixpoint/Induction.lean

@@ -53,14 +53,13 @@ def CCPOProdProjs (n : Nat) (inst : Expr) : Array Expr := Id.run do
 Unfolds an appropriate `PartialOrder` instance on predicates to quantifications and implications.
 I.e. `ImplicationOrder.instPartialOrder.rel P Q` becomes
 `∀ x y, P x y → Q x y`.
-
 In the premise of the Park induction principle (`lfp_le_of_le_monotone`) we use a monotone map defining the predicate in the eta expanded form. In such a case, besides desugaring the predicate, we need to perform a weak head reduction.
 The optional parameter `reduceConclusion` (false by default) indicates whether we need to perform this reduction.
 -/
 def unfoldPredRel (predType : Expr) (body : Expr) (fixpointType : PartialFixpointType) (reduceConclusion : Bool := false) : MetaM Expr := do
   match fixpointType with
   | .partialFixpoint => throwError "Trying to apply lattice induction to a non-lattice fixpoint. Please report this issue."
-  | .leastFixpoint | .greatestFixpoint =>
+  | .inductiveFixpoint | .coinductiveFixpoint =>
     unless body.isAppOfArity ``PartialOrder.rel 4 do
       throwError "{body} is not an application of partial order"
     let lhsTypes ← forallTelescope predType fun ts _ =>  ts.mapM inferType
@@ -68,15 +67,15 @@ def unfoldPredRel (predType : Expr) (body : Expr) (fixpointType : PartialFixpoin
     let bodyArgs := body.getAppArgs
     withLocalDeclsDND (names.zip lhsTypes) fun exprs => do
       let mut applied  := match fixpointType with
-        | .leastFixpoint => (bodyArgs[2]!, bodyArgs[3]!)
-        | .greatestFixpoint => (bodyArgs[3]!, bodyArgs[2]!)
+        | .inductiveFixpoint => (bodyArgs[2]!, bodyArgs[3]!)
+        | .coinductiveFixpoint => (bodyArgs[3]!, bodyArgs[2]!)
         | .partialFixpoint => panic! "Cannot apply lattice induction to a non-lattice fixpoint"
       for e in exprs do
         applied := (mkApp applied.1 e, mkApp applied.2 e)
       if reduceConclusion then
         match fixpointType with
-        | .leastFixpoint => applied := ((←whnf applied.1), applied.2)
-        | .greatestFixpoint => applied := (applied.1, (←whnf applied.2))
+        | .inductiveFixpoint => applied := ((←whnf applied.1), applied.2)
+        | .coinductiveFixpoint => applied := (applied.1, (←whnf applied.2))
         | .partialFixpoint => throwError "Cannot apply lattice induction to a non-lattice fixpoint"
       mkForallFVars exprs (←mkArrow applied.1 applied.2)
 
@@ -93,8 +92,18 @@ private def numberNames (n : Nat) (base : String) : Array Name :=
   .ofFn (n := n) fun ⟨i, _⟩ =>
     if n == 1 then .mkSimple base else .mkSimple s!"{base}_{i+1}"
 
-def deriveInduction (name : Name) : MetaM Unit :=
-  let inductName := name ++ `fixpoint_induct
+def getInductionPrinciplePostfix (name : Name) : MetaM Name := do
+  let some eqnInfo := eqnInfoExt.find? (← getEnv) name | throwError "{name} is not defined by partial_fixpoint, inductive_fixpoint, nor coinductive_fixpoint"
+  let idx := eqnInfo.declNames.idxOf name
+  let some res := eqnInfo.fixpointType[idx]? | throwError "Cannot get fixpoint type for {name}"
+  match res with
+  | .partialFixpoint => return `fixpoint_induct
+  | .inductiveFixpoint => return `induct
+  | .coinductiveFixpoint => return `coinduct
+
+def deriveInduction (name : Name) : MetaM Unit := do
+  let postFix ← getInductionPrinciplePostfix name
+  let inductName := name ++ postFix
   realizeConst name inductName do
   trace[Elab.definition.partialFixpoint] "Called deriveInduction for {inductName}"
   prependError m!"Cannot derive fixpoint induction principle (please report this issue)" do
@@ -250,7 +259,17 @@ def isInductName (env : Environment) (name : Name) : Bool := Id.run do
   match s with
   | "fixpoint_induct" =>
     if let some eqnInfo := eqnInfoExt.find? env p then
-      return p == eqnInfo.declNames[0]!
+      return p == eqnInfo.declNames[0]! && isPartialFixpoint (eqnInfo.fixpointType[0]!)
+    return false
+  | "coinduct" =>
+    if let some eqnInfo := eqnInfoExt.find? env p then
+      let idx := eqnInfo.declNames.idxOf p
+      return isCoinductiveFixpoint eqnInfo.fixpointType[idx]!
+    return false
+  | "induct" =>
+    if let some eqnInfo := eqnInfoExt.find? env p then
+      let idx := eqnInfo.declNames.idxOf p
+      return isInductiveFixpoint eqnInfo.fixpointType[idx]!
     return false
   | _ => return false
 

src/Lean/Elab/PreDefinition/PartialFixpoint/Main.lean

@@ -75,7 +75,7 @@ private def mkMonoPProd : (hmono₁ hmono₂ : Expr × Expr) → MetaM (Expr ×
   return (← inferType hmonoProof, hmonoProof)
 
 def partialFixpoint (preDefs : Array PreDefinition) : TermElabM Unit := do
-  -- We expect all functions in the clique to have `partial_fixpoint` or `greatest_fixpoint` syntax
+  -- We expect all functions in the clique to have `partial_fixpoint`, `inductive_fixpoint` or `coinductive_fixpoint` syntax
   let hints := preDefs.filterMap (·.termination.partialFixpoint?)
   assert! preDefs.size = hints.size
   -- We check if any fixpoints were defined lattice-theoretically
@@ -90,13 +90,13 @@ def partialFixpoint (preDefs : Array PreDefinition) : TermElabM Unit := do
       let type ← instantiateForall preDef.type xs
       let inst ←
         match hints[i]!.fixpointType with
-        | .greatestFixpoint =>
+        | .coinductiveFixpoint =>
           unless type.isProp do
-            throwError "`greatest_fixpoint` can be only used to define predicates"
+            throwError "`coinductive_fixpoint` can be only used to define predicates"
           pure (mkConst ``ReverseImplicationOrder.instCompleteLattice)
-        | .leastFixpoint =>
+        | .inductiveFixpoint =>
           unless type.isProp do
-            throwError "`least_fixpoint` can be only used to define predicates"
+            throwError "`inductive_fixpoint` can be only used to define predicates"
           pure (mkConst ``ImplicationOrder.instCompleteLattice)
         | .partialFixpoint => try
             synthInstance (← mkAppM ``CCPO #[type])

src/Lean/Elab/PreDefinition/Structural/BRecOn.lean

@@ -133,9 +133,9 @@ private partial def replaceRecApps (recArgInfos : Array RecArgInfo) (positions :
     | Expr.forallE n d b c =>
       withLocalDecl n c (← loop below d) fun x => do
         mkForallFVars #[x] (← loop below (b.instantiate1 x))
-    | Expr.letE n type val body _ =>
-      withLetDecl n (← loop below type) (← loop below val) fun x => do
-        mkLetFVars #[x] (← loop below (body.instantiate1 x)) (usedLetOnly := false)
+    | Expr.letE n type val body nondep =>
+      mapLetDecl n (← loop below type) (← loop below val) (nondep := nondep) (usedLetOnly := false) fun x => do
+        loop below (body.instantiate1 x)
     | Expr.mdata d b =>
       if let some stx := getRecAppSyntax? e then
         withRef stx <| loop below b

src/Lean/Elab/PreDefinition/Structural/IndPred.lean

@@ -50,9 +50,9 @@ private partial def replaceIndPredRecApps (recArgInfo : RecArgInfo) (funType : E
     | Expr.forallE n d b c =>
       withLocalDecl n c (← loop d) fun x => do
         mkForallFVars #[x] (← loop (b.instantiate1 x))
-    | Expr.letE n type val body _ =>
-      withLetDecl n (← loop type) (← loop val) fun x => do
-        mkLetFVars #[x] (← loop (body.instantiate1 x))
+    | Expr.letE n type val body nondep =>
+      mapLetDecl n (← loop type) (← loop val) (nondep := nondep) fun x => do
+        loop (body.instantiate1 x)
     | Expr.mdata d b => do
       if let some stx := getRecAppSyntax? e then
         withRef stx <| loop b

src/Lean/Elab/PreDefinition/Structural/SmartUnfolding.lean

@@ -32,8 +32,9 @@ where
     match e with
     | Expr.lam ..     => lambdaTelescope e fun xs b => do mkLambdaFVars xs (← visit b)
     | Expr.forallE .. => forallTelescope e fun xs b => do mkForallFVars xs (← visit b)
-    | Expr.letE n type val body _ =>
-      withLetDecl n type (← visit val) fun x => do mkLetFVars #[x] (← visit (body.instantiate1 x))
+    | Expr.letE n type val body nondep =>
+      mapLetDecl n type (← visit val) (nondep := nondep) fun x => do
+        visit (body.instantiate1 x)
     | Expr.mdata d b     => return mkMData d (← visit b)
     | Expr.proj n i s    => return mkProj n i (← visit s)
     | Expr.app .. =>

src/Lean/Elab/PreDefinition/TerminationHint.lean

@@ -35,11 +35,11 @@ structure DecreasingBy where
 
 inductive PartialFixpointType where
   | partialFixpoint
-  | greatestFixpoint
-  | leastFixpoint
+  | coinductiveFixpoint
+  | inductiveFixpoint
   deriving Inhabited
 
-/-- A single `partial_fixpoint`, `greatest_fixpoint` or `least_fixpoint` clause -/
+/-- A single `partial_fixpoint`, `inductive_fixpoint` or `coinductive_fixpoint` clause -/
 structure PartialFixpoint where
   ref               : Syntax
   term?             : Option Term
@@ -69,20 +69,20 @@ structure TerminationHints where
   extraParams : Nat
   deriving Inhabited
 
-def isLeast : PartialFixpointType → Bool
-  | .leastFixpoint => true
+def isInductiveFixpoint : PartialFixpointType → Bool
+  | .inductiveFixpoint => true
   | _ => false
 
-def isGreatest : PartialFixpointType → Bool
-  | .greatestFixpoint => true
+def isCoinductiveFixpoint : PartialFixpointType → Bool
+  | .coinductiveFixpoint => true
   | _ => false
 
-def isPartial : PartialFixpointType → Bool
+def isPartialFixpoint : PartialFixpointType → Bool
   | .partialFixpoint => true
   | _ => false
 
-def isLatticeTheoretic (p : PartialFixpointType ) : Bool :=
-  isLeast p ∨ isGreatest p
+def isLatticeTheoretic (p : PartialFixpointType) : Bool :=
+  isInductiveFixpoint p ∨ isCoinductiveFixpoint p
 
 def TerminationHints.none : TerminationHints := ⟨.missing, .none, .none, .none, .none, 0⟩
 
@@ -99,8 +99,8 @@ def TerminationHints.ensureNone (hints : TerminationHints) (reason : String) : C
   | .none, .none, .none, .some partialFixpoint =>
     match partialFixpoint.fixpointType with
     | .partialFixpoint => logWarningAt partialFixpoint.ref m!"unused `partial_fixpoint`, function is {reason}"
-    | .greatestFixpoint => logWarningAt partialFixpoint.ref m!"unused `greatest_fixpoint`, function is {reason}"
-    | .leastFixpoint  => logWarningAt partialFixpoint.ref m!"unused `least_fixpoint`, function is {reason}"
+    | .coinductiveFixpoint => logWarningAt partialFixpoint.ref m!"unused `coinductive_fixpoint`, function is {reason}"
+    | .inductiveFixpoint  => logWarningAt partialFixpoint.ref m!"unused `inductive_fixpoint`, function is {reason}"
   | _, _, _, _=>
     logWarningAt hints.ref m!"unused termination hints, function is {reason}"
 
@@ -160,14 +160,14 @@ def elabTerminationHints {m} [Monad m] [MonadError m] (stx : TSyntax ``suffix) :
         pure (some {ref := t, structural := s.isSome, vars := #[], body})
       | `(terminationBy?|termination_by?) => pure none
       | `(partialFixpoint|partial_fixpoint $[monotonicity $_]?) => pure none
-      | `(greatestFixpoint|greatest_fixpoint $[monotonicity $_]?) => pure none
-      | `(leastFixpoint|least_fixpoint $[monotonicity $_]?) => pure none
+      | `(coinductiveFixpoint|coinductive_fixpoint $[monotonicity $_]?) => pure none
+      | `(inductiveFixpoint|inductive_fixpoint $[monotonicity $_]?) => pure none
       | _ => throwErrorAt t "unexpected `termination_by` syntax"
       else pure none
     let partialFixpoint? : Option PartialFixpoint ← if let some t := t? then match t with
       | `(partialFixpoint|partial_fixpoint $[monotonicity $term?]?) => pure (some {ref := t, term?, fixpointType := .partialFixpoint})
-      | `(greatestFixpoint|greatest_fixpoint $[monotonicity $term?]?) => pure (some {ref := t, term?, fixpointType := .greatestFixpoint})
-      | `(leastFixpoint|least_fixpoint $[monotonicity $term?]?) => pure (some {ref := t, term?, fixpointType := .leastFixpoint})
+      | `(coinductiveFixpoint|coinductive_fixpoint $[monotonicity $term?]?) => pure (some {ref := t, term?, fixpointType := .coinductiveFixpoint})
+      | `(inductiveFixpoint|inductive_fixpoint $[monotonicity $term?]?) => pure (some {ref := t, term?, fixpointType := .inductiveFixpoint})
       | _ => pure none
       else pure none
     let decreasingBy? ← d?.mapM fun d => match d with

src/Lean/Elab/PreDefinition/WF/Fix.lean

@@ -84,9 +84,9 @@ where
     | Expr.forallE n d b c =>
       withLocalDecl n c (← loop F d) fun x => do
         mkForallFVars #[x] (← loop F (b.instantiate1 x))
-    | Expr.letE n type val body _ =>
-      withLetDecl n (← loop F type) (← loop F val) fun x => do
-        mkLetFVars #[x] (← loop F (body.instantiate1 x)) (usedLetOnly := false)
+    | Expr.letE n type val body nondep =>
+      mapLetDecl n (← loop F type) (← loop F val) (nondep := nondep) (usedLetOnly := false) fun x => do
+        loop F (body.instantiate1 x)
     | Expr.mdata d b =>
       if let some stx := getRecAppSyntax? e then
         withRef stx <| loop F b

src/Lean/Elab/PreDefinition/WF/GuessLex.lean

@@ -241,10 +241,10 @@ where
       loop param d
       withLocalDecl n c d fun x => do
         loop param (b.instantiate1 x)
-    | Expr.letE n type val body _ =>
+    | Expr.letE n type val body nondep =>
       loop param type
       loop param val
-      withLetDecl n type val fun x => do
+      withLetDecl n type val (nondep := nondep) fun x => do
         loop param (body.instantiate1 x)
     | Expr.mdata _d b =>
       if let some stx := getRecAppSyntax? e then

src/Lean/Elab/PreDefinition/WF/Preprocess.lean

@@ -110,14 +110,68 @@ builtin_dsimproc paramMatcher (_) := fun e => do
   let matcherApp' := { matcherApp with discrs := discrs', alts := alts' }
   return .continue <| matcherApp'.toExpr
 
-/-- `let x := (wfParam e); body[x] ==> let x := e; body[wfParam y] -/
+private def anyLetValueIsWfParam (e : Expr) : Bool :=
+  match e with
+  | .letE _ _ v b _ => (isWfParam? v).isSome || anyLetValueIsWfParam b
+  | _               => false
+
+private def numLetsWithValueNotIsWfParam (e : Expr) (acc := 0) : Nat :=
+  match e with
+  | .letE _ _ v b _ => if (isWfParam? v).isSome then acc else numLetsWithValueNotIsWfParam b (acc + 1)
+  | _               => acc
+
+private partial def processParamLet (e : Expr) : MetaM Expr := do
+  if let .letE _ t v b _ := e then
+    if let some v' := isWfParam? v then
+      if ← Meta.isProp t then
+        processParamLet <| e.updateLetE! t v' b
+      else
+        let u ← getLevel t
+        let b' := b.instantiate1 <| mkApp2 (.const ``wfParam [u]) t (.bvar 0)
+        processParamLet <| e.updateLetE! t v' b'
+    else
+      let num := numLetsWithValueNotIsWfParam e
+      assert! num > 0
+      letBoundedTelescope e num fun xs b => do
+        let b' ← processParamLet b
+        mkLetFVars (usedLetOnly := false) (generalizeNondepLet := false) xs b'
+  else
+    return e
+
+/--
+`let x : T := (wfParam e); body[x] ==> let x : T := e; body[wfParam y]` if `T` is not a proposition,
+otherwise `... ==> let x : T := e; body[x]`. (Applies to `have`s too.)
+
+Note: simprocs are provided the head of a let telescope, but not intermediate lets.
+-/
 builtin_dsimproc paramLet (_) := fun e => do
-  unless e.isLet do return .continue
-  let some v := isWfParam? e.letValue! | return .continue
-  let u ← getLevel e.letType!
-  let body' := e.letBody!.instantiate1 <|
-    mkApp2 (.const ``wfParam [u]) e.letType! (.bvar 0)
-  return .continue <| e.updateLetE! e.letType! v body'
+  unless e.isLet || anyLetValueIsWfParam e do return .continue
+  return .continue (← processParamLet e)
+
+/--
+Transforms non-Prop `have`s to `let`s, so that the values can be used in GuessLex and decreasing-by proofs.
+These `have`s may have been introdued by `simp`, which converts `let`s to `have`s.
+-/
+private def nonPropHaveToLet (e : Expr) : MetaM Expr := do
+  Meta.transform e (pre := fun e => do
+    if (← Meta.isProof e) then
+      return .done e
+    else if e.isLet then
+      -- Recall that `Meta.transform` processes entire let telescopes,
+      -- so we need to handle the telescope all at once.
+      let lctx ← getLCtx
+      let e' ← letTelescope e fun xs b => do
+        let lctx' ← xs.foldlM (init := lctx) fun lctx' x => do
+          let decl ← x.fvarId!.getDecl
+          -- Clear the flag if it's not a prop.
+          let decl' := decl.setNondep <| ← pure decl.isNondep <&&> Meta.isProp decl.type
+          pure <| lctx'.addDecl decl'
+        withLCtx' lctx' do
+          mkLetFVars (usedLetOnly := false) (generalizeNondepLet := false) xs b
+      return .continue e'
+    else
+      return .continue
+  )
 
 def preprocess (e : Expr) : MetaM Simp.Result := do
   unless wf.preprocess.get (← getOptions) do
@@ -141,9 +195,13 @@ def preprocess (e : Expr) : MetaM Simp.Result := do
           if h : as.size ≥ 2 then
             return .continue (mkAppN as[1] as[2:])
         return .continue
+
+    -- Transform `have`s to `let`s for non-propositions.
+    let e'' ← nonPropHaveToLet e''
+
     let result := { result with expr := e'' }
 
-    trace[Elab.definition.wf] "Attach-introduction:{indentExpr e'}\nto{indentExpr result.expr}\ncleaned up as{indentExpr e''}"
+    trace[Elab.definition.wf] "Attach-introduction:{indentExpr e'}\nto{indentExpr result.expr}"
     result.addLambdas xs
 
 end Lean.Elab.WF

src/Lean/Elab/Tactic.lean

@@ -52,4 +52,3 @@ import Lean.Elab.Tactic.ExposeNames
 import Lean.Elab.Tactic.SimpArith
 import Lean.Elab.Tactic.Show
 import Lean.Elab.Tactic.Lets
-import Lean.Elab.Tactic.Do

src/Lean/Elab/Tactic/BuiltinTactic.lean

@@ -606,11 +606,11 @@ where
 
 @[builtin_tactic replace] def evalReplace : Tactic := fun stx => do
   match stx with
-  | `(tactic| replace $decl:haveDecl) =>
+  | `(tactic| replace $decl:letDecl) =>
     withMainContext do
-      let vars ← Elab.Term.Do.getDoHaveVars (← `(doElem| have $decl:haveDecl))
+      let vars ← Elab.Term.Do.getLetDeclVars decl
       let origLCtx ← getLCtx
-      evalTactic $ ← `(tactic| have $decl:haveDecl)
+      evalTactic $ ← `(tactic| have $decl:letDecl)
       let mut toClear := #[]
       for fv in vars do
         if let some ldecl := origLCtx.findFromUserName? fv.getId then

src/Lean/Elab/Tactic/Conv/Lets.lean

@@ -57,4 +57,17 @@ namespace Lean.Elab.Tactic.Conv
         throwTacticEx `lift_lets (← getMainGoal) m!"made no progress"
       changeLhs lhs'
 
+/-!
+### `let_to_have`
+-/
+
+@[builtin_tactic Lean.Parser.Tactic.Conv.letToHave] elab_rules : tactic
+  | `(conv| let_to_have) => do
+    withMainContext do
+      let lhs ← getLhs
+      let lhs' ← Meta.letToHave lhs
+      if lhs == lhs' then
+        throwTacticEx `let_to_have (← getMainGoal) m!"made no progress"
+      changeLhs lhs'
+
 end Lean.Elab.Tactic.Conv

src/Lean/Elab/Tactic/Do.lean

@@ -1,7 +0,0 @@
-/-
-Copyright (c) 2025 Lean FRO LLC. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Sebastian Graf
--/
-prelude
-import Lean.Elab.Tactic.Do.ProofMode

src/Lean/Elab/Tactic/Do/ProofMode.lean

@@ -1,23 +0,0 @@
-/-
-Copyright (c) 2025 Lean FRO LLC. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Sebastian Graf
--/
-prelude
-import Lean.Elab.Tactic.Do.ProofMode.MGoal
-import Lean.Elab.Tactic.Do.ProofMode.Display
-import Lean.Elab.Tactic.Do.ProofMode.Basic
-import Lean.Elab.Tactic.Do.ProofMode.Clear
-import Lean.Elab.Tactic.Do.ProofMode.Intro
-import Lean.Elab.Tactic.Do.ProofMode.Revert
-import Lean.Elab.Tactic.Do.ProofMode.Exact
-import Lean.Elab.Tactic.Do.ProofMode.Assumption
-import Lean.Elab.Tactic.Do.ProofMode.Pure
-import Lean.Elab.Tactic.Do.ProofMode.Frame
-import Lean.Elab.Tactic.Do.ProofMode.LeftRight
-import Lean.Elab.Tactic.Do.ProofMode.Constructor
-import Lean.Elab.Tactic.Do.ProofMode.Specialize
-import Lean.Elab.Tactic.Do.ProofMode.Cases
-import Lean.Elab.Tactic.Do.ProofMode.Exfalso
-import Lean.Elab.Tactic.Do.ProofMode.Have
-import Lean.Elab.Tactic.Do.ProofMode.Refine

src/Lean/Elab/Tactic/Do/ProofMode/Assumption.lean

@@ -1,52 +0,0 @@
-/-
-Copyright (c) 2025 Lean FRO LLC. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Sebastian Graf
--/
-prelude
-import Std.Tactic.Do.Syntax
-import Lean.Elab.Tactic.Do.ProofMode.Basic
-import Lean.Elab.Tactic.Do.ProofMode.Exact
-import Lean.Elab.Tactic.Do.ProofMode.Focus
-
-namespace Lean.Elab.Tactic.Do.ProofMode
-open Std.Do
-open Lean Elab Tactic Meta
-
-theorem Assumption.assumption_l {σs : List Type} {P Q R : SPred σs} (h : P ⊢ₛ R) : P ∧ Q ⊢ₛ R :=
-  SPred.and_elim_l.trans h
-theorem Assumption.assumption_r {σs : List Type} {P Q R : SPred σs} (h : Q ⊢ₛ R) : P ∧ Q ⊢ₛ R :=
-  SPred.and_elim_r.trans h
-
-partial def MGoal.assumption (goal : MGoal) : OptionT MetaM Expr := do
-  if let some _ := parseEmptyHyp? goal.hyps then
-    failure
-  if let some hyp := parseHyp? goal.hyps then
-    guard (← isDefEq hyp.p goal.target)
-    return mkApp2 (mkConst ``SPred.entails.refl) goal.σs hyp.p
-  if let some (σs, lhs, rhs) := parseAnd? goal.hyps then
-    -- NB: Need to prefer rhs over lhs, like the goal view (Lean.Elab.Tactic.Do.ProofMode.Display).
-    mkApp5 (mkConst ``Assumption.assumption_r) σs lhs rhs goal.target <$> assumption { goal with hyps := rhs }
-    <|>
-    mkApp5 (mkConst ``Assumption.assumption_l) σs lhs rhs goal.target <$> assumption { goal with hyps := lhs }
-  else
-    panic! s!"assumption: hypothesis without proper metadata: {goal.hyps}"
-
-def MGoal.assumptionPure (goal : MGoal) : OptionT MetaM Expr := do
-  let φ := mkApp2 (mkConst ``SPred.tautological) goal.σs goal.target
-  let fvarId ← OptionT.mk (findLocalDeclWithType? φ)
-  let inst ← synthInstance? (mkApp3 (mkConst ``PropAsSPredTautology) φ goal.σs goal.target)
-  return mkApp6 (mkConst ``Exact.from_tautology) φ goal.σs goal.hyps goal.target inst (.fvar fvarId)
-
-@[builtin_tactic Lean.Parser.Tactic.massumption]
-def elabMAssumption : Tactic | _ => do
-  let mvar ← getMainGoal
-  mvar.withContext do
-  let g ← instantiateMVars <| ← mvar.getType
-  let some goal := parseMGoal? g | throwError "not in proof mode"
-
-  let some proof ← liftMetaM <|
-    goal.assumption <|> goal.assumptionPure
-    | throwError "hypothesis not found"
-  mvar.assign proof
-  replaceMainGoal []

src/Lean/Elab/Tactic/Do/ProofMode/Basic.lean

@@ -1,60 +0,0 @@
-/-
-Copyright (c) 2022 Lars König. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Lars König, Mario Carneiro, Sebastian Graf
--/
-prelude
-import Lean.Meta
-import Std.Tactic.Do.Syntax
-import Lean.Elab.Tactic.Do.ProofMode.MGoal
-
-namespace Lean.Elab.Tactic.Do.ProofMode
-open Std.Do
-open Lean Elab.Tactic Meta
-
-structure MStartResult where
-  goal : MGoal
-  proof? : Option Expr := none
-
-def mStart (goal : Expr) : MetaM MStartResult := do
-  -- check if already in proof mode
-  if let some mgoal := parseMGoal? goal then
-    return { goal := mgoal }
-
-  let listType := mkApp (mkConst ``List [.succ .zero]) (mkSort (.succ .zero))
-  let σs ← mkFreshExprMVar listType
-  let P ← mkFreshExprMVar (mkApp (mkConst ``SPred) σs)
-  let inst ← synthInstance (mkApp3 (mkConst ``PropAsSPredTautology) goal σs P)
-  let prf := mkApp4 (mkConst ``ProofMode.start_entails) σs P goal inst
-  let goal : MGoal := { σs,  hyps := emptyHyp σs, target := ← instantiateMVars P }
-  return { goal, proof? := some prf }
-
-def mStartMVar (mvar : MVarId) : MetaM (MVarId × MGoal) := mvar.withContext do
-  let goal ← instantiateMVars <| ← mvar.getType
-  unless ← isProp goal do
-    throwError "type mismatch\n{← mkHasTypeButIsExpectedMsg (← inferType goal) (mkSort .zero)}"
-
-  let result ← mStart goal
-  if let some proof := result.proof? then
-    let subgoal ←
-      mkFreshExprSyntheticOpaqueMVar result.goal.toExpr (← mvar.getTag)
-    mvar.assign (mkApp proof subgoal)
-    return (subgoal.mvarId!, result.goal)
-  else
-    return (mvar, result.goal)
-
-@[builtin_tactic Lean.Parser.Tactic.mstart]
-def elabMStart : Tactic | _ => do
-  let (mvar, _) ← mStartMVar (← getMainGoal)
-  replaceMainGoal [mvar]
-
-@[builtin_tactic Lean.Parser.Tactic.mstop]
-def elabMStop : Tactic | _ => do
-  -- parse goal
-  let mvar ← getMainGoal
-  mvar.withContext do
-  let goal ← instantiateMVars <| ← mvar.getType
-
-  -- check if already in proof mode
-  let some mgoal := parseMGoal? goal | throwError "not in proof mode"
-  mvar.setType mgoal.strip

src/Lean/Elab/Tactic/Do/ProofMode/Cases.lean

@@ -1,233 +0,0 @@
-/-
-Copyright (c) 2022 Lars König. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Lars König, Mario Carneiro, Sebastian Graf
--/
-prelude
-import Std.Tactic.Do.Syntax
-import Lean.Elab.Tactic.Do.ProofMode.Focus
-import Lean.Elab.Tactic.Do.ProofMode.Basic
-import Lean.Elab.Tactic.Do.ProofMode.Pure
-import Lean.Elab.Tactic.Do.ProofMode.Intro
-
-namespace Lean.Elab.Tactic.Do.ProofMode
-open Std.Do Lean.Parser.Tactic
-open Lean Elab Tactic Meta
-
-initialize registerTraceClass `Meta.Tactic.Do.cases
-
-theorem SCases.add_goal {σs} {P Q H T : SPred σs} (hand : Q ∧ H ⊣⊢ₛ P) (hgoal : P ⊢ₛ T) : Q ∧ H ⊢ₛ T :=
-  hand.mp.trans hgoal
-
-theorem SCases.clear {σs} {Q H T : SPred σs} (hgoal : Q ∧ ⌜True⌝ ⊢ₛ T) : Q ∧ H ⊢ₛ T :=
-  (SPred.and_mono_r SPred.true_intro).trans hgoal
-
-theorem SCases.pure {σs} {Q T : SPred σs} (hgoal : Q ∧ ⌜True⌝ ⊢ₛ T) : Q ⊢ₛ T :=
-  (SPred.and_intro .rfl SPred.true_intro).trans hgoal
-
-theorem SCases.and_1 {σs} {Q H₁' H₂' H₁₂' T : SPred σs} (hand : H₁' ∧ H₂' ⊣⊢ₛ H₁₂') (hgoal : Q ∧ H₁₂' ⊢ₛ T) : (Q ∧ H₁') ∧ H₂' ⊢ₛ T :=
-  ((SPred.and_congr_r hand.symm).trans SPred.and_assoc.symm).mpr.trans hgoal
-
-theorem SCases.and_2 {σs} {Q H₁' H₂ T : SPred σs} (hgoal : (Q ∧ H₁') ∧ H₂ ⊢ₛ T) : (Q ∧ H₂) ∧ H₁' ⊢ₛ T :=
-  SPred.and_right_comm.mp.trans hgoal
-
-theorem SCases.and_3 {σs} {Q H₁ H₂ H T : SPred σs} (hand : H ⊣⊢ₛ H₁ ∧ H₂) (hgoal : (Q ∧ H₂) ∧ H₁ ⊢ₛ T) : Q ∧ H ⊢ₛ T :=
-  (SPred.and_congr_r hand).mp.trans (SPred.and_assoc.mpr.trans (SPred.and_right_comm.mp.trans hgoal))
-
-theorem SCases.exists {σs : List Type} {Q : SPred σs} {ψ : α → SPred σs} {T : SPred σs}
-  (h : ∀ a, Q ∧ ψ a ⊢ₛ T) : Q ∧ (∃ a, ψ a) ⊢ₛ T :=
-    SPred.imp_elim' (SPred.exists_elim fun a => SPred.imp_intro (SPred.entails.trans SPred.and_symm (h a)))
-
-class IsAnd {σs : List Type} (P : SPred σs) (Q₁ Q₂ : outParam (SPred σs)) where to_and : P ⊣⊢ₛ Q₁ ∧ Q₂
-instance (σs) (Q₁ Q₂ : SPred σs) : IsAnd (σs:=σs) spred(Q₁ ∧ Q₂) Q₁ Q₂ where to_and := .rfl
-instance (σs) : IsAnd (σs:=σs) ⌜p ∧ q⌝ ⌜p⌝ ⌜q⌝ where to_and := SPred.pure_and.symm
-instance (σs) (P Q₁ Q₂ : σ → SPred σs) [base : ∀ s, IsAnd (P s) (Q₁ s) (Q₂ s)] : IsAnd (σs:=σ::σs) P Q₁ Q₂ where to_and := fun s => (base s).to_and
-
--- Given σs and H, produces H₁, H₂ and a proof that H₁ ∧ H₂ ⊣⊢ₛ H.
-def synthIsAnd (σs H : Expr) : OptionT MetaM (Expr × Expr × Expr) := do
-  if let some (_σs, H₁, H₂) := parseAnd? H.consumeMData then
-    return (H₁, H₂, mkApp2 (mkConst ``SPred.bientails.refl) σs H)
-  try
-    let H₁ ← mkFreshExprMVar (mkApp (mkConst ``SPred) σs)
-    let H₂ ← mkFreshExprMVar (mkApp (mkConst ``SPred) σs)
-    let inst ← synthInstance (mkApp4 (mkConst ``IsAnd) σs H H₁ H₂)
-    return (H₁, H₂, mkApp5 (mkConst ``IsAnd.to_and) σs H H₁ H₂ inst)
-  catch _ => failure
-
--- Produce a proof for Q ∧ H ⊢ₛ T by opening a new goal P ⊢ₛ T, where P ⊣⊢ₛ Q ∧ H.
-def mCasesAddGoal (goals : IO.Ref (Array MVarId)) (σs : Expr) (T : Expr) (Q : Expr) (H : Expr) : MetaM (Unit × MGoal × Expr) := do
-  let (P, hand) := mkAnd σs Q H
-  -- hand : Q ∧ H ⊣⊢ₛ P
-  -- Need to produce a proof that P ⊢ₛ T and return res
-  let goal : MGoal := { σs := σs, hyps := P, target := T }
-  let m ← mkFreshExprSyntheticOpaqueMVar goal.toExpr
-  goals.modify (·.push m.mvarId!)
-  let prf := mkApp7 (mkConst ``SCases.add_goal) σs P Q H T hand m
-  let goal := { goal with hyps := mkAnd! σs Q H }
-  return ((), goal, prf)
-
-private def getQH (goal : MGoal) : MetaM (Expr × Expr) := do
-  let some (_, Q, H) := parseAnd? goal.hyps | throwError m!"Internal error: Hypotheses not a conjunction {goal.hyps}"
-  return (Q, H)
-
--- Pretty much like sPureCore, but for existential quantifiers.
--- This function receives the hypothesis H=(∃ (x : α), ψ x) to destruct.
--- It will provide a proof for Q ∧ H ⊢ₛ T
--- if `k` produces a proof for Q ∧ ψ n ⊢ₛ T that may range over `name : α`.
--- It calls `k` with name.
-def mCasesExists (H : Expr) (name : TSyntax ``binderIdent)
-  (k : Expr /-name:α-/ → MetaM (α × MGoal × Expr)) : MetaM (α × MGoal × Expr) := do
-  let some (α, σs, ψ) := H.consumeMData.app3? ``SPred.exists | throwError "Not an existential quantifier {H}"
-  let (name, ref) ← getFreshHypName name
-  withLocalDeclD name α fun x => do
-    addLocalVarInfo ref (← getLCtx) x α
-    let (r, goal, prf /- : goal.toExpr -/) ← k x
-    let (Q, _) ← getQH goal
-    let u ← getLevel α
-    let prf := mkApp6 (mkConst ``SCases.exists [u]) α σs Q ψ goal.target (← mkLambdaFVars #[x] prf)
-    let goal := { goal with hyps := mkAnd! σs Q H }
-    return (r, goal, prf)
-
--- goal is P ⊢ₛ T
--- The caller focuses on hypothesis H, P ⊣⊢ₛ Q ∧ H.
--- scasesCore on H, pat and k builds H ⊢ₛ H' according to pat, then calls k with H'
--- k knows context Q and builds goal Q ∧ H' ⊢ₛ T and a proof of the goal.
--- (k should not also apply H ⊢ₛ H' or unfocus because that does not work with spureCore which needs the see `P'` and not `Q ∧ _`.)
--- then scasesCore builds a proof for Q ∧ H ⊢ₛ T from P' ⊢ₛ T:
---   Q ∧ H ⊢ₛ Q ∧ H' ⊢ₛ P' ⊢ₛ T
--- and finally the caller builds the proof for
---   P ⊢ₛ Q ∧ H ⊢ₛ T
--- by unfocussing.
-partial def mCasesCore (σs : Expr) (H : Expr) (pat : MCasesPat) (k : Expr → MetaM (α × MGoal × Expr)): MetaM (α × MGoal × Expr) :=
-  match pat with
-  | .clear => do
-    let H' := emptyHyp σs -- H' = ⌜True⌝
-    let (a, goal, prf) ← k H'
-    let (Q, _H) ← getQH goal
-    -- prf : Q ∧ ⌜True⌝ ⊢ₛ T
-    -- Then Q ∧ H ⊢ₛ Q ∧ ⌜True⌝ ⊢ₛ T
-    let prf := mkApp5 (mkConst ``SCases.clear) σs Q H goal.target prf
-    let goal := { goal with hyps := mkAnd! σs Q H }
-    return (a, goal, prf)
-  | .stateful name => do
-    let (name, ref) ← getFreshHypName name
-    let uniq ← mkFreshId
-    let hyp := Hyp.mk name uniq H.consumeMData
-    addHypInfo ref σs hyp (isBinder := true)
-    k hyp.toExpr
-  | .pure name => do
-    mPureCore σs H name fun _ _hφ => do
-      -- This case is very similar to the clear case, but we need to
-      -- return Q ⊢ₛ T, not Q ∧ H ⊢ₛ T.
-      let H' := emptyHyp σs -- H' = ⌜True⌝
-      let (a, goal, prf) ← k H'
-      let (Q, _H) ← getQH goal
-      -- prf : Q ∧ ⌜True⌝ ⊢ₛ T
-      -- Then Q ⊢ₛ Q ∧ ⌜True⌝ ⊢ₛ T
-      let prf := mkApp4 (mkConst ``SCases.pure) σs Q goal.target prf
-      let goal := { goal with hyps := Q }
-      return (a, goal, prf)
-    -- Now prf : Q ∧ H ⊢ₛ T (where H is ⌜φ⌝). Exactly what is needed.
-  | .one name => do
-    try
-      -- First try to see if H can be introduced as a pure hypothesis
-      let φ ← mkFreshExprMVar (mkSort .zero)
-      let _ ← synthInstance (mkApp3 (mkConst ``IsPure) σs H φ)
-      mCasesCore σs H (.pure name) k
-    catch _ =>
-      -- Otherwise introduce it as a stateful hypothesis.
-      mCasesCore σs H (.stateful name) k
-  | .tuple [] => mCasesCore σs H .clear k
-  | .tuple [p] => mCasesCore σs H p k
-  | .tuple (p :: ps) => do
-    if let some (H₁, H₂, hand) ← synthIsAnd σs H then
-      -- goal is Q ∧ H ⊢ₛ T, where `hand : H ⊣⊢ₛ H₁ ∧ H₂`. Plan:
-      -- 1. Recurse on H₁ and H₂.
-      -- 2. The inner callback sees H₁' and H₂' and calls k on H₁₂', where H₁₂' = mkAnd H₁' H₂'
-      -- 3. The inner callback receives P' ⊢ₛ T, where (P' ⊣⊢ₛ Q ∧ H₁₂').
-      -- 4. The inner callback returns (Q ∧ H₁') ∧ H₂' ⊢ₛ T
-      -- 5. The outer callback receives (Q ∧ H₁') ∧ H₂ ⊢ₛ T
-      -- 6. The outer callback reassociates and returns (Q ∧ H₂) ∧ H₁' ⊢ₛ T
-      -- 7. The top-level receives (Q ∧ H₂) ∧ H₁ ⊢ₛ T
-      -- 8. Reassociate to Q ∧ (H₁ ∧ H₂) ⊢ₛ T, rebuild Q ∧ H ⊢ₛ T and return it.
-      let ((a, Q), goal, prf) ← mCasesCore σs H₁ p fun H₁' => do
-        let ((a, Q), goal, prf) ← mCasesCore σs H₂ (.tuple ps) fun H₂' => do
-          let (H₁₂', hand') := mkAnd σs H₁' H₂'
-          let (a, goal, prf) ← k H₁₂' -- (2)
-          -- (3) prf : Q ∧ H₁₂' ⊢ₛ T
-          -- (4) refocus to (Q ∧ H₁') ∧ H₂'
-          let (Q, _H) ← getQH goal
-          let T := goal.target
-          let prf := mkApp8 (mkConst ``SCases.and_1) σs Q H₁' H₂' H₁₂' T hand' prf
-          -- check prf
-          let QH₁' := mkAnd! σs Q H₁'
-          let goal := { goal with hyps := mkAnd! σs QH₁' H₂' }
-          return ((a, Q), goal, prf)
-        -- (5) prf : (Q ∧ H₁') ∧ H₂ ⊢ₛ T
-        -- (6) refocus to prf : (Q ∧ H₂) ∧ H₁' ⊢ₛ T
-        let prf := mkApp6 (mkConst ``SCases.and_2) σs Q H₁' H₂ goal.target prf
-        let QH₂ := mkAnd! σs Q H₂
-        let goal := { goal with hyps := mkAnd! σs QH₂ H₁' }
-        return ((a, Q), goal, prf)
-      -- (7) prf : (Q ∧ H₂) ∧ H₁ ⊢ₛ T
-      -- (8) rearrange to Q ∧ H ⊢ₛ T
-      let prf := mkApp8 (mkConst ``SCases.and_3) σs Q H₁ H₂ H goal.target hand prf
-      let goal := { goal with hyps := mkAnd! σs Q H }
-      return (a, goal, prf)
-    else if let some (_α, σs, ψ) := H.consumeMData.app3? ``SPred.exists then
-      let .one n := p
-        | throwError "cannot further destruct a term after moving it to the Lean context"
-      -- goal is Q ∧ (∃ x, ψ x) ⊢ₛ T. The plan is pretty similar to sPureCore:
-      -- 1. Recurse on ψ n where (n : α) is named according to the head pattern p.
-      -- 2. Receive a proof for Q ∧ ψ n ⊢ₛ T.
-      -- 3. Build a proof for Q ∧ (∃ x, ψ x) ⊢ₛ T from it (in sCasesExists).
-      mCasesExists H n fun x => mCasesCore σs (ψ.betaRev #[x]) (.alts ps) k
-    else throwError "Neither a conjunction nor an existential quantifier {H}"
-  | .alts [] => throwUnsupportedSyntax
-  | .alts [p] => mCasesCore σs H p k
-  | .alts (p :: ps) => do
-    let some (σs, H₁, H₂) := H.consumeMData.app3? ``SPred.or | throwError "Not a disjunction {H}"
-    -- goal is Q ∧ (H₁ ∨ H₂) ⊢ₛ T. Plan:
-    -- 1. Recurse on H₁ and H₂ with the same k.
-    -- 2. Receive proofs for Q ∧ H₁ ⊢ₛ T and Q ∧ H₂ ⊢ₛ T.
-    -- 3. Build a proof for Q ∧ (H₁ ∨ H₂) ⊢ₛ T from them.
-    let (_a, goal₁,  prf₁) ← mCasesCore σs H₁ p k
-    let (a,  _goal₂, prf₂) ← mCasesCore σs H₂ (.alts ps) k
-    let (Q, _H₁) ← getQH goal₁
-    let goal := { goal₁ with hyps := mkAnd! σs Q (mkApp3 (mkConst ``SPred.or) σs H₁ H₂) }
-    let prf := mkApp7 (mkConst ``SPred.and_or_elim_r) σs Q H₁ H₂ goal.target prf₁ prf₂
-    return (a, goal, prf)
-
-private theorem assembled_proof {σs} {P P' Q H H' T : SPred σs}
-  (hfocus : P ⊣⊢ₛ Q ∧ H) (hcases : H ⊢ₛ H') (hand : Q ∧ H' ⊣⊢ₛ P') (hprf₃ : P' ⊢ₛ T) : P ⊢ₛ T :=
-  hfocus.mp.trans ((SPred.and_mono_r hcases).trans (hand.mp.trans hprf₃))
-
-private theorem blah2 {σs} {P Q H R : SPred σs}
-  (h₁ : P ⊣⊢ₛ Q ∧ H) (h₂ : Q ∧ H ⊢ₛ R) : P ⊢ₛ R :=
-  h₁.mp.trans h₂
-
-private theorem blah3 {σs} {P Q H T : SPred σs}
-  (hand : Q ∧ H ⊣⊢ₛ P) (hgoal : P ⊢ₛ T) : Q ∧ H ⊢ₛ T :=
-  hand.mp.trans hgoal
-
-@[builtin_tactic Lean.Parser.Tactic.mcases]
-def elabMCases : Tactic
-  | `(tactic| mcases $hyp:ident with $pat:mcasesPat) => do
-  let pat ← liftMacroM <| MCasesPat.parse pat
-  let (mvar, goal) ← mStartMVar (← getMainGoal)
-  mvar.withContext do
-
-  let focus ← goal.focusHypWithInfo hyp
-  -- goal : P ⊢ₛ T,
-  -- hfocus : P ⊣⊢ₛ Q ∧ H
-  let Q := focus.restHyps
-  let H := focus.focusHyp
-  let goals ← IO.mkRef #[]
-  let (_, _new_goal, prf) ← mCasesCore goal.σs H pat (mCasesAddGoal goals goal.σs goal.target Q)
-
-  -- Now prf : Q ∧ H ⊢ₛ T. Prepend hfocus.mp, done.
-  let prf := focus.rewriteHyps goal prf
-  -- check prf
-  mvar.assign prf
-  replaceMainGoal (← goals.get).toList
-  | _ => throwUnsupportedSyntax

src/Lean/Elab/Tactic/Do/ProofMode/Clear.lean

@@ -1,32 +0,0 @@
-/-
-Copyright (c) 2022 Lars König. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Lars König, Mario Carneiro, Sebastian Graf
--/
-prelude
-import Std.Tactic.Do.Syntax
-import Lean.Elab.Tactic.Do.ProofMode.MGoal
-import Lean.Elab.Tactic.Do.ProofMode.Focus
-
-namespace Lean.Elab.Tactic.Do.ProofMode
-open Std.Do
-open Lean Elab Tactic Meta
-
-theorem Clear.clear {σs : List Type} {P P' A Q : SPred σs}
-    (hfocus : P ⊣⊢ₛ P' ∧ A) (h : P' ⊢ₛ Q) : P ⊢ₛ Q :=
-    hfocus.mp.trans <| (SPred.and_mono_l h).trans SPred.and_elim_l
-
-@[builtin_tactic Lean.Parser.Tactic.mclear]
-def elabMClear : Tactic
-  | `(tactic| mclear $hyp:ident) => do
-  let mvar ← getMainGoal
-  mvar.withContext do
-  let g ← instantiateMVars <| ← mvar.getType
-  let some goal := parseMGoal? g | throwError "not in proof mode"
-  let res ← goal.focusHypWithInfo hyp
-  let m ← mkFreshExprSyntheticOpaqueMVar (res.restGoal goal).toExpr
-
-  mvar.assign (mkApp7 (mkConst ``Clear.clear) goal.σs goal.hyps
-    res.restHyps res.focusHyp goal.target res.proof m)
-  replaceMainGoal [m.mvarId!]
-  | _ => throwUnsupportedSyntax

src/Lean/Elab/Tactic/Do/ProofMode/Constructor.lean

@@ -1,30 +0,0 @@
-/-
-Copyright (c) 2022 Lars König. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Lars König, Mario Carneiro, Sebastian Graf
--/
-prelude
-import Std.Tactic.Do.Syntax
-import Lean.Elab.Tactic.Do.ProofMode.MGoal
-
-namespace Lean.Elab.Tactic.Do.ProofMode
-open Std.Do
-open Lean Elab Tactic Meta
-
-def mConstructorCore (mvar : MVarId) : MetaM (MVarId × MVarId) := do
-  let g ← instantiateMVars <| ← mvar.getType
-  let some goal := parseMGoal? g | throwError "not in proof mode"
-
-  let mkApp3 (.const ``SPred.and []) σs L R := goal.target | throwError "target is not SPred.and"
-
-  let leftGoal ← mkFreshExprSyntheticOpaqueMVar {goal with target := L}.toExpr
-  let rightGoal ← mkFreshExprSyntheticOpaqueMVar {goal with target := R}.toExpr
-  mvar.assign (mkApp6 (mkConst ``SPred.and_intro) σs goal.hyps L R leftGoal rightGoal)
-  return (leftGoal.mvarId!, rightGoal.mvarId!)
-
-@[builtin_tactic Lean.Parser.Tactic.mconstructor]
-def elabMConstructor : Tactic | _ => do
-  let mvar ← getMainGoal
-  mvar.withContext do
-  let (leftGoal, rightGoal) ← mConstructorCore mvar
-  replaceMainGoal [leftGoal, rightGoal]

src/Lean/Elab/Tactic/Do/ProofMode/Display.lean

@@ -1,55 +0,0 @@
-/-
-Copyright (c) 2022 Lars König. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Lars König, Mario Carneiro, Sebastian Graf
--/
-prelude
-import Lean.Elab.Tactic.Do.ProofMode.MGoal
-
-namespace Lean.Elab.Tactic.Do.ProofMode
-open Std.Do
-open Lean Expr Meta PrettyPrinter Delaborator SubExpr
-
-syntax mgoalHyp := ident " : " term
-
-syntax mgoalStx := ppDedent(ppLine mgoalHyp)* ppDedent(ppLine "⊢ₛ " term)
-
-@[app_delab MGoalEntails]
-partial def delabMGoal : Delab := do
-  let expr ← instantiateMVars <| ← getExpr
-
-  -- extract environment
-  let some goal := parseMGoal? expr | failure
-
-  -- delaborate
-  let (_, hyps) ← withAppFn ∘ withAppArg <| delabHypotheses goal.σs ({}, #[])
-  let target ← SPred.Notation.unpack (← withAppArg <| delab)
-
-  -- build syntax
-  return ⟨← `(mgoalStx| $hyps.reverse* ⊢ₛ $target:term)⟩
-where
-  delabHypotheses (σs : Expr)
-      (acc : NameMap Nat × Array (TSyntax ``mgoalHyp)) :
-      DelabM (NameMap Nat × Array (TSyntax ``mgoalHyp)) := do
-    let hyps ← getExpr
-    if let some _ := parseEmptyHyp? hyps then
-      return acc
-    if let some hyp := parseHyp? hyps then
-      let mut (map, lines) := acc
-      let (idx, name') :=
-        if let some idx := map.find? hyp.name then
-          (idx + 1, hyp.name.appendAfter <| if idx == 0 then "✝" else "✝" ++ idx.toSuperscriptString)
-        else
-          (0, hyp.name)
-      let name' := mkIdent name'
-      let stx ← `(mgoalHyp| $name' : $(← SPred.Notation.unpack (← withMDataExpr <| delab)))
-      return (map.insert hyp.name idx, lines.push stx)
-    if (parseAnd? hyps).isSome then
-      let acc_rhs ← withAppArg <| delabHypotheses σs acc
-      let acc_lhs ← withAppFn ∘ withAppArg <| delabHypotheses σs acc_rhs
-      return acc_lhs
-    else
-      failure
-
-@[app_delab HypMarker]
-def delabHypMarker : Delab := do SPred.Notation.unpack (← withAppArg delab)

src/Lean/Elab/Tactic/Do/ProofMode/Exact.lean

@@ -1,50 +0,0 @@
-/-
-Copyright (c) 2022 Lars König. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Lars König, Mario Carneiro, Sebastian Graf
--/
-prelude
-import Std.Tactic.Do.Syntax
-import Lean.Elab.Tactic.Do.ProofMode.Basic
-import Lean.Elab.Tactic.Do.ProofMode.Focus
-
-namespace Lean.Elab.Tactic.Do.ProofMode
-open Std.Do
-open Lean Elab Tactic Meta
-
-theorem Exact.assumption {σs : List Type} {P P' A : SPred σs}
-  (h : P ⊣⊢ₛ P' ∧ A) : P ⊢ₛ A := h.mp.trans SPred.and_elim_r
-
-theorem Exact.from_tautology {σs : List Type} {P T : SPred σs} [PropAsSPredTautology φ T] (h : φ) : P ⊢ₛ T :=
-  SPred.true_intro.trans (PropAsSPredTautology.iff.mp h)
-
-def _root_.Lean.Elab.Tactic.Do.ProofMode.MGoal.exact (goal : MGoal) (hyp : Syntax) : OptionT MetaM Expr := do
-  if goal.findHyp? hyp.getId |>.isNone then failure
-  let focusRes ← goal.focusHypWithInfo ⟨hyp⟩
-  OptionT.mk do
-  let proof := mkApp5 (mkConst ``Exact.assumption) goal.σs goal.hyps focusRes.restHyps goal.target focusRes.proof
-  unless ← isDefEq focusRes.focusHyp goal.target do
-    throwError "mexact tactic failed, hypothesis {hyp} is not definitionally equal to {goal.target}"
-  return proof
-
-def _root_.Lean.Elab.Tactic.Do.ProofMode.MGoal.exactPure (goal : MGoal) (hyp : Syntax) : TacticM Expr := do
-  let φ ← mkFreshExprMVar (mkSort .zero)
-  let h ← elabTermEnsuringType hyp φ
-  let P ← mkFreshExprMVar (mkApp (mkConst ``SPred) goal.σs)
-  let some inst ← synthInstance? (mkApp3 (mkConst ``PropAsSPredTautology) φ goal.σs P)
-    | throwError "mexact tactic failed, {hyp} is not an SPred tautology"
-  return mkApp6 (mkConst ``Exact.from_tautology) φ goal.σs goal.hyps goal.target inst h
-
-@[builtin_tactic Lean.Parser.Tactic.mexact]
-def elabMExact : Tactic
-  | `(tactic| mexact $hyp:term) => do
-    let mvar ← getMainGoal
-    mvar.withContext do
-      let g ← instantiateMVars <| ← mvar.getType
-      let some goal := parseMGoal? g | throwError "not in proof mode"
-      if let some prf ← liftMetaM (goal.exact hyp) then
-    mvar.assign prf
-      else
-        mvar.assign (← goal.exactPure hyp)
-      replaceMainGoal []
-  | _ => throwUnsupportedSyntax

src/Lean/Elab/Tactic/Do/ProofMode/Exfalso.lean

@@ -1,31 +0,0 @@
-/-
-Copyright (c) 2022 Lars König. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Lars König, Mario Carneiro, Sebastian Graf
--/
-prelude
-import Std.Tactic.Do.Syntax
-import Lean.Elab.Tactic.Do.ProofMode.MGoal
-import Lean.Elab.Tactic.Do.ProofMode.Basic
-
-namespace Lean.Elab.Tactic.Do.ProofMode
-open Std.Do
-open Lean Elab Tactic Meta
-
-
--- set_option pp.all true in
--- #check ⌜False⌝
-private def falseProp (σs : Expr) : Expr := -- ⌜False⌝ standing in for an empty conjunction of hypotheses
-  mkApp3 (mkConst ``SVal.curry) (.sort .zero) σs <| mkLambda `escape .default (mkApp (mkConst ``SVal.StateTuple) σs) (mkConst ``False)
-
-@[builtin_tactic Lean.Parser.Tactic.mexfalso]
-def elabMExfalso : Tactic | _ => do
-  let mvar ← getMainGoal
-  mvar.withContext do
-  let g ← instantiateMVars <| ← mvar.getType
-  let some goal := parseMGoal? g | throwError "not in proof mode"
-  let newGoal := { goal with target := falseProp goal.σs }
-  let m ← mkFreshExprSyntheticOpaqueMVar newGoal.toExpr
-  let prf := mkApp4 (mkConst ``SPred.exfalso) goal.σs goal.hyps goal.target m
-  mvar.assign prf
-  replaceMainGoal [m.mvarId!]

src/Lean/Elab/Tactic/Do/ProofMode/Focus.lean

@@ -1,80 +0,0 @@
-/-
-Copyright (c) 2022 Lars König. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Lars König, Mario Carneiro, Sebastian Graf
--/
-prelude
-import Lean.Elab.Tactic.Do.ProofMode.MGoal
-import Lean.Meta
-
-namespace Lean.Elab.Tactic.Do.ProofMode
-open Std.Do ProofMode
-open Lean Elab.Tactic Meta
-
-/-- The result of focussing the context of a goal `goal : MGoal` on a particular hypothesis.
-The focussed hypothesis is returned as `focusHyp : Expr`, along with the
-residual `restHyps : Expr` and a `proof : Expr` for the property
-`goal.hyps ⊣⊢ₛ restHyps ∧ focusHyp`. -/
-structure FocusResult where
-  focusHyp : Expr
-  restHyps : Expr
-  proof : Expr
-  deriving Inhabited
-
-theorem focus_this {σs : List Type} {P : SPred σs} : P ⊣⊢ₛ ⌜True⌝ ∧ P :=
-  SPred.true_and.symm
-
-theorem focus_l {σs : List Type} {P P' Q C R : SPred σs} (h₁ : P ⊣⊢ₛ P' ∧ R) (h₂ : P' ∧ Q ⊣⊢ₛ C) :
-    P ∧ Q ⊣⊢ₛ C ∧ R :=
-  (SPred.and_congr_l h₁).trans (SPred.and_right_comm.trans (SPred.and_congr_l h₂))
-
-theorem focus_r {σs : List Type} {P Q Q' C R : SPred σs} (h₁ : Q ⊣⊢ₛ Q' ∧ R) (h₂ : P ∧ Q' ⊣⊢ₛ C) :
-    P ∧ Q ⊣⊢ₛ C ∧ R :=
-  (SPred.and_congr_r h₁).trans (SPred.and_assoc.symm.trans (SPred.and_congr_l h₂))
-
-partial def focusHyp (σs : Expr) (e : Expr) (name : Name) : Option FocusResult := do
-  if let some hyp := parseHyp? e then
-    if hyp.name = name then
-      return ⟨e, emptyHyp σs, mkApp2 (mkConst ``focus_this) σs e⟩
-    else
-      none
-  else if let some (σs, lhs, rhs) := parseAnd? e then
-    try
-      -- NB: Need to prefer rhs over lhs, like the goal view (Lean.Elab.Tactic.Do.ProofMode.Display).
-      let ⟨focus, rhs', h₁⟩ ← focusHyp σs rhs name
-      let ⟨C, h₂⟩ := mkAnd σs lhs rhs'
-      return ⟨focus, C, mkApp8 (mkConst ``focus_r) σs lhs rhs rhs' C focus h₁ h₂⟩
-    catch _ =>
-      let ⟨focus, lhs', h₁⟩ ← focusHyp σs lhs name
-      let ⟨C, h₂⟩ := mkAnd σs lhs' rhs
-      return ⟨focus, C, mkApp8 (mkConst ``focus_l) σs lhs lhs' rhs C focus h₁ h₂⟩
-  else if let some _ := parseEmptyHyp? e then
-    none
-  else
-    panic! s!"focusHyp: hypothesis without proper metadata: {e}"
-
-def MGoal.focusHyp (goal : MGoal) (name : Name) : Option FocusResult :=
-  Lean.Elab.Tactic.Do.ProofMode.focusHyp goal.σs goal.hyps name
-
-def FocusResult.refl (σs : Expr) (restHyps : Expr) (focusHyp : Expr) : FocusResult :=
-  let proof := mkApp2 (mkConst ``SPred.bientails.refl) σs (mkAnd! σs restHyps focusHyp)
-  { restHyps, focusHyp, proof }
-
-def FocusResult.restGoal (res : FocusResult) (goal : MGoal) : MGoal :=
-  { goal with hyps := res.restHyps }
-
-def FocusResult.recombineGoal (res : FocusResult) (goal : MGoal) : MGoal :=
-  { goal with hyps := mkAnd! goal.σs res.restHyps res.focusHyp }
-
-theorem FocusResult.rewrite_hyps {σs} {P Q R : SPred σs} (hrw : P ⊣⊢ₛ Q) (hgoal : Q ⊢ₛ R) : P ⊢ₛ R :=
-  hrw.mp.trans hgoal
-
-/-- Turn a proof for `(res.recombineGoal goal).toExpr` into one for `goal.toExpr`. -/
-def FocusResult.rewriteHyps (res : FocusResult) (goal : MGoal) : Expr → Expr :=
-  mkApp6 (mkConst ``rewrite_hyps) goal.σs goal.hyps (mkAnd! goal.σs res.restHyps res.focusHyp) goal.target res.proof
-
-def MGoal.focusHypWithInfo (goal : MGoal) (name : Ident) : MetaM FocusResult := do
-  let some res := goal.focusHyp name.getId | throwError "unknown hypothesis '{name}'"
-  let some hyp := parseHyp? res.focusHyp | throwError "impossible; res.focusHyp not a hypothesis"
-  addHypInfo name goal.σs hyp
-  pure res

src/Lean/Elab/Tactic/Do/ProofMode/Frame.lean

@@ -1,129 +0,0 @@
-/-
-Copyright (c) 2025 Lars König. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Sebastian Graf
--/
-prelude
-import Std.Tactic.Do.Syntax
-import Lean.Elab.Tactic.Do.ProofMode.MGoal
-import Lean.Elab.Tactic.Do.ProofMode.Focus
-
-namespace Lean.Elab.Tactic.Do.ProofMode
-open Std.Do
-open Lean Elab Tactic Meta
-
-class SimpAnd {σs : List Type} (P Q : SPred σs) (PQ : outParam (SPred σs)) : Prop where
-  simp_and : P ∧ Q ⊣⊢ₛ PQ
-
-instance (σs) (P Q : SPred σs) : SimpAnd P Q (spred(P ∧ Q)) where simp_and := .rfl
-instance (σs) (P : SPred σs) : SimpAnd P ⌜True⌝ P where simp_and := SPred.and_true
-instance (σs) (P : SPred σs) : SimpAnd ⌜True⌝ P P where simp_and := SPred.true_and
-
-class HasFrame {σs : List Type} (P : SPred σs) (P' : outParam (SPred σs)) (φ : outParam Prop) : Prop where
-  reassoc : P ⊣⊢ₛ P' ∧ ⌜φ⌝
-instance (σs) : HasFrame (σs:=σs) ⌜φ⌝ ⌜True⌝ φ where reassoc := SPred.true_and.symm
-instance (σs) (P P' Q QP : SPred σs) [HasFrame P Q φ] [SimpAnd Q P' QP]: HasFrame (σs:=σs) spred(P ∧ P') QP φ where
-  reassoc := ((SPred.and_congr_l HasFrame.reassoc).trans SPred.and_right_comm).trans (SPred.and_congr_l SimpAnd.simp_and)
-instance (σs) (P P' Q' PQ : SPred σs) [HasFrame P' Q' φ] [SimpAnd P Q' PQ]: HasFrame (σs:=σs) spred(P ∧ P') PQ φ where
-  reassoc := ((SPred.and_congr_r HasFrame.reassoc).trans SPred.and_assoc.symm).trans (SPred.and_congr_l SimpAnd.simp_and)
-instance (σs) (P : SPred σs) : HasFrame (σs:=σs) spred(⌜φ⌝ ∧ P) P φ where reassoc := SPred.and_comm
-instance (σs) (P : SPred σs) : HasFrame (σs:=σs) spred(P ∧ ⌜φ⌝) P φ where reassoc := .rfl
-instance (σs) (P P' Q Q' QQ : SPred σs) [HasFrame P Q φ] [HasFrame P' Q' ψ] [SimpAnd Q Q' QQ]: HasFrame (σs:=σs) spred(P ∧ P') QQ (φ ∧ ψ) where
-  reassoc := (SPred.and_congr HasFrame.reassoc HasFrame.reassoc).trans
-             <| SPred.and_assoc.trans
-             <| (SPred.and_congr_r
-                  <| SPred.and_assoc.symm.trans
-                  <| (SPred.and_congr_l SPred.and_comm).trans
-                  <| SPred.and_assoc.trans
-                  <| SPred.and_congr_r SPred.pure_and).trans
-             <| SPred.and_assoc.symm.trans
-             <| SPred.and_congr_l SimpAnd.simp_and
-instance (σs) (P Q : SPred σs) [HasFrame P Q ψ] : HasFrame (σs:=σs) spred(⌜φ⌝ ∧ P) Q (φ ∧ ψ) where
-  reassoc := SPred.and_comm.trans
-             <| (SPred.and_congr_l HasFrame.reassoc).trans
-             <| SPred.and_right_comm.trans
-             <| SPred.and_assoc.trans
-             <| SPred.and_congr_r SPred.pure_and
-instance (σs) (P Q : SPred σs) [HasFrame P Q ψ] : HasFrame (σs:=σs) spred(P ∧ ⌜φ⌝) Q (ψ ∧ φ) where
-  reassoc := (SPred.and_congr_l HasFrame.reassoc).trans
-             <| SPred.and_right_comm.trans
-             <| SPred.and_assoc.trans
-             <| SPred.and_congr_r (SPred.and_comm.trans SPred.pure_and)
--- The following instance comes last so that it gets the highest priority.
--- It's the most efficient and best solution if valid
-instance {P : Prop} : HasFrame (σs:=[]) P ⌜True⌝ P where reassoc := SPred.true_and.symm
-
--- #synth ∀ {w x P Q y z}, HasFrame spred(⌜w = 2⌝ ∧ ⌜x = 3⌝ ∧ P ∧ ⌜y = 4⌝ ∧ Q ∧ ⌜z=6⌝) _ _
-
-theorem Frame.frame {σs : List Type} {P Q T : SPred σs} {φ : Prop} [HasFrame P Q φ]
-  (h : φ → Q ⊢ₛ T) : P ⊢ₛ T := by
-    apply SPred.pure_elim
-    · exact HasFrame.reassoc.mp.trans SPred.and_elim_r
-    · intro hp
-      exact HasFrame.reassoc.mp.trans (SPred.and_elim_l' (h hp))
-
-/-- If `P'` is a conjunction of unnamed hypotheses that are a subset of the named hypotheses of `P`,
-transfer the names of the hypotheses of `P` to the hypotheses of `P'`. -/
-partial def transferHypNames (P P' : Expr) : MetaM Expr := (·.snd) <$> label (collectHyps P) P'
-  where
-    collectHyps (P : Expr) (acc : List Hyp := []) : List Hyp :=
-      if let some hyp := parseHyp? P then
-        hyp :: acc
-      else if let some (_, L, R) := parseAnd? P then
-        collectHyps L (collectHyps R acc)
-      else
-        acc
-
-    label (Ps : List Hyp) (P' : Expr) : MetaM (List Hyp × Expr) := do
-      let P' ← instantiateMVarsIfMVarApp P'
-      if let some _ := parseEmptyHyp? P' then
-        return (Ps, P')
-      if let some (σs, L, R) := parseAnd? P' then
-        let (Ps, L') ← label Ps L
-        let (Ps, R') ← label Ps R
-        return (Ps, mkAnd! σs L' R')
-      else
-        let mut Ps' := Ps
-        repeat
-          -- If we cannot find the hyp, it might be in a nested conjunction.
-          -- Just pick a default name for it.
-          let uniq ← mkFreshId
-          let P :: Ps'' := Ps' | return (Ps, { name := `h, uniq, p := P' : Hyp }.toExpr)
-          Ps' := Ps''
-          if ← isDefEq P.p P' then
-            return (Ps, { P with p := P' }.toExpr)
-        unreachable!
-
-def mFrameCore [Monad m] [MonadControlT MetaM m] [MonadLiftT MetaM m]
-  (goal : MGoal) (kFail : m (α × Expr)) (kSuccess : Expr /-φ:Prop-/ → Expr /-h:φ-/ → MGoal → m (α × Expr)) : m (α × Expr) := do
-  let P := goal.hyps
-  let φ ← mkFreshExprMVar (mkSort .zero)
-  let P' ← mkFreshExprMVar (mkApp (mkConst ``SPred) goal.σs)
-  if let some inst ← synthInstance? (mkApp4 (mkConst ``HasFrame) goal.σs P P' φ) then
-    if ← isDefEq (mkConst ``True) φ then return (← kFail)
-    -- copy the name of P to P' if it is a named hypothesis
-    let P' ← transferHypNames P P'
-    let goal := { goal with hyps := P' }
-    withLocalDeclD `h φ fun hφ => do
-      let (a, prf) ← kSuccess φ hφ goal
-      let prf ← mkLambdaFVars #[hφ] prf
-      let prf := mkApp7 (mkConst ``Frame.frame) goal.σs P P' goal.target φ inst prf
-      return (a, prf)
-  else
-    kFail
-
-def mTryFrame [Monad m] [MonadControlT MetaM m] [MonadLiftT MetaM m]
-  (goal : MGoal) (k : MGoal → m (α × Expr)) : m (α × Expr) :=
-  mFrameCore goal (k goal) (fun _ _ goal => k goal)
-
-@[builtin_tactic Lean.Parser.Tactic.mframe]
-def elabMFrame : Tactic | _ => do
-  let mvar ← getMainGoal
-  mvar.withContext do
-  let g ← instantiateMVars <| ← mvar.getType
-  let some goal := parseMGoal? g | throwError "not in proof mode"
-  let (m, prf) ← mFrameCore goal (fun _ => throwError "Could not infer frame") fun _ _ goal => do
-    let m ← mkFreshExprSyntheticOpaqueMVar goal.toExpr
-    return (m, m)
-  mvar.assign prf
-  replaceMainGoal [m.mvarId!]

src/Lean/Elab/Tactic/Do/ProofMode/Have.lean

@@ -1,96 +0,0 @@
-/-
-Copyright (c) 2025 Lean FRO LLC. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Sebastian Graf
--/
-prelude
-import Std.Tactic.Do.Syntax
-import Lean.Elab.Tactic.Do.ProofMode.Cases
-import Lean.Elab.Tactic.Do.ProofMode.Specialize
-
-namespace Lean.Elab.Tactic.Do.ProofMode
-open Std.Do
-open Lean Elab Tactic Meta
-
-def Have.dup {σs : List Type} {P Q H T : SPred σs} (hfoc : P ⊣⊢ₛ Q ∧ H) (hgoal : P ∧ H ⊢ₛ T) : P ⊢ₛ T :=
-  (SPred.and_intro .rfl (hfoc.mp.trans SPred.and_elim_r)).trans hgoal
-
-def Have.have {σs : List Type} {P H PH T : SPred σs} (hand : P ∧ H ⊣⊢ₛ PH) (hhave : P ⊢ₛ H) (hgoal : PH ⊢ₛ T) : P ⊢ₛ T :=
-  (SPred.and_intro .rfl hhave).trans (hand.mp.trans hgoal)
-
-def Have.replace {σs : List Type} {P H H' PH PH' T : SPred σs} (hfoc : PH ⊣⊢ₛ P ∧ H ) (hand : P ∧ H' ⊣⊢ₛ PH') (hhave : PH ⊢ₛ H') (hgoal : PH' ⊢ₛ T) : PH ⊢ₛ T :=
-  (SPred.and_intro (hfoc.mp.trans SPred.and_elim_l) hhave).trans (hand.mp.trans hgoal)
-
-@[builtin_tactic Lean.Parser.Tactic.mdup]
-def elabMDup : Tactic
-  | `(tactic| mdup $h:ident => $h₂:ident) => do
-  let (mvar, goal) ← ensureMGoal
-  mvar.withContext do
-  let some res := goal.focusHyp h.raw.getId | throwError m!"Hypothesis {h} not found"
-  let P := goal.hyps
-  let Q := res.restHyps
-  let H := res.focusHyp
-  let uniq ← mkFreshId
-  let hyp := Hyp.mk h₂.raw.getId uniq H.consumeMData
-  addHypInfo h goal.σs hyp (isBinder := true)
-  let H' := hyp.toExpr
-  let T := goal.target
-  let newGoal := { goal with hyps := mkAnd! goal.σs P H' }
-  let m ← mkFreshExprSyntheticOpaqueMVar newGoal.toExpr
-  mvar.assign (mkApp7 (mkConst ``Have.dup) goal.σs P Q H T res.proof m)
-  replaceMainGoal [m.mvarId!]
-  | _ => throwUnsupportedSyntax
-
-@[builtin_tactic Lean.Parser.Tactic.mhave]
-def elabMHave : Tactic
-  | `(tactic| mhave $h $[: $ty?]? := $rhs) => do
-  let (mvar, goal) ← ensureMGoal
-  mvar.withContext do
-  -- build goal `P ⊢ₛ T` from `P ⊢ₛ H` and residual goal `P ∧ H ⊢ₛ T`
-  let P := goal.hyps
-  let spred := mkApp (mkConst ``SPred) goal.σs
-  let H ← match ty? with
-    | some ty => elabTerm ty spred
-    | _       => mkFreshExprMVar spred
-  let uniq ← mkFreshId
-  let hyp := Hyp.mk h.raw.getId uniq H
-  addHypInfo h goal.σs hyp (isBinder := true)
-  let H := hyp.toExpr
-  let T := goal.target
-  let (PH, hand) := mkAnd goal.σs P H
-  let haveGoal := { goal with target := H }
-  let hhave ← elabTermEnsuringType rhs haveGoal.toExpr
-  let newGoal := { goal with hyps := PH }
-  let m ← mkFreshExprSyntheticOpaqueMVar newGoal.toExpr
-  mvar.assign (mkApp8 (mkConst ``Have.have) goal.σs P H PH T hand hhave m)
-  replaceMainGoal [m.mvarId!]
-  | _ => throwUnsupportedSyntax
-
-@[builtin_tactic Lean.Parser.Tactic.mreplace]
-def elabMReplace : Tactic
-  | `(tactic| mreplace $h $[: $ty?]? := $rhs) => do
-  let (mvar, goal) ← ensureMGoal
-  mvar.withContext do
-  -- build goal `P ⊢ₛ T` from `P ⊢ₛ H` and residual goal `P ∧ H ⊢ₛ T`
-  let PH := goal.hyps
-  let some res := goal.focusHyp h.raw.getId | throwError m!"Hypothesis {h} not found"
-  let P := res.restHyps
-  let H := res.focusHyp
-  let spred := mkApp (mkConst ``SPred) goal.σs
-  let H' ← match ty? with
-    | some ty => elabTerm ty spred
-    | _       => mkFreshExprMVar spred
-  let uniq ← mkFreshId
-  let hyp := Hyp.mk h.raw.getId uniq H'
-  addHypInfo h goal.σs hyp (isBinder := true)
-  let H' := hyp.toExpr
-  let haveGoal := { goal with target := H' }
-  let hhave ← elabTermEnsuringType rhs haveGoal.toExpr
-  let T := goal.target
-  let (PH', hand) := mkAnd goal.σs P H'
-  let newGoal := { goal with hyps := PH' }
-  let m ← mkFreshExprSyntheticOpaqueMVar newGoal.toExpr
-  let prf := mkApp (mkApp10 (mkConst ``Have.replace) goal.σs P H H' PH PH' T res.proof hand hhave) m
-  mvar.assign prf
-  replaceMainGoal [m.mvarId!]
-  | _ => throwUnsupportedSyntax

src/Lean/Elab/Tactic/Do/ProofMode/Intro.lean

@@ -1,90 +0,0 @@
-/-
-Copyright (c) 2022 Lars König. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Lars König, Mario Carneiro, Sebastian Graf
--/
-prelude
-import Std.Tactic.Do.Syntax
-import Lean.Elab.Tactic.Do.ProofMode.Basic
-import Lean.Elab.Tactic.Do.ProofMode.Display
-
-namespace Lean.Elab.Tactic.Do.ProofMode
-open Std.Do
-open Lean Elab Tactic Meta
-
-theorem Intro.intro {σs : List Type} {P Q H T : SPred σs} (hand : Q ∧ H ⊣⊢ₛ P) (h : P ⊢ₛ T) : Q ⊢ₛ H → T :=
-  SPred.imp_intro (hand.mp.trans h)
-
-partial def mIntro [Monad m] [MonadControlT MetaM m] (goal : MGoal) (ident : TSyntax ``binderIdent) (k : MGoal → m (α × Expr)) : m (α × Expr) :=
-  controlAt MetaM fun map => do
-  let some (σs, H, T) := goal.target.app3? ``SPred.imp | throwError "Target not an implication {goal.target}"
-  let (name, ref) ← getFreshHypName ident
-  let uniq ← mkFreshId
-  let hyp := Hyp.mk name uniq H
-  addHypInfo ref σs hyp (isBinder := true)
-  let Q := goal.hyps
-  let H := hyp.toExpr
-  let (P, hand) := mkAnd goal.σs goal.hyps H
-  map do
-    let (a, prf) ← k { goal with hyps := P, target := T }
-    let prf := mkApp7 (mkConst ``Intro.intro) σs P Q H T hand prf
-    return (a, prf)
-
--- This is regular MVar.intro, but it takes care not to leave the proof mode by preserving metadata
-partial def mIntroForall [Monad m] [MonadControlT MetaM m] [MonadLiftT MetaM m] (goal : MGoal) (ident : TSyntax ``binderIdent) (k : MGoal → m (α × Expr)) : m (α × Expr) :=
-  controlAt MetaM fun map => do
-  let some (_type, σ, σs') := (← whnf goal.σs).app3? ``List.cons | liftMetaM <| throwError "Ambient state list not a cons {goal.σs}"
-  let name ← match ident with
-  | `(binderIdent| $name:ident) => pure name.getId
-  | `(binderIdent| $_) => liftMetaM <| mkFreshUserName `s
-  withLocalDeclD name σ fun s => do
-    addLocalVarInfo ident (← getLCtx) s σ (isBinder := true)
-    let H := betaRevPreservingHypNames σs' goal.hyps #[s]
-    let T := goal.target.betaRev #[s]
-    map do
-      let (a, prf) ← k { σs:=σs', hyps:=H, target:=T }
-      let prf ← mkLambdaFVars #[s] prf
-      return (a, mkApp5 (mkConst ``SPred.entails_cons_intro) σ σs' goal.hyps goal.target prf)
-
-def mIntroForallN [Monad m] [MonadControlT MetaM m] [MonadLiftT MetaM m] (goal : MGoal) (n : Nat) (k : MGoal → m (α × Expr)) : m (α × Expr) :=
-  match n with
-  | 0 => k goal
-  | n+1 => do mIntroForall goal (← liftM (m := MetaM) `(binderIdent| _)) fun g =>
-              mIntroForallN g n k
-
-macro_rules
-  | `(tactic| mintro $pat₁ $pat₂ $pats:mintroPat*) => `(tactic| mintro $pat₁; mintro $pat₂ $pats*)
-  | `(tactic| mintro $pat:mintroPat) => do
-    match pat with
-    | `(mintroPat| $_:binderIdent) => Macro.throwUnsupported -- handled by an elaborator below
-    | `(mintroPat| ∀$_:binderIdent) => Macro.throwUnsupported -- handled by an elaborator below
-    | `(mintroPat| $pat:mcasesPat) => `(tactic| mintro h; mcases h with $pat)
-    | _ => Macro.throwUnsupported -- presently unreachable
-
-@[builtin_tactic Lean.Parser.Tactic.mintro]
-def elabMIntro : Tactic
-  | `(tactic| mintro $ident:binderIdent) => do
-
-  let (mvar, goal) ← mStartMVar (← getMainGoal)
-  mvar.withContext do
-
-  let goals ← IO.mkRef []
-  mvar.assign (← Prod.snd <$> mIntro goal ident fun newGoal => do
-    let m ← mkFreshExprSyntheticOpaqueMVar newGoal.toExpr
-    goals.modify (m.mvarId! :: ·)
-    return ((), m))
-  replaceMainGoal (← goals.get)
-
-  | `(tactic| mintro ∀$ident:binderIdent) => do
-
-  let (mvar, goal) ← mStartMVar (← getMainGoal)
-  mvar.withContext do
-
-  let goals ← IO.mkRef []
-  mvar.assign (← Prod.snd <$> mIntroForall goal ident fun newGoal => do
-    let m ← mkFreshExprSyntheticOpaqueMVar newGoal.toExpr
-    goals.modify (m.mvarId! :: ·)
-    return ((), m))
-  replaceMainGoal (← goals.get)
-
-  | _ => throwUnsupportedSyntax

src/Lean/Elab/Tactic/Do/ProofMode/LeftRight.lean

@@ -1,38 +0,0 @@
-/-
-Copyright (c) 2022 Lars König. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Lars König, Mario Carneiro, Sebastian Graf
--/
-prelude
-import Std.Tactic.Do.Syntax
-import Lean.Elab.Tactic.Do.ProofMode.MGoal
-
-namespace Lean.Elab.Tactic.Do.ProofMode
-open Std.Do
-open Lean Elab Tactic Meta
-
-def mLeftRightCore (right : Bool) (mvar : MVarId) : MetaM MVarId := do
-  let g ← instantiateMVars <| ← mvar.getType
-  let some goal := parseMGoal? g | throwError "not in proof mode"
-
-  let mkApp3 (.const ``SPred.or []) σs L R := goal.target | throwError "target is not SPred.or"
-
-  let (thm, keep) := if right then (``SPred.or_intro_r', R) else (``SPred.or_intro_l', L)
-
-  let newGoal ← mkFreshExprSyntheticOpaqueMVar {goal with target := keep}.toExpr
-  mvar.assign (mkApp5 (mkConst thm) σs goal.hyps L R newGoal)
-  return newGoal.mvarId!
-
-@[builtin_tactic Lean.Parser.Tactic.mleft]
-def elabMLeft : Tactic | _ => do
-  let mvar ← getMainGoal
-  mvar.withContext do
-  let newGoal ← mLeftRightCore (right := false) mvar
-  replaceMainGoal [newGoal]
-
-@[builtin_tactic Lean.Parser.Tactic.mright]
-def elabMRight : Tactic | _ => do
-  let mvar ← getMainGoal
-  mvar.withContext do
-  let newGoal ← mLeftRightCore (right := true) mvar
-  replaceMainGoal [newGoal]

src/Lean/Elab/Tactic/Do/ProofMode/MGoal.lean

@@ -1,192 +0,0 @@
-/-
-Copyright (c) 2022 Lars König. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Lars König, Mario Carneiro, Sebastian Graf
--/
-prelude
-import Std.Do.SPred.DerivedLaws
-
-import Lean.Meta
-open Lean Elab Meta
-
-namespace Std.Do
-
-/-- Tautology in `SPred` as a definition. -/
-abbrev SPred.tautological {σs : List Type} (Q : SPred σs) : Prop := ⊢ₛ Q
-
-class PropAsSPredTautology (φ : Prop) {σs : outParam (List Type)} (P : outParam (SPred σs)) : Prop where
-  iff : φ ↔ ⊢ₛ P
-
-instance : PropAsSPredTautology (σs := []) φ φ where
-  iff := true_imp_iff.symm
-
-instance : PropAsSPredTautology (P ⊢ₛ Q) spred(P → Q) where
-  iff := (SPred.entails_true_intro P Q).symm
-
-instance : PropAsSPredTautology (⊢ₛ P) P where
-  iff := Iff.rfl
-
-end Std.Do
-
-namespace Lean.Elab.Tactic.Do.ProofMode
-open Std.Do
-
-theorem start_entails {φ : Prop} [PropAsSPredTautology φ P] : (⊢ₛ P) → φ :=
-  PropAsSPredTautology.iff.mpr
-
-theorem elim_entails {φ : Prop} [PropAsSPredTautology φ P] : φ → (⊢ₛ P) :=
-  PropAsSPredTautology.iff.mp
-
-@[match_pattern] def nameAnnotation := `name
-@[match_pattern] def uniqAnnotation := `uniq
-
-structure Hyp where
-  name : Name
-  uniq : Name -- for display purposes only
-  p : Expr
-
-def parseHyp? : Expr → Option Hyp
-  | .mdata ⟨[(nameAnnotation, .ofName name), (uniqAnnotation, .ofName uniq)]⟩ p =>
-    some ⟨name, uniq, p⟩ -- NB: mdatas are transparent to SubExpr; hence no pos.push
-  | _ => none
-
-def Hyp.toExpr (hyp : Hyp) : Expr :=
-  .mdata ⟨[(nameAnnotation, .ofName hyp.name), (uniqAnnotation, .ofName hyp.uniq)]⟩ hyp.p
-
-/-- An elaborator to create a new named hypothesis for an `MGoal` context. -/
-elab "mk_hyp " name:ident " := " e:term : term <= ty? => do
-  let e ← Lean.Elab.Term.elabTerm e ty?
-  let uniq ← mkFreshId
-  return (Hyp.mk name.getId uniq e).toExpr
-
--- set_option pp.all true in
--- #check ⌜True⌝
-def emptyHyp (σs : Expr) : Expr := -- ⌜True⌝ standing in for an empty conjunction of hypotheses
-  mkApp3 (mkConst ``SVal.curry) (.sort .zero) σs <| mkLambda `escape .default (mkApp (mkConst ``SVal.StateTuple) σs) (mkConst ``True)
-def parseEmptyHyp? : Expr → Option Expr
-  | mkApp3 (.const ``SVal.curry _) (.sort .zero) σs (.lam _ _ (.const ``True _) _) => some σs
-  | _ => none
-
-def pushLeftConjunct (pos : SubExpr.Pos) : SubExpr.Pos :=
-  pos.pushNaryArg 3 1
-
-def pushRightConjunct (pos : SubExpr.Pos) : SubExpr.Pos :=
-  pos.pushNaryArg 3 2
-
-/-- Combine two hypotheses into a conjunction.
-Precondition: Neither `lhs` nor `rhs` is empty (`parseEmptyHyp?`). -/
-def mkAnd! (σs lhs rhs : Expr) : Expr :=
-  mkApp3 (mkConst ``SPred.and) σs lhs rhs
-
-/-- Smart constructor that cancels away empty hypotheses,
-along with a proof that `lhs ∧ rhs ⊣⊢ₛ result`. -/
-def mkAnd (σs lhs rhs : Expr) : Expr × Expr :=
-  if let some _ := parseEmptyHyp? lhs then
-    (rhs, mkApp2 (mkConst ``SPred.true_and) σs rhs)
-  else if let some _ := parseEmptyHyp? rhs then
-    (lhs, mkApp2 (mkConst ``SPred.and_true) σs lhs)
-  else
-    let result := mkAnd! σs lhs rhs
-    (result, mkApp2 (mkConst ``SPred.bientails.refl) σs result)
-
-def σs.mkType : Expr := mkApp (mkConst ``List [.succ .zero]) (mkSort (.succ .zero))
-def σs.mkNil : Expr := mkApp (mkConst ``List.nil [.succ .zero]) (mkSort (.succ .zero))
-
-def parseAnd? (e : Expr) : Option (Expr × Expr × Expr) :=
-  e.app3? ``SPred.and <|> (σs.mkNil, ·) <$> e.app2? ``And
-
-structure MGoal where
-  σs : Expr -- Q(List Type)
-  hyps : Expr -- A conjunction of hypotheses in `SPred σs`, each carrying a name and uniq as metadata (`parseHyp?`)
-  target : Expr -- Q(SPred $σs)
-  deriving Inhabited
-
-/-- This is the same as `SPred.entails`.
-This constant is used to detect `SPred` proof mode goals. -/
-abbrev MGoalEntails := @SPred.entails
-
-def parseMGoal? (expr : Expr) : Option MGoal := do
-  let some (σs, hyps, target) := expr.consumeMData.app3? ``MGoalEntails | none
-  some { σs, hyps, target }
-
-open Tactic in
-def ensureMGoal : TacticM (MVarId × MGoal) := do
-  let mvar ← getMainGoal
-  let goal ← instantiateMVars <| (← mvar.getType)
-  if let some goal := parseMGoal? goal then
-    return (mvar, goal)
-  else
-    throwError "Not in proof mode"
-
-def MGoal.strip (goal : MGoal) : Expr := -- omits the .mdata wrapper
-  mkApp3 (mkConst ``SPred.entails) goal.σs goal.hyps goal.target
-
-/-- Roundtrips with `parseMGoal?`. -/
-def MGoal.toExpr (goal : MGoal) : Expr :=
-  mkApp3 (mkConst ``MGoalEntails) goal.σs goal.hyps goal.target
-
-partial def MGoal.findHyp? (goal : MGoal) (name : Name) : Option (SubExpr.Pos × Hyp) := go goal.hyps SubExpr.Pos.root
-  where
-    go (e : Expr) (p : SubExpr.Pos) : Option (SubExpr.Pos × Hyp) := do
-      if let some hyp := parseHyp? e then
-        if hyp.name = name then
-          return (p, hyp)
-        else
-          none
-      else if let some (_, lhs, rhs) := parseAnd? e then
-        -- NB: Need to prefer rhs over lhs, like the goal view (Lean.Elab.Tactic.Do.ProofMode.Display).
-        go rhs (pushLeftConjunct p) <|> go lhs (pushRightConjunct p)
-      else if let some _ := parseEmptyHyp? e then
-        none
-      else
-        panic! "MGoal.findHyp?: hypothesis without proper metadata: {e}"
-
-def MGoal.checkProof (goal : MGoal) (prf : Expr) (suppressWarning : Bool := false) : MetaM Unit := do
-  check prf
-  let prf_type ← inferType prf
-  unless ← isDefEq goal.toExpr prf_type do
-    throwError "MGoal.checkProof: the proof and its supposed type did not match.\ngoal:  {goal.toExpr}\nproof: {prf_type}"
-  unless suppressWarning do
-    logWarning m!"stray MGoal.checkProof {prf_type} {goal.toExpr}"
-
-def getFreshHypName : TSyntax ``binderIdent → CoreM (Name × Syntax)
-  | `(binderIdent| $name:ident) => pure (name.getId, name)
-  | stx => return (← mkFreshUserName `h, stx)
-
-partial def betaRevPreservingHypNames (σs' e : Expr) (args : Array Expr) : Expr :=
-  if let some _σs := parseEmptyHyp? e then
-    emptyHyp σs'
-  else if let some hyp := parseHyp? e then
-    { hyp with p := hyp.p.betaRev args }.toExpr
-  else if let some (_σs, lhs, rhs) := parseAnd? e then
-    -- _σs = σ :: σs'
-    mkAnd! σs' (betaRevPreservingHypNames σs' lhs args) (betaRevPreservingHypNames σs' rhs args)
-  else
-    e.betaRev args
-
-def betaPreservingHypNames (σs' e : Expr) (args : Array Expr) : Expr :=
-  betaRevPreservingHypNames σs' e args.reverse
-
-def dropStateList (σs : Expr) (n : Nat) : MetaM Expr := do
-  let mut σs := σs
-  for _ in [:n] do
-    let some (_type, _σ, σs') := (← whnfR σs).app3? ``List.cons | throwError "Ambient state list not a cons {σs}"
-    σs := σs'
-  return σs
-
-/-- This is only used for display purposes, so that we can render context variables that appear
-to have type `A : PROP` even though `PROP` is not a type. -/
-def HypMarker {σs : List Type} (_A : SPred σs) : Prop := True
-
-def addLocalVarInfo (stx : Syntax) (lctx : LocalContext)
-    (expr : Expr) (expectedType? : Option Expr) (isBinder := false) : MetaM Unit := do
-  Elab.withInfoContext' (pure ())
-    (fun _ =>
-      return .inl <| .ofTermInfo
-        { elaborator := .anonymous, lctx, expr, stx, expectedType?, isBinder })
-    (return .ofPartialTermInfo { elaborator := .anonymous, lctx, stx, expectedType? })
-
-def addHypInfo (stx : Syntax) (σs : Expr) (hyp : Hyp) (isBinder := false) : MetaM Unit := do
-  let lctx ← getLCtx
-  let ty := mkApp2 (mkConst ``HypMarker) σs hyp.p
-  addLocalVarInfo stx (lctx.mkLocalDecl ⟨hyp.uniq⟩ hyp.name ty) (.fvar ⟨hyp.uniq⟩) ty isBinder

src/Lean/Elab/Tactic/Do/ProofMode/Pure.lean

@@ -1,71 +0,0 @@
-/-
-Copyright (c) 2022 Lars König. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Lars König, Mario Carneiro, Sebastian Graf
--/
-prelude
-import Std.Tactic.Do.Syntax
-import Lean.Elab.Tactic.Do.ProofMode.MGoal
-import Lean.Elab.Tactic.Do.ProofMode.Focus
-
-namespace Lean.Elab.Tactic.Do.ProofMode
-open Std.Do
-open Lean Elab Tactic Meta
-
-class IsPure {σs : List Type} (P : SPred σs) (φ : outParam Prop) where to_pure : P ⊣⊢ₛ ⌜φ⌝
-instance (σs) : IsPure (σs:=σs) ⌜φ⌝ φ where to_pure := .rfl
-instance (σs) : IsPure (σs:=σs) spred(⌜φ⌝ → ⌜ψ⌝) (φ → ψ) where to_pure := SPred.pure_imp
-instance (σs) : IsPure (σs:=σs) spred(⌜φ⌝ ∧ ⌜ψ⌝) (φ ∧ ψ) where to_pure := SPred.pure_and
-instance (σs) : IsPure (σs:=σs) spred(⌜φ⌝ ∨ ⌜ψ⌝) (φ ∨ ψ) where to_pure := SPred.pure_or
-instance (σs) (P : α → Prop) : IsPure (σs:=σs) spred(∃ x, ⌜P x⌝) (∃ x, P x) where to_pure := SPred.pure_exists
-instance (σs) (P : α → Prop) : IsPure (σs:=σs) spred(∀ x, ⌜P x⌝) (∀ x, P x) where to_pure := SPred.pure_forall
-instance (σs) (P : SPred (σ::σs)) [inst : IsPure P φ] : IsPure (σs:=σs) spred(P s) φ where to_pure := (iff_of_eq SPred.bientails_cons).mp inst.to_pure s
-instance (P : Prop) : IsPure (σs:=[]) P P where to_pure := Iff.rfl
-
-theorem Pure.thm {σs : List Type} {P Q T : SPred σs} {φ : Prop} [IsPure Q φ]
-  (h : φ → P ⊢ₛ T) : P ∧ Q ⊢ₛ T := by
-    apply SPred.pure_elim
-    · exact SPred.and_elim_r.trans IsPure.to_pure.mp
-    · intro hp
-      exact SPred.and_elim_l.trans (h hp)
-
--- NB: We do not use MVarId.intro because that would mean we require all callers to supply an MVarId.
--- This function only knows about the hypothesis H=⌜φ⌝ to destruct.
--- It will provide a proof for Q ∧ H ⊢ₛ T
--- if `k` produces a proof for Q ⊢ₛ T that may range over a pure proof h : φ.
--- It calls `k` with the φ in H = ⌜φ⌝ and a proof `h : φ` thereof.
-def mPureCore (σs : Expr) (hyp : Expr) (name : TSyntax ``binderIdent)
-  (k : Expr /-φ:Prop-/ → Expr /-h:φ-/ → MetaM (α × MGoal × Expr)) : MetaM (α × MGoal × Expr) := do
-  let φ ← mkFreshExprMVar (mkSort .zero)
-  let inst ← synthInstance (mkApp3 (mkConst ``IsPure) σs hyp φ)
-  let (name, ref) ← getFreshHypName name
-  withLocalDeclD name φ fun h => do
-    addLocalVarInfo ref (← getLCtx) h φ
-    let (a, goal, prf /- : goal.toExpr -/) ← k φ h
-    let prf ← mkLambdaFVars #[h] prf
-    let prf := mkApp7 (mkConst ``Pure.thm) σs goal.hyps hyp goal.target φ inst prf
-    let goal := { goal with hyps := mkAnd! σs goal.hyps hyp }
-    return (a, goal, prf)
-
-@[builtin_tactic Lean.Parser.Tactic.mpure]
-def elabMPure : Tactic
-  | `(tactic| mpure $hyp) => do
-  let mvar ← getMainGoal
-  mvar.withContext do
-  let g ← instantiateMVars <| ← mvar.getType
-  let some goal := parseMGoal? g | throwError "not in proof mode"
-  let res ← goal.focusHypWithInfo hyp
-  let (m, _new_goal, prf) ← mPureCore goal.σs res.focusHyp (← `(binderIdent| $hyp:ident)) fun _ _ => do
-    let goal := res.restGoal goal
-    let m ← mkFreshExprSyntheticOpaqueMVar goal.toExpr
-    return (m, goal, m)
-  let prf := res.rewriteHyps goal prf
-  mvar.assign prf
-  replaceMainGoal [m.mvarId!]
-  | _ => throwUnsupportedSyntax
-
-/-- A generalization of `SPred.pure_intro` exploiting `IsPure`. -/
-private theorem Pure.intro {σs : List Type} {P Q : SPred σs} {φ : Prop} [IsPure Q φ] (hp : φ) : P ⊢ₛ Q :=
-  (SPred.pure_intro hp).trans IsPure.to_pure.mpr
-
-macro "mpure_intro" : tactic => `(tactic| apply Pure.intro)

src/Lean/Elab/Tactic/Do/ProofMode/Refine.lean

@@ -1,78 +0,0 @@
-/-
-Copyright (c) 2022 Lars König. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Lars König, Mario Carneiro, Sebastian Graf
--/
-prelude
-import Std.Tactic.Do.Syntax
-import Lean.Elab.Tactic.Do.ProofMode.Focus
-import Lean.Elab.Tactic.Do.ProofMode.Assumption
-import Lean.Elab.Tactic.Do.ProofMode.Exact
-
-namespace Lean.Elab.Tactic.Do.ProofMode
-open Std.Do Lean.Parser.Tactic
-open Lean Elab Tactic Meta
-
-def patAsTerm (pat : MRefinePat) (expected : Option Expr := none) : OptionT TacticM Expr := do
-  match pat with
-  | .pure t => elabTerm t expected
-  | .one name =>
-    if let `(binderIdent| $name:ident) := name then
-      elabTerm (← `($name)) expected
-    else failure
-  | _ => failure
-
-partial def mRefineCore (goal : MGoal) (pat : MRefinePat) (k : MGoal → TSyntax ``binderIdent → TacticM Expr) : TacticM Expr := do
-  match pat with
-  | .stateful name => liftMetaM do
-    match name with
-    | `(binderIdent| $name:ident) => do
-      let some prf ← goal.exact name | throwError "unknown hypothesis '{repr name}'"
-      return prf
-    | _ => do
-      let some prf ← goal.assumption | throwError "could not solve {goal.target} by assumption"
-      return prf
-  | .pure t => do
-    goal.exactPure t
-  | .one name =>
-      if let `(binderIdent| $_:ident) := name then
-        mRefineCore goal (.pure ⟨name.raw⟩) k <|> mRefineCore goal (.stateful name) k
-      else
-        mRefineCore goal (.stateful name) k
-  | .hole name => k goal name
-  | .tuple [] => throwUnsupportedSyntax
-  | .tuple [p] => mRefineCore goal p k
-  | .tuple (p::ps) => do
-    let T ← whnfR goal.target
-    if let some (σs, T₁, T₂) := parseAnd? T.consumeMData then
-      let prf₁ ← mRefineCore { goal with target := T₁ } p k
-      let prf₂ ← mRefineCore { goal with target := T₂ } (.tuple ps) k
-      return mkApp6 (mkConst ``SPred.and_intro) σs goal.hyps T₁ T₂ prf₁ prf₂
-    else if let some (α, σs, ψ) := T.app3? ``SPred.exists then
-      let some witness ← patAsTerm p (some α) | throwError "pattern does not elaborate to a term to instantiate ψ"
-      let prf ← mRefineCore { goal with target := ψ.betaRev #[witness] } (.tuple ps) k
-      let u ← getLevel α
-      return mkApp6 (mkConst ``SPred.exists_intro' [u]) α σs goal.hyps ψ witness prf
-    else throwError "Neither a conjunction nor an existential quantifier {goal.target}"
-
-@[builtin_tactic Lean.Parser.Tactic.mrefine]
-def elabMRefine : Tactic
-  | `(tactic| mrefine $pat:mrefinePat) => do
-  let pat ← liftMacroM <| MRefinePat.parse pat
-  let (mvar, goal) ← mStartMVar (← getMainGoal)
-  mvar.withContext do
-
-  let goals ← IO.mkRef #[]
-  let prf ← mRefineCore goal pat fun goal name => do
-    let m ← mkFreshExprSyntheticOpaqueMVar goal.toExpr name.raw.getId
-    goals.modify (·.push m.mvarId!)
-    return m
-  mvar.assign prf
-  replaceMainGoal (← goals.get).toList
-  | _ => throwUnsupportedSyntax
-
-macro_rules
-  | `(tactic| mexists $args,*) => do
-  let pats ← args.getElems.mapM fun t => `(mrefinePat| ⌜$t⌝)
-  let pat ← pats.foldrM (fun pat acc => `(mrefinePat| ⟨$pat, $acc⟩)) (← `(mrefinePat| ?_))
-  `(tactic| (mrefine $pat; try massumption))

src/Lean/Elab/Tactic/Do/ProofMode/Revert.lean

@@ -1,40 +0,0 @@
-/-
-Copyright (c) 2022 Lars König. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Lars König, Mario Carneiro, Sebastian Graf
--/
-prelude
-import Std.Tactic.Do.Syntax
-import Lean.Elab.Tactic.Do.ProofMode.Focus
-import Lean.Elab.Tactic.Do.ProofMode.Basic
-
-namespace Lean.Elab.Tactic.Do.ProofMode
-open Std.Do
-open Lean Elab Tactic Meta
-
-theorem Revert.revert {σs : List Type} {P Q H T : SPred σs} (hfoc : P ⊣⊢ₛ Q ∧ H) (h : Q ⊢ₛ H → T) : P ⊢ₛ T :=
-  hfoc.mp.trans (SPred.imp_elim h)
-
-partial def mRevertStep (goal : MGoal) (ref : TSyntax `ident) (k : MGoal → MetaM Expr) : MetaM Expr := do
-  let res ← goal.focusHypWithInfo ref
-  let P := goal.hyps
-  let Q := res.restHyps
-  let H := res.focusHyp
-  let T := goal.target
-  let prf ← k { goal with hyps := Q, target := mkApp3 (mkConst ``SPred.imp) goal.σs H T }
-  let prf := mkApp7 (mkConst ``Revert.revert) goal.σs P Q H T res.proof prf
-  return prf
-
-@[builtin_tactic Lean.Parser.Tactic.mrevert]
-def elabMRevert : Tactic
-  | `(tactic| mrevert $h) => do
-  let (mvar, goal) ← mStartMVar (← getMainGoal)
-  mvar.withContext do
-
-  let goals ← IO.mkRef []
-  mvar.assign (← mRevertStep goal h fun newGoal => do
-    let m ← mkFreshExprSyntheticOpaqueMVar newGoal.toExpr
-    goals.modify (m.mvarId! :: ·)
-    return m)
-  replaceMainGoal (← goals.get)
-  | _ => throwUnsupportedSyntax

src/Lean/Elab/Tactic/Do/ProofMode/Specialize.lean

@@ -1,203 +0,0 @@
-/-
-Copyright (c) 2022 Lars König. All rights reserved.
-Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Lars König, Mario Carneiro, Sebastian Graf
--/
-prelude
-import Std.Tactic.Do.Syntax
-import Lean.Elab.Tactic.Do.ProofMode.MGoal
-import Lean.Elab.Tactic.Do.ProofMode.Focus
-import Lean.Elab.Tactic.Do.ProofMode.Basic
-import Lean.Elab.Tactic.Do.ProofMode.Pure
-
-namespace Lean.Elab.Tactic.Do.ProofMode
-open Std.Do
-open Lean Elab Tactic Meta
-
-initialize registerTraceClass `Meta.Tactic.Do.specialize
-
-theorem Specialize.imp_stateful {P P' Q R : SPred σs}
-  (hrefocus : P ∧ (Q → R) ⊣⊢ₛ P' ∧ Q) : P ∧ (Q → R) ⊢ₛ P ∧ R := by
-  calc spred(P ∧ (Q → R))
-    _ ⊢ₛ (P' ∧ Q) ∧ (Q → R) := SPred.and_intro hrefocus.mp SPred.and_elim_r
-    _ ⊢ₛ P' ∧ Q ∧ (Q → R) := SPred.and_assoc.mp
-    _ ⊢ₛ P' ∧ Q ∧ R := SPred.and_mono_r (SPred.and_intro SPred.and_elim_l SPred.imp_elim_r)
-    _ ⊢ₛ (P' ∧ Q) ∧ R := SPred.and_assoc.mpr
-    _ ⊢ₛ P ∧ R := SPred.and_mono_l (hrefocus.mpr.trans SPred.and_elim_l)
-
-theorem Specialize.imp_pure {P Q R : SPred σs} [PropAsSPredTautology φ Q]
-  (h : φ) : P ∧ (Q → R) ⊢ₛ P ∧ R := by
-  calc spred(P ∧ (Q → R))
-    _ ⊢ₛ P ∧ (Q ∧ (Q → R)) := SPred.and_mono_r (SPred.and_intro (SPred.true_intro.trans (PropAsSPredTautology.iff.mp h)) .rfl)
-    _ ⊢ₛ P ∧ R := SPred.and_mono_r (SPred.mp SPred.and_elim_r SPred.and_elim_l)
-
-theorem Specialize.forall {P : SPred σs} {ψ : α → SPred σs}
-  (a : α) : P ∧ (∀ x, ψ x) ⊢ₛ P ∧ ψ a := SPred.and_mono_r (SPred.forall_elim a)
-
-theorem Specialize.pure_start {φ : Prop} {H P T : SPred σs} [PropAsSPredTautology φ H] (hpure : φ) (hgoal : P ∧ H ⊢ₛ T) : P ⊢ₛ T :=
-  (SPred.and_intro .rfl (SPred.true_intro.trans (PropAsSPredTautology.iff.mp hpure))).trans hgoal
-
-theorem Specialize.pure_taut {σs} {φ} {P : SPred σs} [IsPure P φ] (h : φ) : ⊢ₛ P :=
-  (SPred.pure_intro h).trans IsPure.to_pure.mpr
-
-def mSpecializeImpStateful (σs : Expr) (P : Expr) (QR : Expr) (arg : TSyntax `term) : OptionT TacticM (Expr × Expr) := do
-  guard (arg.raw.isIdent)
-  let some argRes := focusHyp σs (mkAnd! σs P QR) arg.raw.getId | failure
-  let some hyp := parseHyp? argRes.focusHyp | failure
-  addHypInfo arg σs hyp
-  OptionT.mk do -- no OptionT failure after this point
-  -- The goal is P ∧ (Q → R)
-  -- argRes.proof : P ∧ (Q → R) ⊣⊢ₛ P' ∧ Q
-  -- we want to return (R, (proof : P ∧ (Q → R) ⊢ₛ P ∧ R))
-  let some specHyp := parseHyp? QR | panic! "Precondition of specializeImpStateful violated"
-  let P' := argRes.restHyps
-  let Q := argRes.focusHyp
-  let hrefocus := argRes.proof -- P ∧ (Q → R) ⊣⊢ₛ P' ∧ Q
-  let mkApp3 (.const ``SPred.imp []) σs Q' R := specHyp.p | throwError "Expected implication {QR}"
-  let proof := mkApp6 (mkConst ``Specialize.imp_stateful) σs P P' Q R hrefocus
-  -- check proof
-  trace[Meta.Tactic.Do.specialize] "Statefully specialize {specHyp.p} with {Q}. New Goal: {mkAnd! σs P R}"
-  unless ← isDefEq Q Q' do
-    throwError "failed to specialize {specHyp.p} with {Q}"
-
-  return ({ specHyp with p := R }.toExpr, proof)
-
-def mSpecializeImpPure (_σs : Expr) (P : Expr) (QR : Expr) (arg : TSyntax `term) : OptionT TacticM (Expr × Expr) := do
-  let some specHyp := parseHyp? QR | panic! "Precondition of specializeImpPure violated"
-  let mkApp3 (.const ``SPred.imp []) σs Q R := specHyp.p | failure
-  let mut φ ← mkFreshExprMVar (mkSort .zero)
-  let mut (hφ, mvarIds) ← try
-    elabTermWithHoles arg.raw φ `specialize (allowNaturalHoles := true)
-    catch _ => failure
-  -- We might have hφ : φ and Q = ⌜φ⌝. In this case, convert hφ to a proof of ⊢ₛ ⌜φ⌝,
-  -- so that we can infer an instance of `PropAsSPredTautology`.
-  -- NB: PropAsSPredTautology φ ⌜φ⌝ is unfortunately impossible because ⊢ₛ ⌜φ⌝ does not imply φ.
-  -- Hence this additional (lossy) conversion.
-  if let some inst ← synthInstance? (mkApp3 (mkConst ``IsPure) σs Q φ) then
-    hφ := mkApp5 (mkConst ``Specialize.pure_taut) σs φ Q inst hφ
-    φ := mkApp2 (mkConst ``SPred.tautological) σs Q
-
-  let some inst ← synthInstance? (mkApp3 (mkConst ``PropAsSPredTautology) φ σs Q)
-    | failure
-
-  OptionT.mk do -- no OptionT failure after this point
-  -- The goal is P ∧ (Q → R)
-  -- we want to return (R, (proof : P ∧ (Q → R) ⊢ₛ P ∧ R))
-  pushGoals mvarIds
-  let proof := mkApp7 (mkConst ``Specialize.imp_pure) σs φ P Q R inst hφ
-  -- check proof
-  trace[Meta.Tactic.Do.specialize] "Purely specialize {specHyp.p} with {Q}. New Goal: {mkAnd! σs P R}"
-  -- logInfo m!"proof: {← inferType proof}"
-  return ({ specHyp with p := R }.toExpr, proof)
-
-def mSpecializeForall (_σs : Expr) (P : Expr) (Ψ : Expr) (arg : TSyntax `term) : OptionT TacticM (Expr × Expr) := do
-  let some specHyp := parseHyp? Ψ | panic! "Precondition of specializeForall violated"
-  let mkApp3 (.const ``SPred.forall [u]) α σs αR := specHyp.p | failure
-  let (a, mvarIds) ← try
-    elabTermWithHoles arg.raw α `specialize (allowNaturalHoles := true)
-    catch _ => failure
-  OptionT.mk do -- no OptionT failure after this point
-  pushGoals mvarIds
-  let proof := mkApp5 (mkConst ``Specialize.forall [u]) σs α P αR a
-  let R := αR.beta #[a]
-  -- check proof
-  trace[Meta.Tactic.Do.specialize] "Instantiate {specHyp.p} with {a}. New Goal: {mkAnd! σs P R}"
-  return ({ specHyp with p := R }.toExpr, proof)
-
-theorem focus {P P' Q R : SPred σs} (hfocus : P ⊣⊢ₛ P' ∧ Q) (hnew : P' ∧ Q ⊢ₛ R) : P ⊢ₛ R :=
-  hfocus.mp.trans hnew
-
-@[builtin_tactic Lean.Parser.Tactic.mspecialize]
-def elabMSpecialize : Tactic
-  | `(tactic| mspecialize $hyp $args*) => do
-  let (mvar, goal) ← mStartMVar (← getMainGoal)
-  mvar.withContext do
-
-  -- Want to prove goal P ⊢ T, where hyp occurs in P.
-  -- So we
-  -- 1. focus on hyp (referred to as H):  P ⊣⊢ₛ P' ∧ H. Prove P' ∧ H ⊢ₛ T
-  -- 2. Produce a (transitive chain of) proofs
-  --      P' ∧ H ⊢ P' ∧ H₁ ⊢ₛ P' ∧ H₂ ⊢ₛ ...
-  --    One for each arg; end up with goal P' ∧ H' ⊢ₛ T
-  -- 3. Recombine with mkAnd (NB: P' might be empty), compose with P' ∧ H' ⊣⊢ₛ mkAnd P' H'.
-  -- 4. Make a new MVar for goal `mkAnd P' H' ⊢ T` and assign the transitive chain.
-  let some specFocus := goal.focusHyp hyp.getId | throwError "unknown identifier '{hyp}'"
-  let σs := goal.σs
-  let P := specFocus.restHyps
-  let mut H := specFocus.focusHyp
-  let some hyp' := parseHyp? H | panic! "Invariant of specialize violated"
-  addHypInfo hyp σs hyp'
-  -- invariant: proof (_ : { goal with hyps := mkAnd! σs P H }.toExpr) fills the mvar
-  let mut proof : Expr → Expr :=
-    mkApp7 (mkConst ``focus) σs goal.hyps P H goal.target specFocus.proof
-
-  for arg in args do
-    let res? ← OptionT.run
-      (mSpecializeImpStateful σs P H arg
-        <|> mSpecializeImpPure σs P H arg
-        <|> mSpecializeForall σs P H arg)
-    match res? with
-    | some (H', H2H') =>
-      -- logInfo m!"H: {H}, proof: {← inferType H2H'}"
-      proof := fun hgoal => proof (mkApp6 (mkConst ``SPred.entails.trans) σs (mkAnd! σs P H) (mkAnd! σs P H') goal.target H2H' hgoal)
-      H := H'
-    | none =>
-      throwError "Could not specialize {H} with {arg}"
-
-  let newMVar ← mkFreshExprSyntheticOpaqueMVar { goal with hyps := mkAnd! σs P H }.toExpr
-  mvar.assign (proof newMVar)
-  replaceMainGoal [newMVar.mvarId!]
-
-  | _ => throwUnsupportedSyntax
-
-@[builtin_tactic Lean.Parser.Tactic.mspecializePure]
-def elabMspecializePure : Tactic
-  | `(tactic| mspecialize_pure $head $args* => $hyp) => do
-  -- "mspecialize_pure" >> term >> many (ppSpace >> checkColGt "irrelevant" >> termParser (eval_prec max)) >> "as" >> ident
-  let (mvar, goal) ← mStartMVar (← getMainGoal)
-  mvar.withContext do
-
-  -- Want to prove goal P ⊢ₛ T. `head` is a pure proof of type `φ` that turns into `⊢ₛ H` via `start_entails`.
-  -- So we
-  -- 1. Introduce `head` via `PropAsEntails` as stateful hypothesis named `hyp`, P ∧ (hyp : H) ⊢ₛ T
-  -- 2. (from here on it's the same as `mspecialize`.)
-  --    Produce a (transitive chain of) proofs
-  --      P ∧ H ⊢ P ∧ H₁ ⊢ₛ P ∧ H₂ ⊢ₛ ...
-  --    One for each arg; end up with goal P ∧ H' ⊢ₛ T
-  -- 3. Recombine with mkAnd (NB: P' might be empty), compose with P' ∧ H' ⊣⊢ₛ mkAnd P' H'.
-  -- 4. Make a new MVar for goal `mkAnd P' H' ⊢ T` and assign the transitive chain.
-  let σs := goal.σs
-  let P := goal.hyps
-  let T := goal.target
-  let hφ ← elabTerm head none
-  let φ ← inferType hφ
-  let H ← mkFreshExprMVar (mkApp (mkConst ``SPred) σs)
-  let inst ← synthInstance (mkApp3 (mkConst ``PropAsSPredTautology) φ σs H)
-  let uniq ← mkFreshId
-  let mut H := (Hyp.mk hyp.getId uniq (← instantiateMVars H)).toExpr
-
-  let goal : MGoal := { goal with hyps := mkAnd! σs P H }
-  -- invariant: proof (_ : { goal with hyps := mkAnd! σs P H }.toExpr) fills the mvar
-  let mut proof : Expr → Expr :=
-    mkApp8 (mkConst ``Specialize.pure_start) σs φ H P T inst hφ
-
-  for arg in args do
-    let res? ← OptionT.run
-      (mSpecializeImpStateful σs P H ⟨arg⟩
-        <|> mSpecializeImpPure σs P H ⟨arg⟩
-        <|> mSpecializeForall σs P H ⟨arg⟩)
-    match res? with
-    | some (H', H2H') =>
-      -- logInfo m!"H: {H}, proof: {← inferType H2H'}"
-      proof := fun hgoal => proof (mkApp6 (mkConst ``SPred.entails.trans) σs (mkAnd! σs P H) (mkAnd! σs P H') goal.target H2H' hgoal)
-      H := H'
-    | none =>
-      throwError "Could not specialize {H} with {arg}"
-
-  let some hyp' := parseHyp? H | panic! "Invariant of specialize_pure violated"
-  addHypInfo hyp σs hyp'
-
-  let newMVar ← mkFreshExprSyntheticOpaqueMVar { goal with hyps := mkAnd! σs P H }.toExpr
-  mvar.assign (proof newMVar)
-  replaceMainGoal [newMVar.mvarId!]
-  | _ => throwUnsupportedSyntax

src/Lean/Elab/Tactic/Induction.lean

@@ -412,7 +412,7 @@ where
           applyAltStx tacSnaps altStxs altStxIdx altStx alt
         alts := #[]
       else
-        throwErrorAt altStx (Term.mkRedundantAlternativeMsg altName none)
+        throwNamedErrorAt altStx lean.redundantMatchAlt (Term.mkRedundantAlternativeMsg altName none)
 
     -- now process remaining alternatives; these might either be unreachable or we're in `induction`
     -- without `with`. In all other cases, remaining alternatives are flagged as errors.

src/Lean/Elab/Tactic/Lets.lean

@@ -65,4 +65,15 @@ declare_config_elab elabLiftLetsConfig LiftLetsConfig
       (atTarget := liftMetaTactic1 fun mvarId => mvarId.liftLets config)
       (failed := fun _ => throwError "'lift_lets' tactic failed")
 
+/-!
+### `let_to_have`
+-/
+
+@[builtin_tactic letToHave] elab_rules : tactic
+  | `(tactic| let_to_have $[$loc?:location]?) => do
+    withLocation (expandOptLocation (Lean.mkOptionalNode loc?))
+      (atLocal := fun h => liftMetaTactic1 fun mvarId => mvarId.letToHaveLocalDecl h)
+      (atTarget := liftMetaTactic1 fun mvarId => mvarId.letToHave)
+      (failed := fun _ => throwError "'let_to_have' tactic failed")
+
 end Lean.Elab.Tactic

src/Lean/Elab/Tactic/Monotonicity.lean

@@ -134,7 +134,7 @@ def solveMonoStep (failK : ∀ {α}, Expr → Array Name → MetaM α := @defaul
       return [goal'.mvarId!]
 
     -- Handle let
-    if let .letE n t v b _nonDep := e then
+    if let .letE n t v b nondep := e then
       if t.hasLooseBVars || v.hasLooseBVars then
         -- We cannot float the let to the context, so just zeta-reduce.
         let b' := f.updateLambdaE! f.bindingDomain! (b.instantiate1 v)
@@ -143,10 +143,10 @@ def solveMonoStep (failK : ∀ {α}, Expr → Array Name → MetaM α := @defaul
         return [goal'.mvarId!]
       else
         -- No recursive call in t or v, so float out
-        let goal' ← withLetDecl n t v fun x => do
+        let goal' ← withLetDecl n t v (nondep := nondep) fun x => do
           let b' := f.updateLambdaE! f.bindingDomain! (b.instantiate1 x)
           let goal' ← mkFreshExprSyntheticOpaqueMVar (mkApp type.appFn! b')
-          goal.assign (← mkLetFVars #[x] goal')
+          goal.assign (← mkLetFVars (generalizeNondepLet := false) #[x] goal')
           pure goal'
         return [goal'.mvarId!]
 

src/Lean/Elab/Tactic/NormCast.lean

@@ -266,7 +266,7 @@ def evalConvNormCast : Tactic :=
 
 @[builtin_tactic pushCast]
 def evalPushCast : Tactic := fun stx => do
-  let { ctx, simprocs, dischargeWrapper } ← withMainContext do
+  let { ctx, simprocs, dischargeWrapper, .. } ← withMainContext do
     mkSimpContext (simpTheorems := pushCastExt.getTheorems) stx (eraseLocal := false)
   let ctx := ctx.setFailIfUnchanged false
   dischargeWrapper.with fun discharge? =>

src/Lean/Elab/Tactic/RCases.lean

@@ -27,11 +27,12 @@ instance : Coe (TSyntax ``rcasesPatMed) (TSyntax ``rcasesPatLo) where
 instance : Coe (TSyntax `rcasesPat) (TSyntax `rintroPat) where
   coe stx := Unhygienic.run `(rintroPat| $stx:rcasesPat)
 
-/-- A list, with a disjunctive meaning (like a list of inductive constructors, or subgoals) -/
-local notation "ListΣ" => List
+-- These frequently cause bootstrapping issues. Commented out for now, using `List/-Σ-/` and `List/-Π-/` instead.
+-- /-- A list, with a disjunctive meaning (like a list of inductive constructors, or subgoals) -/
+-- local notation "ListΣ" => List
 
-/-- A list, with a conjunctive meaning (like a list of constructor arguments, or hypotheses) -/
-local notation "ListΠ" => List
+-- /-- A list, with a conjunctive meaning (like a list of constructor arguments, or hypotheses) -/
+-- local notation "ListΠ" => List
 
 /--
 An `rcases` pattern can be one of the following, in a nested combination:
@@ -65,9 +66,9 @@ inductive RCasesPatt : Type
   /-- A type ascription like `pat : ty` (parentheses are optional) -/
   | typed (ref : Syntax) : RCasesPatt → Term → RCasesPatt
   /-- A tuple constructor like `⟨p1, p2, p3⟩` -/
-  | tuple (ref : Syntax) : ListΠ RCasesPatt → RCasesPatt
+  | tuple (ref : Syntax) : List/-Π-/ RCasesPatt → RCasesPatt
   /-- An alternation / variant pattern `p1 | p2 | p3` -/
-  | alts (ref : Syntax) : ListΣ RCasesPatt → RCasesPatt
+  | alts (ref : Syntax) : List/-Σ-/ RCasesPatt → RCasesPatt
   deriving Repr
 
 namespace RCasesPatt
@@ -97,7 +98,7 @@ def ref : RCasesPatt → Syntax
 /--
 Interpret an rcases pattern as a tuple, where `p` becomes `⟨p⟩` if `p` is not already a tuple.
 -/
-def asTuple : RCasesPatt → Bool × ListΠ RCasesPatt
+def asTuple : RCasesPatt → Bool × List/-Π-/ RCasesPatt
   | paren _ p    => p.asTuple
   | explicit _ p => (true, p.asTuple.2)
   | tuple _ ps   => (false, ps)
@@ -107,7 +108,7 @@ def asTuple : RCasesPatt → Bool × ListΠ RCasesPatt
 Interpret an rcases pattern as an alternation, where non-alternations are treated as one
 alternative.
 -/
-def asAlts : RCasesPatt → ListΣ RCasesPatt
+def asAlts : RCasesPatt → List/-Σ-/ RCasesPatt
   | paren _ p => p.asAlts
   | alts _ ps => ps
   | p         => [p]
@@ -118,7 +119,7 @@ def typed? (ref : Syntax) : RCasesPatt → Option Term → RCasesPatt
   | p, some ty => typed ref p ty
 
 /-- Convert a list of patterns to a tuple pattern, but mapping `[p]` to `p` instead of `⟨p⟩`. -/
-def tuple' : ListΠ RCasesPatt → RCasesPatt
+def tuple' : List/-Π-/ RCasesPatt → RCasesPatt
   | [p] => p
   | ps  => tuple (ps.head?.map (·.ref) |>.getD .missing) ps
 
@@ -126,7 +127,7 @@ def tuple' : ListΠ RCasesPatt → RCasesPatt
 Convert a list of patterns to an alternation pattern, but mapping `[p]` to `p` instead of
 a unary alternation `|p`.
 -/
-def alts' (ref : Syntax) : ListΣ RCasesPatt → RCasesPatt
+def alts' (ref : Syntax) : List/-Σ-/ RCasesPatt → RCasesPatt
   | [p] => p
   | ps  => alts ref ps
 
@@ -139,7 +140,7 @@ becomes `⟨a, b, c, d⟩` instead of `⟨a, b, ⟨c, d⟩⟩`.
 We must be careful to turn `[a, ⟨⟩]` into `⟨a, ⟨⟩⟩` instead of `⟨a⟩` (which will not perform the
 nested match).
 -/
-def tuple₁Core : ListΠ RCasesPatt → ListΠ RCasesPatt
+def tuple₁Core : List/-Π-/ RCasesPatt → List/-Π-/ RCasesPatt
   | []         => []
   | [tuple ref []] => [tuple ref []]
   | [tuple _ ps] => ps
@@ -150,7 +151,7 @@ This function is used for producing rcases patterns based on a case tree. This i
 `tuple₁Core` but it produces a pattern instead of a tuple pattern list, converting `[n]` to `n`
 instead of `⟨n⟩` and `[]` to `_`, and otherwise just converting `[a, b, c]` to `⟨a, b, c⟩`.
 -/
-def tuple₁ : ListΠ RCasesPatt → RCasesPatt
+def tuple₁ : List/-Π-/ RCasesPatt → RCasesPatt
   | []      => default
   | [one ref n] => one ref n
   | ps      => tuple ps.head!.ref $ tuple₁Core ps
@@ -162,7 +163,7 @@ produce a list of alternatives with the same effect. This function calls `tuple
 individual alternatives, and handles merging `[a, b, c | d]` to `a | b | c | d` instead of
 `a | b | (c | d)`.
 -/
-def alts₁Core : ListΣ (ListΠ RCasesPatt) → ListΣ RCasesPatt
+def alts₁Core : List/-Σ-/ (List/-Π-/ RCasesPatt) → List/-Σ-/ RCasesPatt
   | []          => []
   | [[alts _ ps]] => ps
   | p :: ps     => tuple₁ p :: alts₁Core ps
@@ -174,7 +175,7 @@ specially translate the empty alternation to `⟨⟩`, and translate `|(a | b)`
 don't have any syntax for unary alternation). Otherwise we can use the regular merging of
 alternations at the last argument so that `a | b | (c | d)` becomes `a | b | c | d`.
 -/
-def alts₁ (ref : Syntax) : ListΣ (ListΠ RCasesPatt) → RCasesPatt
+def alts₁ (ref : Syntax) : List/-Σ-/ (List/-Π-/ RCasesPatt) → RCasesPatt
   | [[]]        => tuple .missing []
   | [[alts ref ps]] => tuple ref ps
   | ps          => alts' ref $ alts₁Core ps
@@ -204,7 +205,7 @@ constructor. The `name` is the name which will be used in the top-level `cases`
 tactics.
 -/
 def processConstructor (ref : Syntax) (info : Array ParamInfo)
-    (explicit : Bool) (idx : Nat) (ps : ListΠ RCasesPatt) : ListΠ Name × ListΠ RCasesPatt :=
+    (explicit : Bool) (idx : Nat) (ps : List/-Π-/ RCasesPatt) : List/-Π-/ Name × List/-Π-/ RCasesPatt :=
   if _ : idx < info.size then
     if !explicit && info[idx].binderInfo != .default then
       let (ns, tl) := processConstructor ref info explicit (idx+1) ps
@@ -227,7 +228,7 @@ and the list of `(constructor name, patterns)` for each constructor, where `patt
 (conjunctive) list of patterns to apply to each constructor argument.
 -/
 def processConstructors (ref : Syntax) (params : Nat) (altVarNames : Array AltVarNames := #[]) :
-    ListΣ Name → ListΣ RCasesPatt → MetaM (Array AltVarNames × ListΣ (Name × ListΠ RCasesPatt))
+    List/-Σ-/ Name → List/-Σ-/ RCasesPatt → MetaM (Array AltVarNames × List/-Σ-/ (Name × List/-Π-/ RCasesPatt))
   | [], _ => pure (altVarNames, [])
   | c :: cs, ps => do
     let info := (← getFunInfo (← mkConstWithLevelParams c)).paramInfo
@@ -354,7 +355,7 @@ partial def rcasesCore (g : MVarId) (fs : FVarSubst) (clears : Array FVarId) (e
       let rec
       /-- Runs `rcasesContinue` on the first pattern in `r` with a matching `ctorName`.
       The unprocessed patterns (subsequent to the matching pattern) are returned. -/
-      align : ListΠ (Name × ListΠ RCasesPatt) → TermElabM (ListΠ (Name × ListΠ RCasesPatt) × α)
+      align : List/-Π-/ (Name × List/-Π-/ RCasesPatt) → TermElabM (List/-Π-/ (Name × List/-Π-/ RCasesPatt) × α)
       | [] => pure ([], a)
       | (tgt, ps) :: as => do
         if tgt == ctorName then
@@ -372,7 +373,7 @@ earlier arguments. For example `⟨a | b, ⟨c, d⟩⟩` performs the `⟨c, d
 `a` branch and once on `b`.
 -/
 partial def rcasesContinue (g : MVarId) (fs : FVarSubst) (clears : Array FVarId) (a : α)
-  (pats : ListΠ (RCasesPatt × Expr)) (cont : MVarId → FVarSubst → Array FVarId → α → TermElabM α) :
+  (pats : List/-Π-/ (RCasesPatt × Expr)) (cont : MVarId → FVarSubst → Array FVarId → α → TermElabM α) :
   TermElabM α :=
   match pats with
   | []  => cont g fs clears a

src/Lean/Elab/Tactic/Simp.lean

@@ -5,7 +5,9 @@ Authors: Leonardo de Moura
 -/
 prelude
 import Lean.Meta.Tactic.Simp
+import Lean.Meta.Tactic.Simp.LoopProtection
 import Lean.Meta.Tactic.Replace
+import Lean.Meta.Hint
 import Lean.Elab.BuiltinNotation
 import Lean.Elab.Tactic.Basic
 import Lean.Elab.Tactic.ElabTerm
@@ -91,56 +93,6 @@ def elabSimpConfig (optConfig : Syntax) (kind : SimpKind) : TacticM Meta.Simp.Co
   | .simpAll => return (← elabSimpConfigCtxCore optConfig).toConfig
   | .dsimp   => return { (← elabDSimpConfigCore optConfig) with }
 
-private def addDeclToUnfoldOrTheorem (config : Meta.ConfigWithKey) (thms : SimpTheorems) (id : Origin) (e : Expr) (post : Bool) (inv : Bool) (kind : SimpKind) : MetaM SimpTheorems := do
-  if e.isConst then
-    let declName := e.constName!
-    let info ← getConstVal declName
-    if (← isProp info.type) then
-      thms.addConst declName (post := post) (inv := inv)
-    else
-      if inv then
-        throwError "invalid '←' modifier, '{declName}' is a declaration name to be unfolded"
-      if kind == .dsimp then
-        return thms.addDeclToUnfoldCore declName
-      else
-        thms.addDeclToUnfold declName
-  else if e.isFVar then
-    let fvarId := e.fvarId!
-    let decl ← fvarId.getDecl
-    if (← isProp decl.type) then
-      thms.add id #[] e (post := post) (inv := inv) (config := config)
-    else if !decl.isLet then
-      throwError "invalid argument, variable is not a proposition or let-declaration"
-    else if inv then
-      throwError "invalid '←' modifier, '{e}' is a let-declaration name to be unfolded"
-    else
-      return thms.addLetDeclToUnfold fvarId
-  else
-    thms.add id #[] e (post := post) (inv := inv) (config := config)
-
-private def addSimpTheorem (config : Meta.ConfigWithKey) (thms : SimpTheorems) (id : Origin) (stx : Syntax) (post : Bool) (inv : Bool) : TermElabM SimpTheorems := do
-  let thm? ← Term.withoutModifyingElabMetaStateWithInfo <| withRef stx do
-    let e ← Term.elabTerm stx none
-    Term.synthesizeSyntheticMVars (postpone := .no) (ignoreStuckTC := true)
-    let e ← instantiateMVars e
-    if e.hasSyntheticSorry then
-      return none
-    let e := e.eta
-    if e.hasMVar then
-      let r ← abstractMVars e
-      return some (r.paramNames, r.expr)
-    else
-      return some (#[], e)
-  if let some (levelParams, proof) := thm? then
-    thms.add id levelParams proof (post := post) (inv := inv) (config := config)
-  else
-    return thms
-
-structure ElabSimpArgsResult where
-  ctx      : Simp.Context
-  simprocs : Simp.SimprocsArray
-  starArg  : Bool := false
-
 inductive ResolveSimpIdResult where
   | none
   | expr (e : Expr)
@@ -154,104 +106,8 @@ inductive ResolveSimpIdResult where
   -/
   | ext  (ext₁? : Option SimpExtension) (ext₂? : Option Simp.SimprocExtension) (h : ext₁?.isSome || ext₂?.isSome)
 
-/--
-  Elaborate extra simp theorems provided to `simp`. `stx` is of the form `"[" simpTheorem,* "]"`
-  If `eraseLocal == true`, then we consider local declarations when resolving names for erased theorems (`- id`),
-  this option only makes sense for `simp_all` or `*` is used.
-  When `recover := true`, try to recover from errors as much as possible so that users keep seeing
-  the current goal.
--/
-def elabSimpArgs (stx : Syntax) (ctx : Simp.Context) (simprocs : Simp.SimprocsArray) (eraseLocal : Bool) (kind : SimpKind) : TacticM ElabSimpArgsResult := do
-  if stx.isNone then
-    return { ctx, simprocs }
-  else
-    /-
-    syntax simpPre := "↓"
-    syntax simpPost := "↑"
-    syntax simpLemma := (simpPre <|> simpPost)? "← "? term
-
-    syntax simpErase := "-" ident
-    -/
-    let go := withMainContext do
-      let zetaDeltaSet ← toZetaDeltaSet stx ctx
-      withTrackingZetaDeltaSet zetaDeltaSet do
-        let mut thmsArray := ctx.simpTheorems
-        let mut thms      := thmsArray[0]!
-        let mut simprocs  := simprocs
-        let mut starArg   := false
-        for arg in stx[1].getSepArgs do
-          try -- like withLogging, but compatible with do-notation
-            if arg.getKind == ``Lean.Parser.Tactic.simpErase then
-              let fvar? ← if eraseLocal || starArg then Term.isLocalIdent? arg[1] else pure none
-              if let some fvar := fvar? then
-                -- We use `eraseCore` because the simp theorem for the hypothesis was not added yet
-                thms := thms.eraseCore (.fvar fvar.fvarId!)
-              else
-                let id := arg[1]
-                if let .ok declName ← observing (realizeGlobalConstNoOverloadWithInfo id) then
-                  if (← Simp.isSimproc declName) then
-                    simprocs := simprocs.erase declName
-                  else if ctx.config.autoUnfold then
-                    thms := thms.eraseCore (.decl declName)
-                  else
-                    thms ← withRef id <| thms.erase (.decl declName)
-                else
-                  -- If `id` could not be resolved, we should check whether it is a builtin simproc.
-                  -- before returning error.
-                  let name := id.getId.eraseMacroScopes
-                  if (← Simp.isBuiltinSimproc name) then
-                    simprocs := simprocs.erase name
-                  else
-                    throwUnknownConstantAt id name
-            else if arg.getKind == ``Lean.Parser.Tactic.simpLemma then
-              let post :=
-                if arg[0].isNone then
-                  true
-                else
-                  arg[0][0].getKind == ``Parser.Tactic.simpPost
-              let inv  := !arg[1].isNone
-              let term := arg[2]
-              match (← resolveSimpIdTheorem? term) with
-              | .expr e  =>
-                let name ← mkFreshId
-                thms ← addDeclToUnfoldOrTheorem ctx.indexConfig thms (.stx name arg) e post inv kind
-              | .simproc declName =>
-                simprocs ← simprocs.add declName post
-              | .ext (some ext₁) (some ext₂) _ =>
-                thmsArray := thmsArray.push (← ext₁.getTheorems)
-                simprocs  := simprocs.push (← ext₂.getSimprocs)
-              | .ext (some ext₁) none _ =>
-                thmsArray := thmsArray.push (← ext₁.getTheorems)
-              | .ext none (some ext₂) _ =>
-                simprocs  := simprocs.push (← ext₂.getSimprocs)
-              | .none    =>
-                let name ← mkFreshId
-                thms ← addSimpTheorem ctx.indexConfig thms (.stx name arg) term post inv
-            else if arg.getKind == ``Lean.Parser.Tactic.simpStar then
-              starArg := true
-            else
-              throwUnsupportedSyntax
-          catch ex =>
-            if (← read).recover then
-              logException ex
-            else
-              throw ex
-        let ctx := ctx.setZetaDeltaSet zetaDeltaSet (← getZetaDeltaFVarIds)
-        return { ctx := ctx.setSimpTheorems (thmsArray.set! 0 thms), simprocs, starArg }
-    -- If recovery is disabled, then we want simp argument elaboration failures to be exceptions.
-    -- This affects `addSimpTheorem`.
-    if (← read).recover then
-      go
-    else
-      Term.withoutErrToSorry go
-where
-  isSimproc? (e : Expr) : MetaM (Option Name) := do
-    let .const declName _ := e | return none
-    unless (← Simp.isSimproc declName) do return none
-    return some declName
-
-  resolveSimpIdTheorem? (simpArgTerm : Term) : TacticM ResolveSimpIdResult := do
-    let resolveExt (n : Name) : TacticM ResolveSimpIdResult := do
+private def resolveSimpIdTheorem? (simpArgTerm : Term) : TermElabM ResolveSimpIdResult := do
+    let resolveExt (n : Name) : TermElabM ResolveSimpIdResult := do
       let ext₁? ← getSimpExtension? n
       let ext₂? ← Simp.getSimprocExtension? n
       if h : ext₁?.isSome || ext₂?.isSome then
@@ -279,7 +135,243 @@ where
         return .expr e
       else
         return .none
+where
+  isSimproc? (e : Expr) : MetaM (Option Name) := do
+    let .const declName _ := e | return none
+    unless (← Simp.isSimproc declName) do return none
+    return some declName
 
+
+/--
+The result of elaborating a single `simp` argument
+-/
+inductive ElabSimpArgResult where
+  | addEntries (entries : Array SimpEntry)
+  | addSimproc («simproc» : Name) (post : Bool)
+  | addLetToUnfold (fvarId : FVarId)
+  | ext  (ext₁? : Option SimpExtension) (ext₂? : Option Simp.SimprocExtension) (h : ext₁?.isSome || ext₂?.isSome)
+  | erase (toErase : Origin)
+  | eraseSimproc (toErase : Name)
+  | star
+  | none -- used for example when elaboration fails
+
+def ElabSimpArgResult.simpTheorems : ElabSimpArgResult → Array SimpTheorem
+  | addEntries entries => Id.run do
+    let mut thms := #[]
+    for entry in entries do
+      if let .thm thm := entry then
+        thms := thms.push thm
+    return thms
+  | _ => #[]
+
+private def elabDeclToUnfoldOrTheorem (config : Meta.ConfigWithKey) (id : Origin)
+    (e : Expr) (post : Bool) (inv : Bool) (kind : SimpKind) : MetaM ElabSimpArgResult := do
+  if e.isConst then
+    let declName := e.constName!
+    let info ← getConstVal declName
+    if (← isProp info.type) then
+      let thms ← mkSimpTheoremFromConst declName (post := post) (inv := inv)
+      return .addEntries <| thms.map (SimpEntry.thm ·)
+    else
+      if inv then
+        throwError "invalid '←' modifier, '{declName}' is a declaration name to be unfolded"
+      if kind == .dsimp then
+        return .addEntries #[.toUnfold declName]
+      else
+        .addEntries <$> mkSimpEntryOfDeclToUnfold declName
+  else if e.isFVar then
+    let fvarId := e.fvarId!
+    let decl ← fvarId.getDecl
+    if (← isProp decl.type) then
+      let thms ← mkSimpTheoremFromExpr id #[] e (post := post) (inv := inv) (config := config)
+      return .addEntries <| thms.map (SimpEntry.thm ·)
+    else if !decl.isLet then
+      throwError "invalid argument, variable is not a proposition or let-declaration"
+    else if inv then
+      throwError "invalid '←' modifier, '{e}' is a let-declaration name to be unfolded"
+    else
+      return .addLetToUnfold fvarId
+  else
+    let thms ← mkSimpTheoremFromExpr id #[] e (post := post) (inv := inv) (config := config)
+    return .addEntries <| thms.map (SimpEntry.thm ·)
+
+private def elabSimpTheorem (config : Meta.ConfigWithKey) (id : Origin) (stx : Syntax)
+    (post : Bool) (inv : Bool) : TermElabM ElabSimpArgResult := do
+  let thm? ← Term.withoutModifyingElabMetaStateWithInfo <| withRef stx do
+    let e ← Term.elabTerm stx .none
+    Term.synthesizeSyntheticMVars (postpone := .no) (ignoreStuckTC := true)
+    let e ← instantiateMVars e
+    if e.hasSyntheticSorry then
+      return .none
+    let e := e.eta
+    if e.hasMVar then
+      let r ← abstractMVars e
+      return some (r.paramNames, r.expr)
+    else
+      return some (#[], e)
+  if let some (levelParams, proof) := thm? then
+    let thms ← mkSimpTheoremFromExpr id levelParams proof (post := post) (inv := inv) (config := config)
+    return .addEntries <| thms.map (SimpEntry.thm ·)
+  else
+    return .none
+
+private def elabSimpArg (indexConfig : Meta.ConfigWithKey) (eraseLocal : Bool) (kind : SimpKind)
+    (arg : Syntax) : TacticM ElabSimpArgResult := withRef arg do
+  try
+    /-
+    syntax simpPre := "↓"
+    syntax simpPost := "↑"
+    syntax simpLemma := (simpPre <|> simpPost)? "← "? term
+
+    syntax simpErase := "-" ident
+    -/
+    if arg.getKind == ``Lean.Parser.Tactic.simpErase then
+      let fvar? ← if eraseLocal then Term.isLocalIdent? arg[1] else pure none
+      if let some fvar := fvar? then
+        -- We use `eraseCore` because the simp theorem for the hypothesis was not added yet
+        return .erase (.fvar fvar.fvarId!)
+      else
+        let id := arg[1]
+        if let .ok declName ← observing (realizeGlobalConstNoOverloadWithInfo id) then
+          if (← Simp.isSimproc declName) then
+            return .eraseSimproc declName
+          else
+            return .erase (.decl declName)
+        else
+          -- If `id` could not be resolved, we should check whether it is a builtin simproc.
+          -- before returning error.
+          let name := id.getId.eraseMacroScopes
+          if (← Simp.isBuiltinSimproc name) then
+            return .eraseSimproc name
+          else
+            throwUnknownConstantAt id name
+    else if arg.getKind == ``Lean.Parser.Tactic.simpLemma then
+      let post :=
+        if arg[0].isNone then
+          true
+        else
+          arg[0][0].getKind == ``Parser.Tactic.simpPost
+      let inv  := !arg[1].isNone
+      let term := arg[2]
+      match (← resolveSimpIdTheorem? term) with
+      | .expr e  =>
+        let name ← mkFreshId
+        elabDeclToUnfoldOrTheorem indexConfig (.stx name arg) e post inv kind
+      | .simproc declName =>
+        return .addSimproc declName post
+      | .ext ext₁? ext₂? h =>
+        return .ext ext₁? ext₂? h
+      | .none    =>
+        let name ← mkFreshId
+        elabSimpTheorem indexConfig (.stx name arg) term post inv
+    else if arg.getKind == ``Lean.Parser.Tactic.simpStar then
+      return .star
+    else
+      throwUnsupportedSyntax
+  catch ex =>
+    if (← read).recover then
+      logException ex
+      return .none
+    else
+      throw ex
+
+/--
+The result of elaborating a full array of simp arguments and applying them to the simp context.
+-/
+structure ElabSimpArgsResult where
+  ctx      : Simp.Context
+  simprocs : Simp.SimprocsArray
+  /-- The elaborated simp arguments with syntax -/
+  simpArgs : Array (Syntax × ElabSimpArgResult)
+
+/-- Implements the effect of the `*` attribute. -/
+private def applyStarArg (ctx : Simp.Context) : MetaM Simp.Context := do
+  let mut simpTheorems := ctx.simpTheorems
+  /-
+  When using `zetaDelta := false`, we do not expand let-declarations when using `[*]`.
+  Users must explicitly include it in the list.
+  -/
+  let hs ← getPropHyps
+  for h in hs do
+    unless simpTheorems.isErased (.fvar h) do
+      simpTheorems ← simpTheorems.addTheorem (.fvar h) (← h.getDecl).toExpr (config := ctx.indexConfig)
+  return ctx.setSimpTheorems simpTheorems
+
+/--
+  Elaborate extra simp theorems provided to `simp`. `stx` is of the form `"[" simpTheorem,* "]"`
+  If `eraseLocal == true`, then we consider local declarations when resolving names for erased theorems (`- id`),
+  this option only makes sense for `simp_all` or `*` is used.
+  When `recover := true`, try to recover from errors as much as possible so that users keep seeing
+  the current goal.
+-/
+def elabSimpArgs (stx : Syntax) (ctx : Simp.Context) (simprocs : Simp.SimprocsArray) (eraseLocal : Bool)
+    (kind : SimpKind) (ignoreStarArg := false) : TacticM ElabSimpArgsResult := do
+  if stx.isNone then
+    return { ctx, simprocs, simpArgs := #[] }
+  else
+    /-
+    syntax simpPre := "↓"
+    syntax simpPost := "↑"
+    syntax simpLemma := (simpPre <|> simpPost)? "← "? term
+
+    syntax simpErase := "-" ident
+    -/
+    let go := withMainContext do
+      let zetaDeltaSet ← toZetaDeltaSet stx ctx
+      withTrackingZetaDeltaSet zetaDeltaSet do
+        let mut starArg := false -- only after * we can erase local declarations
+        let mut args : Array (Syntax × ElabSimpArgResult) := #[]
+        for argStx in stx[1].getSepArgs do
+          let arg ← elabSimpArg ctx.indexConfig (eraseLocal || starArg) kind argStx
+          starArg := !ignoreStarArg && (starArg || arg matches .star)
+          args := args.push (argStx, arg)
+
+        let mut thmsArray := ctx.simpTheorems
+        let mut thms      := thmsArray[0]!
+        let mut simprocs  := simprocs
+        for (ref, arg) in args do
+          match arg with
+          | .addEntries entries =>
+            for entry in entries do
+              thms := thms.uneraseSimpEntry entry
+              thms := thms.addSimpEntry entry
+          | .addLetToUnfold fvarId =>
+            thms := thms.addLetDeclToUnfold fvarId
+          | .addSimproc declName post =>
+            simprocs ← simprocs.add declName post
+          | .erase origin =>
+            -- `thms.erase` checks if the erasure is effective.
+            -- We do not want this check for local hypotheses (they are added later based on `starArg`)
+            if origin matches .fvar _ then
+              thms := thms.eraseCore origin
+            -- Nor for decls to unfold when we do auto unfolding
+            else if ctx.config.autoUnfold then
+              thms := thms.eraseCore origin
+            else
+              thms ← withRef ref <| thms.erase origin
+          | .eraseSimproc name =>
+            simprocs := simprocs.erase name
+          | .ext simpExt? simprocExt? _ =>
+            if let some simpExt := simpExt? then
+              thmsArray := thmsArray.push (← simpExt.getTheorems)
+            if let some simprocExt := simprocExt? then
+              simprocs := simprocs.push (← simprocExt.getSimprocs)
+          | .star => pure ()
+          | .none => pure ()
+
+        let mut ctx := ctx.setZetaDeltaSet zetaDeltaSet (← getZetaDeltaFVarIds)
+        ctx := ctx.setSimpTheorems (thmsArray.set! 0 thms)
+        if !ignoreStarArg && starArg then
+          ctx ← applyStarArg ctx
+
+        return { ctx, simprocs, simpArgs := args}
+    -- If recovery is disabled, then we want simp argument elaboration failures to be exceptions.
+    -- This affects `addSimpTheorem`.
+    if (← read).recover then
+      go
+    else
+      Term.withoutErrToSorry go
+where
   /-- If `zetaDelta := false`, create a `FVarId` set with all local let declarations in the `simp` argument list. -/
   toZetaDeltaSet (stx : Syntax) (ctx : Simp.Context) : TacticM FVarIdSet := do
     if ctx.config.zetaDelta then return {}
@@ -319,6 +411,8 @@ structure MkSimpContextResult where
   ctx              : Simp.Context
   simprocs         : Simp.SimprocsArray
   dischargeWrapper : Simp.DischargeWrapper
+  /-- The elaborated simp arguments with syntax -/
+  simpArgs         : Array (Syntax × ElabSimpArgResult) := #[]
 
 /--
    Create the `Simp.Context` for the `simp`, `dsimp`, and `simp_all` tactics.
@@ -351,23 +445,33 @@ def mkSimpContext (stx : Syntax) (eraseLocal : Bool) (kind := SimpKind.simp)
      (config := (← elabSimpConfig stx[1] (kind := kind)))
      (simpTheorems := #[simpTheorems])
      congrTheorems
-  let r ← elabSimpArgs stx[4] (eraseLocal := eraseLocal) (kind := kind) (simprocs := #[simprocs]) ctx
-  if !r.starArg || ignoreStarArg then
-    return { r with dischargeWrapper }
-  else
-    let ctx := r.ctx
-    let simprocs := r.simprocs
-    let mut simpTheorems := ctx.simpTheorems
-    /-
-    When using `zetaDelta := false`, we do not expand let-declarations when using `[*]`.
-    Users must explicitly include it in the list.
-    -/
-    let hs ← getPropHyps
-    for h in hs do
-      unless simpTheorems.isErased (.fvar h) do
-        simpTheorems ← simpTheorems.addTheorem (.fvar h) (← h.getDecl).toExpr (config := ctx.indexConfig)
-    let ctx := ctx.setSimpTheorems simpTheorems
-    return { ctx, simprocs, dischargeWrapper }
+  let r ← elabSimpArgs stx[4] (eraseLocal := eraseLocal) (kind := kind) (simprocs := #[simprocs]) (ignoreStarArg := ignoreStarArg) ctx
+  return { r with dischargeWrapper }
+
+/--
+Runs the given action.
+If it throws a maxRecDepth exception (nested or not), run the loop checking.
+If it does not throw, run the loop checking only if explicitly enabled.
+-/
+@[inline] def withLoopChecking [Monad m] [MonadExcept Exception m] [MonadRuntimeException m] [MonadLiftT MetaM m]
+    (r : MkSimpContextResult) (k : m α) : m α := do
+  -- We use tryCatchRuntimeEx here, normal try-catch would swallow the trace messages
+  -- from diagnostics
+  let x ← tryCatchRuntimeEx do
+      k
+    fun e => do
+      if e.isMaxRecDepth || e.toMessageData.hasTag (· = `nested.runtime.maxRecDepth) then
+        go (force := true)
+      throw e
+  go (force := false)
+  pure x
+where
+  go force : m Unit := liftMetaM do
+    let { ctx, simprocs, dischargeWrapper := _, simpArgs } := r
+    for (ref, arg) in simpArgs do
+      for thm in arg.simpTheorems do
+        withRef ref do
+          Simp.checkLoops (force := force) ctx (methods := Simp.mkDefaultMethodsCore simprocs) thm
 
 register_builtin_option tactic.simp.trace : Bool := {
   defValue := false
@@ -436,6 +540,79 @@ def mkSimpOnly (stx : Syntax) (usedSimps : Simp.UsedSimps) : MetaM Syntax := do
 def traceSimpCall (stx : Syntax) (usedSimps : Simp.UsedSimps) : MetaM Unit := do
   logInfoAt stx[0] m!"Try this: {← mkSimpOnly stx usedSimps}"
 
+
+register_builtin_option linter.unusedSimpArgs : Bool := {
+  defValue := true,
+  descr := "enable the linter that warns when explicit `simp` arguments are unused.\n\
+    \n\
+    The linter suggests removing the unused arguments. This hint may not be correct in the case \
+    that `simp [← thm]` is given, when `thm` has the `@[simp]` attribute, and it is relevant that \
+    `thm` it disabled (which is a side-effect of specifying `← thm`). In that case, replace \
+    it with `simp [- thm]`.\n\
+    \n\
+    When one `simp` invocation is run multiple times (e.g. `all_goals simp [thm]`), it warns \
+    about simp arguments that are unused in all invocations. For this reason, the linter \
+    does not warn about uses of `simp` inside a macro, as there it is usually not possible to see \
+    all invocations."
+}
+
+structure UnusedSimpArgsInfo where
+  mask : Array Bool
+deriving TypeName
+
+def pushUnusedSimpArgsInfo [Monad m] [MonadInfoTree m] (simpStx : Syntax) (mask : Array Bool) : m Unit := do
+  pushInfoLeaf <| .ofCustomInfo {
+    stx := simpStx
+    value := .mk { mask := mask : UnusedSimpArgsInfo } }
+
+/--
+Checks the simp arguments for unused ones, and stores a bitmask of unused ones in the info tree,
+to be picked up by the linter.
+(This indirection is necessary because the same `simp` syntax may be executed multiple times,
+and different simp arguments may be used in each step.)
+-/
+def warnUnusedSimpArgs (simpArgs : Array (Syntax × ElabSimpArgResult)) (usedSimps : Simp.UsedSimps) : MetaM Unit := do
+  if simpArgs.isEmpty then return
+  let mut mask : Array Bool := #[]
+  for h : i in [:simpArgs.size] do
+    let (ref, arg) := simpArgs[i]
+    let used ←
+      match arg with
+      | .addEntries entries =>
+        entries.anyM fun
+          | .thm thm => return usedSimps.contains (← usedThmIdOfSimpTheorem thm)
+          | .toUnfold declName => return usedSimps.contains (.decl declName)
+          | .toUnfoldThms _declName thms => return thms.any (usedSimps.contains <| .decl ·)
+      | .addSimproc declName post =>
+        pure <| usedSimps.contains (.decl declName post)
+      | .addLetToUnfold fvarId =>
+        pure <| usedSimps.contains (.fvar fvarId)
+      | .erase _
+      | .eraseSimproc _
+      | .ext _ _ _
+      | .star
+      | .none
+      => pure true -- not supported yet
+    mask := mask.push used
+  pushUnusedSimpArgsInfo (← getRef) mask
+where
+  /--
+  For equational theorems, usedTheorems record the declaration name. So if the user
+  specified `foo.eq_1`, we get `foo` in `usedTheores`, but we still want to mark
+  `foo.eq_1` as used.
+  (cf. `recordSimpTheorem`)
+  This may lead to unused, explicitly given `foo.eq_1` to not be warned about. Ok for now,
+  eventually `recordSimpTheorem` could record the actual theorem, and the logic for
+  treating `foo.eq_1` as `foo` be moved to `SimpTrace.lean`
+  -/
+  usedThmIdOfSimpTheorem (thm : SimpTheorem) : MetaM Origin := do
+    let thmId := thm.origin
+    if let .decl declName post false := thmId then
+      if let some declName ← isEqnThm? declName then
+        return (Origin.decl declName post false)
+    return thmId
+
+
 /--
 `simpLocation ctx discharge? varIdToLemmaId loc`
 runs the simplifier at locations specified by `loc`,
@@ -477,21 +654,30 @@ def withSimpDiagnostics (x : TacticM Simp.Diagnostics) : TacticM Unit := do
   (location)?
 -/
 @[builtin_tactic Lean.Parser.Tactic.simp] def evalSimp : Tactic := fun stx => withMainContext do withSimpDiagnostics do
-  let { ctx, simprocs, dischargeWrapper } ← mkSimpContext stx (eraseLocal := false)
+  let r@{ ctx, simprocs, dischargeWrapper, simpArgs } ← mkSimpContext stx (eraseLocal := false)
   let stats ← dischargeWrapper.with fun discharge? =>
-    simpLocation ctx simprocs discharge? (expandOptLocation stx[5])
+    withLoopChecking r do
+      simpLocation ctx simprocs discharge? (expandOptLocation stx[5])
   if tactic.simp.trace.get (← getOptions) then
     traceSimpCall stx stats.usedTheorems
+  else if linter.unusedSimpArgs.get (← getOptions) then
+    withRef stx do
+      warnUnusedSimpArgs simpArgs stats.usedTheorems
   return stats.diag
 
 @[builtin_tactic Lean.Parser.Tactic.simpAll] def evalSimpAll : Tactic := fun stx => withMainContext do withSimpDiagnostics do
-  let { ctx, simprocs, .. } ← mkSimpContext stx (eraseLocal := true) (kind := .simpAll) (ignoreStarArg := true)
-  let (result?, stats) ← simpAll (← getMainGoal) ctx (simprocs := simprocs)
+  let r@{ ctx, simprocs, dischargeWrapper := _, simpArgs } ← mkSimpContext stx (eraseLocal := true) (kind := .simpAll) (ignoreStarArg := true)
+  let (result?, stats) ←
+    withLoopChecking r do
+      simpAll (← getMainGoal) ctx (simprocs := simprocs)
   match result? with
   | none => replaceMainGoal []
   | some mvarId => replaceMainGoal [mvarId]
   if tactic.simp.trace.get (← getOptions) then
     traceSimpCall stx stats.usedTheorems
+  else if linter.unusedSimpArgs.get (← getOptions) then
+    withRef stx do
+      warnUnusedSimpArgs simpArgs stats.usedTheorems
   return stats.diag
 
 def dsimpLocation (ctx : Simp.Context) (simprocs : Simp.SimprocsArray) (loc : Location) : TacticM Unit := do

src/Lean/Elab/Tactic/SimpTrace.lean

@@ -30,7 +30,7 @@ def mkSimpCallStx (stx : Syntax) (usedSimps : UsedSimps) : MetaM (TSyntax `tacti
       `(tactic| simp!%$tk $cfg:optConfig $(discharger)? $[only%$o]? $[[$args,*]]? $(loc)?)
     else
       `(tactic| simp%$tk $cfg:optConfig $[$discharger]? $[only%$o]? $[[$args,*]]? $(loc)?)
-    let { ctx, simprocs, dischargeWrapper } ← mkSimpContext stx (eraseLocal := false)
+    let { ctx, simprocs, dischargeWrapper, ..} ← mkSimpContext stx (eraseLocal := false)
     let ctx := if bang.isSome then ctx.setAutoUnfold else ctx
     let stats ← dischargeWrapper.with fun discharge? =>
       simpLocation ctx (simprocs := simprocs) discharge? <|

src/Lean/Elab/Tactic/Simpa.lean

@@ -34,7 +34,7 @@ deriving instance Repr for UseImplicitLambdaResult
   | `(tactic| simpa%$tk $[?%$squeeze]? $[!%$unfold]? $cfg:optConfig $(disch)? $[only%$only]?
         $[[$args,*]]? $[using $usingArg]?) => Elab.Tactic.focus do withSimpDiagnostics do
     let stx ← `(tactic| simp $cfg:optConfig $(disch)? $[only%$only]? $[[$args,*]]?)
-    let { ctx, simprocs, dischargeWrapper } ←
+    let { ctx, simprocs, dischargeWrapper, .. } ←
       withMainContext <| mkSimpContext stx (eraseLocal := false)
     let ctx := if unfold.isSome then ctx.setAutoUnfold else ctx
     -- TODO: have `simpa` fail if it doesn't use `simp`.

src/Lean/Environment.lean

@@ -1876,18 +1876,6 @@ abbrev ImportStateM := StateRefT ImportState IO
 @[inline] nonrec def ImportStateM.run (x : ImportStateM α) (s : ImportState := {}) : IO (α × ImportState) :=
   x.run s
 
-def ModuleArtifacts.oleanParts (arts : ModuleArtifacts) : Array System.FilePath := Id.run do
-  let mut fnames := #[]
-  -- Opportunistically load all available parts.
-  -- Producer (e.g., Lake) should limit parts to the proper import level.
-  if let some mFile := arts.olean? then
-    fnames := fnames.push mFile
-    if let some sFile := arts.oleanServer? then
-      fnames := fnames.push sFile
-      if let some pFile := arts.oleanPrivate? then
-        fnames := fnames.push pFile
-  return fnames
-
 private def findOLeanParts (mod : Name) : IO (Array System.FilePath) := do
   let mFile ← findOLean mod
   unless (← mFile.pathExists) do
@@ -1904,7 +1892,7 @@ private def findOLeanParts (mod : Name) : IO (Array System.FilePath) := do
   return fnames
 
 partial def importModulesCore
-    (imports : Array Import) (isModule := false) (arts : NameMap ModuleArtifacts := {}) :
+    (imports : Array Import) (isModule := false) (arts : NameMap ImportArtifacts := {}) :
     ImportStateM Unit := do
   go imports (importAll := true) (isExported := isModule) (isMeta := false)
   if isModule then
@@ -1977,10 +1965,9 @@ where go (imports : Array Import) (importAll isExported isMeta : Bool) := do
       continue
     let fnames ←
       if let some arts := arts.find? i.module then
-        let fnames := arts.oleanParts
-        if fnames.isEmpty then
-          findOLeanParts i.module
-        else pure fnames
+        -- Opportunistically load all available parts.
+        -- Producer (e.g., Lake) should limit parts to the proper import level.
+        pure arts.oleanParts
       else
         findOLeanParts i.module
     let parts ← readModuleDataParts fnames
@@ -2146,7 +2133,7 @@ as if no `module` annotations were present in the imports.
 -/
 def importModules (imports : Array Import) (opts : Options) (trustLevel : UInt32 := 0)
     (plugins : Array System.FilePath := #[]) (leakEnv := false) (loadExts := false)
-    (level := OLeanLevel.private) (arts : NameMap ModuleArtifacts := {})
+    (level := OLeanLevel.private) (arts : NameMap ImportArtifacts := {})
     : IO Environment := profileitIO "import" opts do
   for imp in imports do
     if imp.module matches .anonymous then

src/Lean/ErrorExplanations.lean

@@ -0,0 +1,11 @@
+/-
+Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Joseph Rotella
+-/
+prelude
+import Lean.ErrorExplanations.CtorResultingTypeMismatch
+import Lean.ErrorExplanations.DependsOnNoncomputable
+import Lean.ErrorExplanations.InductiveParamMismatch
+import Lean.ErrorExplanations.InductiveParamMissing
+import Lean.ErrorExplanations.RedundantMatchAlt

src/Lean/ErrorExplanations/CtorResultingTypeMismatch.lean

@@ -0,0 +1,67 @@
+/-
+Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Joseph Rotella
+-/
+prelude
+import Lean.ErrorExplanation
+
+/--
+In an inductive declaration, the resulting type of each constructor must match the type being
+declared; if it does not, this error is raised. That is, every constructor of an inductive type must
+return a value of that type. See the [Inductive Types](lean-manual://section/inductive-types) manual
+section for additional details. Note that it is possible to omit the resulting type for a
+constructor if the inductive type being defined has no indices.
+
+# Examples
+
+## Typo in resulting type
+```lean broken
+inductive Tree (α : Type) where
+  | leaf : Tree α
+  | node : α → Tree α → Treee α
+```
+```output
+Unexpected resulting type for constructor 'Tree.node': Expected an application of
+  Tree
+but found
+  ?m.22
+```
+```lean fixed
+inductive Tree (α : Type) where
+  | leaf : Tree α
+  | node : α → Tree α → Tree α
+```
+
+## Missing resulting type after constructor parameter
+
+```lean broken
+inductive Credential where
+  | pin      : Nat
+  | password : String
+```
+```output
+Unexpected resulting type for constructor 'Credential.pin': Expected
+  Credential
+but found
+  Nat
+```
+```lean fixed (title := "Fixed (resulting type)")
+inductive Credential where
+  | pin      : Nat → Credential
+  | password : String → Credential
+```
+```lean fixed (title := "Fixed (named parameter)")
+inductive Credential where
+  | pin (num : Nat)
+  | password (str : String)
+```
+
+If the type of a constructor is annotated, the full type—including the resulting type—must be
+provided. Alternatively, constructor parameters can be written using named binders; this allows the
+omission of the constructor's resulting type because it contains no indices.
+-/
+register_error_explanation lean.ctorResultingTypeMismatch {
+  summary := "Resulting type of constructor was not the inductive type being declared."
+  sinceVersion := "4.22.0"
+}

src/Lean/ErrorExplanations/DependsOnNoncomputable.lean

@@ -0,0 +1,117 @@
+/-
+Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Joseph Rotella
+-/
+prelude
+import Lean.ErrorExplanation
+
+/--
+This error indicates that the specified definition depends on one or more definitions that do not
+contain executable code and is therefore required to be marked as `noncomputable`. Such definitions
+can be type-checked but do not contain code that can be executed by Lean.
+
+If you intended for the definition named in the error message to be noncomputable, marking it as
+`noncomputable` will resolve this error. If you did not, inspect the noncomputable definitions on
+which it depends: they may be noncomputable because they failed to compile, are `axiom`s, or were
+themselves marked as `noncomputable`. Making all of your definition's noncomputable dependencies
+computable will also resolve this error. See the manual section on
+[Modifiers](lean-manual://section/declaration-modifiers) for more information about noncomputable
+definitions.
+
+# Examples
+
+## Necessarily noncomputable function not appropriately marked
+
+```lean broken
+axiom transform : Nat → Nat
+
+def transformIfZero : Nat → Nat
+  | 0 => transform 0
+  | n => n
+```
+```output
+axiom 'transform' not supported by code generator; consider marking definition as 'noncomputable'
+```
+```lean fixed
+axiom transform : Nat → Nat
+
+noncomputable def transformIfZero : Nat → Nat
+  | 0 => transform 0
+  | n => n
+```
+In this example, `transformIfZero` depends on the axiom `transform`. Because `transform` is an
+axiom, it does not contain any executable code; although the value `transform 0` has type `Nat`,
+there is no way to compute its value. Thus, `transformIfZero` must be marked `noncomputable` because
+its execution would depend on this axiom.
+
+## Noncomputable dependency can be made computable
+
+```lean broken
+noncomputable def getOrDefault [Nonempty α] : Option α → α
+  | some x => x
+  | none => Classical.ofNonempty
+
+def endsOrDefault (ns : List Nat) : Nat × Nat :=
+  let head := getOrDefault ns.head?
+  let tail := getOrDefault ns.getLast?
+  (head, tail)
+```
+```output
+failed to compile definition, consider marking it as 'noncomputable' because it depends on 'getOrDefault', which is 'noncomputable'
+```
+```lean fixed (title := "Fixed (computable)")
+def getOrDefault [Inhabited α] : Option α → α
+  | some x => x
+  | none => default
+
+def endsOrDefault (ns : List Nat) : Nat × Nat :=
+  let head := getOrDefault ns.head?
+  let tail := getOrDefault ns.getLast?
+  (head, tail)
+```
+The original definition of `getOrDefault` is noncomputable due to its use of `Classical.choice`.
+Unlike in the preceding example, however, it is possible to implement a similar but computable
+version of `getOrDefault` (using the `Inhabited` type class), allowing `endsOrDefault` to be
+computable. (The differences between `Inhabited` and `Nonempty` are described in the documentation
+of inhabited types in the manual section on [Basic Classes](lean-manual://section/basic-classes).)
+
+## Noncomputable instance in namespace
+
+```lean broken
+open Classical in
+/--
+Returns `y` if it is in the image of `f`,
+or an element of the image of `f` otherwise.
+-/
+def fromImage (f : Nat → Nat) (y : Nat) :=
+  if ∃ x, f x = y then
+    y
+  else
+    f 0
+```
+```output
+failed to compile definition, consider marking it as 'noncomputable' because it depends on 'Classical.propDecidable', which is 'noncomputable'
+```
+```lean fixed
+open Classical in
+/--
+Returns `y` if it is in the image of `f`,
+or an element of the image of `f` otherwise.
+-/
+noncomputable def fromImage (f : Nat → Nat) (y : Nat) :=
+  if ∃ x, f x = y then
+    y
+  else
+    f 0
+```
+The `Classical` namespace contains `Decidable` instances that are not computable. These are a common
+source of noncomputable dependencies that do not explicitly appear in the source code of a
+definition. In the above example, for instance, a `Decidable` instance for the proposition
+`∃ x, f x = y` is synthesized using a `Classical` decidability instance; therefore, `fromImage` must
+be marked `noncomputable`.
+-/
+register_error_explanation lean.dependsOnNoncomputable {
+  summary := "Declaration depends on noncomputable definitions but is not marked as noncomputable"
+  sinceVersion := "4.22.0"
+}

src/Lean/ErrorExplanations/InductiveParamMismatch.lean

@@ -0,0 +1,57 @@
+/-
+Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Joseph Rotella
+-/
+prelude
+import Lean.ErrorExplanation
+
+/--
+This error occurs when a parameter of an inductive type is not uniform in an inductive
+declaration. The parameters of an inductive type (i.e., those that appear before the colon following
+the `inductive` keyword) must be identical in all occurrences of the type being defined in its
+constructors' types. If a parameter of an inductive type must vary between constructors, make the
+parameter an index by moving it to the right of the colon. See the manual section on
+[Inductive Types](lean-manual://section/inductive-types) for additional details.
+
+Note that auto-implicit inlay hints always appear left of the colon in an inductive declaration
+(i.e., as parameters), even when they are actually indices. This means that double-clicking on an
+inlay hint to insert such parameters may result in this error. If it does, change the inserted
+parameters to indices.
+
+# Examples
+
+## Vector length index as a parameter
+
+```lean broken
+inductive Vec (α : Type) (n : Nat) : Type where
+  | nil  : Vec α 0
+  | cons : α → Vec α n → Vec α (n + 1)
+```
+```output broken
+Mismatched inductive type parameter in
+  Vec α 0
+The provided argument
+  0
+is not definitionally equal to the expected parameter
+  n
+
+Note: The value of parameter 'n' must be fixed throughout the inductive declaration. Consider making this parameter an index if it must vary.
+```
+```lean fixed
+inductive Vec (α : Type) : Nat → Type where
+  | nil  : Vec α 0
+  | cons : α → Vec α n → Vec α (n + 1)
+```
+
+The length argument `n` of the `Vec` type constructor is declared as a parameter, but other values
+for this argument appear in the `nil` and `cons` constructors (namely, `0` and `n + 1`). An error
+therefore appears at the first occurrence of such an argument. To correct this, `n` cannot be a
+parameter of the inductive declaration and must instead be an index, as in the corrected example. On
+the other hand, `α` remains unchanged throughout all occurrences of `Vec` in the declaration and so
+is a valid parameter.
+-/
+register_error_explanation lean.inductiveParamMismatch {
+  summary := "Invalid parameter in an occurrence of an inductive type in one of its constructors."
+  sinceVersion := "4.22.0"
+}