fix: E-matching patterns containing ground universe polymorphic patterns in grind

This PR ensures `grind` can E-match patterns containing universe
polymorphic ground sub-patterns. For example, given
```
set_option pp.universes true in
attribute [grind?] Id.run_pure
```
the pattern
```
Id.run_pure.{u_1}: [@Id.run.{u_1} #1 (@pure.{u_1, u_1} `[Id.{u_1}] `[Applicative.toPure.{u_1, u_1}] _ #0)]
```
contains two nested universe polymorphic ground patterns
- `Id.{u_1}`
- `Applicative.toPure.{u_1, u_1}`

This kind of pattern is not common, but it occurs in core.

.github/workflows/build-template.yml

@@ -205,7 +205,7 @@ jobs:
         id: test
         run: |
           ulimit -c unlimited  # coredumps
-          time ctest --preset ${{ matrix.CMAKE_PRESET || 'release' }} --test-dir build/$TARGET_STAGE -j$NPROC --output-junit test-results.xml ${{ matrix.CTARGET_OPTIONS }}
+          time ctest --preset ${{ matrix.CMAKE_PRESET || 'release' }} --test-dir build/$TARGET_STAGE -j$NPROC --output-junit test-results.xml
         if: (matrix.wasm || !matrix.cross) && (inputs.check-level >= 1 || matrix.test)
       - name: Test Summary
         uses: test-summary/action@v2
@@ -235,9 +235,13 @@ jobs:
         if: matrix.test-speedcenter
       - name: Check rebootstrap
         run: |
+          set -e
           # clean rebuild in case of Makefile changes/Lake does not detect uncommited stage 0
           # changes yet
-          make -C build update-stage0 && make -C build/stage1 clean-stdlib && make -C build -j$NPROC
+          make -C build update-stage0
+          make -C build/stage1 clean-stdlib
+          time make -C build -j$NPROC
+          time ctest --preset ${{ matrix.CMAKE_PRESET || 'release' }} --test-dir build/stage1 -j$NPROC
         if: matrix.check-rebootstrap
       - name: CCache stats
         if: always()

script/AnalyzeGrindAnnotations.lean

@@ -0,0 +1,87 @@
+/-
+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: Leonardo de Moura
+-/
+import Lean
+
+namespace Lean.Meta.Grind.Analyzer
+/-!
+A simple E-matching annotation analyzer.
+For each theorem annotated as an E-matching candidate, it creates an artificial goal, executes `grind` and shows the
+number of instances created.
+For a theorem of the form `params -> type`, the artificial goal is of the form `params -> type -> False`.
+-/
+
+/--
+`grind` configuration for the analyzer. We disable case-splits and lookahead,
+increase the number of generations, and limit the number of instances generated.
+-/
+def config : Grind.Config := {
+  splits       := 0
+  lookahead    := false
+  mbtc         := false
+  ematch       := 20
+  instances    := 100
+  gen          := 10
+}
+
+structure Config where
+  /-- Minimum number of instantiations to trigger summary report -/
+  min : Nat := 10
+  /-- Minimum number of instantiations to trigger detailed report -/
+  detailed : Nat := 50
+
+def mkParams : MetaM Params := do
+  let params ← Grind.mkParams config
+  let ematch ← getEMatchTheorems
+  let casesTypes ← Grind.getCasesTypes
+  return { params with ematch, casesTypes }
+
+/-- Returns the total number of generated instances.  -/
+private def sum (cs : PHashMap Origin Nat) : Nat := Id.run do
+  let mut r := 0
+  for (_, c) in cs do
+    r := r + c
+  return r
+
+private def thmsToMessageData (thms : PHashMap Origin Nat) : MetaM MessageData := do
+  let data := thms.toArray.filterMap fun (origin, c) =>
+    match origin with
+    | .decl declName => some (declName, c)
+    | _ => none
+  let data := data.qsort fun (d₁, c₁) (d₂, c₂) => if c₁ == c₂ then Name.lt d₁ d₂ else c₁ > c₂
+  let data ← data.mapM fun (declName, counter) =>
+    return .trace { cls := `thm } m!"{.ofConst (← mkConstWithLevelParams declName)} ↦ {counter}" #[]
+  return .trace { cls := `thm } "instances" data
+
+/--
+Analyzes theorem `declName`. That is, creates the artificial goal based on `declName` type,
+and invokes `grind` on it.
+-/
+def analyzeEMatchTheorem (declName : Name) (c : Config) : MetaM Unit := do
+  let info ← getConstInfo declName
+  let mvarId ← forallTelescope info.type fun _ type => do
+    withLocalDeclD `h type fun _ => do
+      return (← mkFreshExprMVar (mkConst ``False)).mvarId!
+  let result ← Grind.main mvarId (← mkParams) (pure ())
+  let thms := result.counters.thm
+  let s := sum thms
+  if s > c.min then
+    IO.println s!"{declName} : {s}"
+  if s > c.detailed then
+    logInfo m!"{declName}\n{← thmsToMessageData thms}"
+
+/-- Analyzes all theorems in the standard library marked as E-matching theorems. -/
+def analyzeEMatchTheorems (c : Config := {}) : MetaM Unit := do
+  let origins := (← getEMatchTheorems).getOrigins
+  for o in origins do
+    let .decl declName := o | pure ()
+    analyzeEMatchTheorem declName c
+
+set_option maxHeartbeats 5000000
+run_meta analyzeEMatchTheorems
+
+-- We can analyze specific theorems using commands such as
+set_option trace.grind.ematch.instance true in
+run_meta analyzeEMatchTheorem ``List.filterMap_some {}

src/Init/Data.lean

@@ -49,5 +49,6 @@ public import Init.Data.Vector
 public import Init.Data.Iterators
 public import Init.Data.Range.Polymorphic
 public import Init.Data.Slice
+public import Init.Data.Order
 
 public section

src/Init/Data/Array/Lex/Lemmas.lean

@@ -12,9 +12,12 @@ public import Init.Data.Array.Lemmas
 public import Init.Data.List.Lex
 import Init.Data.Range.Polymorphic.Lemmas
 import Init.Data.Range.Polymorphic.NatLemmas
+import Init.Data.Order.Lemmas
 
 public section
 
+open Std
+
 set_option linter.listVariables true -- Enforce naming conventions for `List`/`Array`/`Vector` variables.
 set_option linter.indexVariables true -- Enforce naming conventions for index variables.
 
@@ -28,8 +31,8 @@ namespace Array
 @[simp] theorem lt_toList [LT α] {xs ys : Array α} : xs.toList < ys.toList ↔ xs < ys := Iff.rfl
 @[simp] theorem le_toList [LT α] {xs ys : Array α} : xs.toList ≤ ys.toList ↔ xs ≤ ys := Iff.rfl
 
-grind_pattern _root_.List.lt_toArray =>  l₁.toArray < l₂.toArray
-grind_pattern _root_.List.le_toArray =>  l₁.toArray ≤ l₂.toArray
+grind_pattern _root_.List.lt_toArray => l₁.toArray < l₂.toArray
+grind_pattern _root_.List.le_toArray => l₁.toArray ≤ l₂.toArray
 grind_pattern lt_toList => xs.toList < ys.toList
 grind_pattern le_toList => xs.toList ≤ ys.toList
 
@@ -100,6 +103,14 @@ theorem singleton_lex_singleton [BEq α] {lt : α → α → Bool} : #[a].lex #[
     xs.toList.lex ys.toList lt = xs.lex ys lt := by
   cases xs <;> cases ys <;> simp
 
+instance [LT α] [LE α] [LawfulOrderLT α] [IsLinearOrder α] : IsLinearOrder (Array α) := by
+  apply IsLinearOrder.of_le
+  · constructor
+    intro _ _ hab hba
+    simpa using Std.le_antisymm (α := List α) hab hba
+  · constructor; exact Std.le_trans (α := List α)
+  · constructor; exact fun _ _ => Std.le_total (α := List α)
+
 protected theorem lt_irrefl [LT α] [Std.Irrefl (· < · : α → α → Prop)] (xs : Array α) : ¬ xs < xs :=
   List.lt_irrefl xs.toList
 
@@ -131,27 +142,35 @@ instance [LT α] [Trans (· < · : α → α → Prop) (· < ·) (· < ·)] :
     Trans (· < · : Array α → Array α → Prop) (· < ·) (· < ·) where
   trans h₁ h₂ := Array.lt_trans h₁ h₂
 
-protected theorem lt_of_le_of_lt [LT α]
-    [i₀ : Std.Irrefl (· < · : α → α → Prop)]
+protected theorem lt_of_le_of_lt [LE α] [LT α] [LawfulOrderLT α] [IsLinearOrder α]
+    {xs ys zs : Array α} (h₁ : xs ≤ ys) (h₂ : ys < zs) : xs < zs :=
+  Std.lt_of_le_of_lt (α := List α) h₁ h₂
+
+@[deprecated Array.lt_of_le_of_lt (since := "2025-08-01")]
+protected theorem lt_of_le_of_lt' [LT α]
     [i₁ : Std.Asymm (· < · : α → α → Prop)]
     [i₂ : Std.Antisymm (¬ · < · : α → α → Prop)]
     [i₃ : Trans (¬ · < · : α → α → Prop) (¬ · < ·) (¬ · < ·)]
     {xs ys zs : Array α} (h₁ : xs ≤ ys) (h₂ : ys < zs) : xs < zs :=
-  List.lt_of_le_of_lt h₁ h₂
+  letI := LE.ofLT α
+  haveI : IsLinearOrder α := IsLinearOrder.of_lt
+  Array.lt_of_le_of_lt h₁ h₂
 
-protected theorem le_trans [LT α]
-    [Std.Irrefl (· < · : α → α → Prop)]
-    [Std.Asymm (· < · : α → α → Prop)]
-    [Std.Antisymm (¬ · < · : α → α → Prop)]
-    [Trans (¬ · < · : α → α → Prop) (¬ · < ·) (¬ · < ·)]
+protected theorem le_trans [LE α] [LT α] [LawfulOrderLT α] [IsLinearOrder α]
     {xs ys zs : Array α} (h₁ : xs ≤ ys) (h₂ : ys ≤ zs) : xs ≤ zs :=
   fun h₃ => h₁ (Array.lt_of_le_of_lt h₂ h₃)
 
-instance [LT α]
-    [Std.Irrefl (· < · : α → α → Prop)]
-    [Std.Asymm (· < · : α → α → Prop)]
-    [Std.Antisymm (¬ · < · : α → α → Prop)]
-    [Trans (¬ · < · : α → α → Prop) (¬ · < ·) (¬ · < ·)] :
+@[deprecated Array.le_trans (since := "2025-08-01")]
+protected theorem le_trans' [LT α]
+    [i₁ : Std.Asymm (· < · : α → α → Prop)]
+    [i₂ : Std.Antisymm (¬ · < · : α → α → Prop)]
+    [i₃ : Trans (¬ · < · : α → α → Prop) (¬ · < ·) (¬ · < ·)]
+    {xs ys zs : Array α} (h₁ : xs ≤ ys) (h₂ : ys ≤ zs) : xs ≤ zs :=
+  letI := LE.ofLT α
+  haveI : IsLinearOrder α := IsLinearOrder.of_lt
+  Array.le_trans h₁ h₂
+
+instance [LE α] [LT α] [LawfulOrderLT α] [IsLinearOrder α] :
     Trans (· ≤ · : Array α → Array α → Prop) (· ≤ ·) (· ≤ ·) where
   trans h₁ h₂ := Array.le_trans h₁ h₂
 
@@ -165,7 +184,7 @@ instance [LT α]
   asymm _ _ := Array.lt_asymm
 
 protected theorem le_total [LT α]
-    [i : Std.Total (¬ · < · : α → α → Prop)] (xs ys : Array α) : xs ≤ ys ∨ ys ≤ xs :=
+    [i : Std.Asymm (· < · : α → α → Prop)] (xs ys : Array α) : xs ≤ ys ∨ ys ≤ xs :=
   List.le_total xs.toList ys.toList
 
 @[simp] protected theorem not_lt [LT α]
@@ -175,19 +194,22 @@ protected theorem le_total [LT α]
     {xs ys : Array α} : ¬ ys ≤ xs ↔ xs < ys := Classical.not_not
 
 protected theorem le_of_lt [LT α]
-    [i : Std.Total (¬ · < · : α → α → Prop)]
+    [i : Std.Asymm (· < · : α → α → Prop)]
     {xs ys : Array α} (h : xs < ys) : xs ≤ ys :=
   List.le_of_lt h
 
 protected theorem le_iff_lt_or_eq [LT α]
     [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)]
-    [Std.Total (¬ · < · : α → α → Prop)]
+    [Std.Asymm (· < · : α → α → Prop)]
     {xs ys : Array α} : xs ≤ ys ↔ xs < ys ∨ xs = ys := by
   simpa using List.le_iff_lt_or_eq (l₁ := xs.toList) (l₂ := ys.toList)
 
-instance [LT α]
-    [Std.Total (¬ · < · : α → α → Prop)] :
+protected theorem le_antisymm [LT α] [LE α] [IsLinearOrder α] [LawfulOrderLT α]
+    {xs ys : Array α} : xs ≤ ys → ys ≤ xs → xs = ys := by
+  simpa using List.le_antisymm (as := xs.toList) (bs := ys.toList)
+
+instance [LT α] [Std.Asymm (· < · : α → α → Prop)] :
     Std.Total (· ≤ · : Array α → Array α → Prop) where
   total := Array.le_total
 
@@ -266,7 +288,6 @@ protected theorem lt_iff_exists [LT α] {xs ys : Array α} :
   simp [List.lt_iff_exists]
 
 protected theorem le_iff_exists [LT α]
-    [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Asymm (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)] {xs ys : Array α} :
     xs ≤ ys ↔
@@ -286,7 +307,6 @@ theorem append_left_lt [LT α] {xs ys zs : Array α} (h : ys < zs) :
   simpa using List.append_left_lt h
 
 theorem append_left_le [LT α]
-    [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Asymm (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)]
     {xs ys zs : Array α} (h : ys ≤ zs) :
@@ -310,10 +330,8 @@ protected theorem map_lt [LT α] [LT β]
   simpa using List.map_lt w h
 
 protected theorem map_le [LT α] [LT β]
-    [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Asymm (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)]
-    [Std.Irrefl (· < · : β → β → Prop)]
     [Std.Asymm (· < · : β → β → Prop)]
     [Std.Antisymm (¬ · < · : β → β → Prop)]
     {xs ys : Array α} {f : α → β} (w : ∀ x y, x < y → f x < f y) (h : xs ≤ ys) :

src/Init/Data/BitVec/Lemmas.lean

@@ -19,9 +19,12 @@ public import Init.Data.Int.LemmasAux
 public import Init.Data.Int.Pow
 public import Init.Data.Int.LemmasAux
 public import Init.Data.BitVec.Bootstrap
+public import Init.Data.Order.Factories
 
 public section
 
+open Std
+
 set_option linter.missingDocs true
 
 namespace BitVec
@@ -4015,6 +4018,16 @@ protected theorem ne_of_lt {x y : BitVec n} : x < y → x ≠ y := by
   simp only [lt_def, ne_eq, toNat_eq]
   apply Nat.ne_of_lt
 
+instance instIsLinearOrder : IsLinearOrder (BitVec n) := by
+  apply IsLinearOrder.of_le
+  case le_antisymm => constructor; apply BitVec.le_antisymm
+  case le_trans => constructor; apply BitVec.le_trans
+  case le_total => constructor; apply BitVec.le_total
+
+instance instLawfulOrderLT : LawfulOrderLT (BitVec n) := by
+  apply LawfulOrderLT.of_le
+  simpa using fun _ _ => BitVec.lt_asymm
+
 protected theorem umod_lt (x : BitVec n) {y : BitVec n} : 0 < y → x % y < y := by
   simp only [ofNat_eq_ofNat, lt_def, toNat_ofNat, Nat.zero_mod]
   apply Nat.mod_lt

src/Init/Data/Char.lean

@@ -8,5 +8,6 @@ module
 prelude
 public import Init.Data.Char.Basic
 public import Init.Data.Char.Lemmas
+public import Init.Data.Char.Order
 
 public section

src/Init/Data/Char/Lemmas.lean

@@ -61,6 +61,7 @@ instance leTotal : Std.Total (· ≤ · : Char → Char → Prop) where
   total := Char.le_total
 
 -- This instance is useful while setting up instances for `String`.
+@[deprecated ltAsymm (since := "2025-08-01")]
 def notLTTotal : Std.Total (¬ · < · : Char → Char → Prop) where
   total := fun x y => by simpa using Char.le_total y x
 

src/Init/Data/Char/Order.lean

@@ -0,0 +1,27 @@
+/-
+Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Paul Reichert
+-/
+module
+
+prelude
+public import Init.Data.Char.Basic
+import Init.Data.Char.Lemmas
+public import Init.Data.Order.Factories
+
+open Std
+
+namespace Char
+
+public instance instIsLinearOrder : IsLinearOrder Char := by
+  apply IsLinearOrder.of_le
+  case le_antisymm => constructor; apply Char.le_antisymm
+  case le_trans => constructor; apply Char.le_trans
+  case le_total => constructor; apply Char.le_total
+
+public instance : LawfulOrderLT Char where
+  lt_iff a b := by
+    simp [← Char.not_le, Decidable.imp_iff_not_or, Std.Total.total]
+
+end Char

src/Init/Data/Fin/Lemmas.lean

@@ -12,9 +12,13 @@ public import Init.Ext
 public import Init.ByCases
 public import Init.Conv
 public import Init.Omega
+public import Init.Data.Order.Factories
+import Init.Data.Order.Lemmas
 
 public section
 
+open Std
+
 namespace Fin
 
 @[simp] theorem ofNat_zero (n : Nat) [NeZero n] : Fin.ofNat n 0 = 0 := rfl
@@ -251,6 +255,16 @@ protected theorem le_antisymm_iff {x y : Fin n} : x = y ↔ x ≤ y ∧ y ≤ x
 protected theorem le_antisymm {x y : Fin n} (h1 : x ≤ y) (h2 : y ≤ x) : x = y :=
   Fin.le_antisymm_iff.2 ⟨h1, h2⟩
 
+instance instIsLinearOrder : IsLinearOrder (Fin n) := by
+  apply IsLinearOrder.of_le
+  case le_antisymm => constructor; apply Fin.le_antisymm
+  case le_total => constructor; apply Fin.le_total
+  case le_trans => constructor; apply Fin.le_trans
+
+instance : LawfulOrderLT (Fin n) where
+  lt_iff := by
+    simp [← Fin.not_le, Decidable.imp_iff_not_or, Std.Total.total]
+
 @[simp, grind =] theorem val_rev (i : Fin n) : rev i = n - (i + 1) := rfl
 
 @[simp] theorem rev_rev (i : Fin n) : rev (rev i) = i := Fin.ext <| by

src/Init/Data/Int/Order.lean

@@ -8,9 +8,13 @@ module
 prelude
 public import Init.Data.Int.Lemmas
 public import Init.ByCases
+public import Init.Data.Order.Factories
+import Init.Data.Order.Lemmas
 
 public section
 
+open Std
+
 /-!
 # Results about the order properties of the integers, and the integers as an ordered ring.
 -/
@@ -1415,4 +1419,14 @@ theorem natAbs_eq_iff_mul_eq_zero : natAbs a = n ↔ (a - n) * (a + n) = 0 := by
 @[deprecated natAbs_eq_iff_mul_eq_zero (since := "2025-03-11")]
 abbrev eq_natAbs_iff_mul_eq_zero := @natAbs_eq_iff_mul_eq_zero
 
+instance instIsLinearOrder : IsLinearOrder Int := by
+  apply IsLinearOrder.of_le
+  case le_antisymm => constructor; apply Int.le_antisymm
+  case le_total => constructor; apply Int.le_total
+  case le_trans => constructor; apply Int.le_trans
+
+instance : LawfulOrderLT Int where
+  lt_iff := by
+    simp [← Int.not_le, Decidable.imp_iff_not_or, Std.Total.total]
+
 end Int

src/Init/Data/Iterators/PostconditionMonad.lean

@@ -7,7 +7,7 @@ module
 
 prelude
 public import Init.Control.Lawful.Basic
-public import Init.Data.Subtype
+public import Init.Data.Subtype.Basic
 public import Init.PropLemmas
 
 public section

src/Init/Data/List/Attach.lean

@@ -8,7 +8,7 @@ module
 prelude
 public import all Init.Data.List.Lemmas  -- for dsimping with `getElem?_cons_succ`
 public import Init.Data.List.Count
-public import Init.Data.Subtype
+public import Init.Data.Subtype.Basic
 public import Init.BinderNameHint
 
 public section

src/Init/Data/List/Lex.lean

@@ -8,9 +8,13 @@ module
 prelude
 public import Init.Data.List.Lemmas
 public import Init.Data.List.Nat.TakeDrop
+public import Init.Data.Order.Factories
+import Init.Data.Order.Lemmas
 
 public section
 
+open Std
+
 set_option linter.listVariables true -- Enforce naming conventions for `List`/`Array`/`Vector` variables.
 set_option linter.indexVariables true -- Enforce naming conventions for index variables.
 
@@ -18,6 +22,11 @@ namespace List
 
 /-! ### Lexicographic ordering -/
 
+instance [LT α] [Std.Asymm (α := List α) (· < ·)] : LawfulOrderLT (List α) where
+  lt_iff := by
+    simp only [LE.le, List.le, Classical.not_not, iff_and_self]
+    apply Std.Asymm.asymm
+
 @[simp] theorem lex_lt [LT α] {l₁ l₂ : List α} : Lex (· < ·) l₁ l₂ ↔ l₁ < l₂ := Iff.rfl
 @[simp] theorem not_lex_lt [LT α] {l₁ l₂ : List α} : ¬ Lex (· < ·) l₁ l₂ ↔ l₂ ≤ l₁ := Iff.rfl
 
@@ -79,7 +88,6 @@ theorem not_cons_lex_cons_iff [DecidableEq α] [DecidableRel r] {a b} {l₁ l₂
   rw [cons_lex_cons_iff, not_or, Decidable.not_and_iff_or_not, and_or_left]
 
 theorem cons_le_cons_iff [LT α]
-    [i₀ : Std.Irrefl (· < · : α → α → Prop)]
     [i₁ : Std.Asymm (· < · : α → α → Prop)]
     [i₂ : Std.Antisymm (¬ · < · : α → α → Prop)]
     {a b} {l₁ l₂ : List α} :
@@ -101,19 +109,22 @@ theorem cons_le_cons_iff [LT α]
         exact ⟨i₂.antisymm _ _ h₃ h₁, h₂⟩
   · rintro (h | ⟨h₁, h₂⟩)
     · left
-      exact ⟨i₁.asymm _ _ h, fun w => i₀.irrefl _ (w ▸ h)⟩
+      exact ⟨i₁.asymm _ _ h, fun w => Irrefl.irrefl _ (w ▸ h)⟩
     · right
-      exact ⟨fun w => i₀.irrefl _ (h₁ ▸ w), h₂⟩
+      exact ⟨fun w => Irrefl.irrefl _ (h₁ ▸ w), h₂⟩
 
 theorem not_lt_of_cons_le_cons [LT α]
-    [i₀ : Std.Irrefl (· < · : α → α → Prop)]
     [i₁ : Std.Asymm (· < · : α → α → Prop)]
     [i₂ : Std.Antisymm (¬ · < · : α → α → Prop)]
     {a b : α} {l₁ l₂ : List α} (h : a :: l₁ ≤ b :: l₂) : ¬ b < a := by
   rw [cons_le_cons_iff] at h
   rcases h with h | ⟨rfl, h⟩
   · exact i₁.asymm _ _ h
-  · exact i₀.irrefl _
+  · exact Irrefl.irrefl _
+
+theorem left_le_left_of_cons_le_cons [LT α] [LE α] [IsLinearOrder α]
+    [LawfulOrderLT α] {a b : α} {l₁ l₂ : List α} (h : a :: l₁ ≤ b :: l₂) : a ≤ b := by
+  simpa [not_lt] using not_lt_of_cons_le_cons h
 
 theorem le_of_cons_le_cons [LT α]
     [i₀ : Std.Irrefl (· < · : α → α → Prop)]
@@ -165,11 +176,7 @@ instance [LT α] [Trans (· < · : α → α → Prop) (· < ·) (· < ·)] :
 
 
 
-protected theorem lt_of_le_of_lt [LT α]
-    [i₀ : Std.Irrefl (· < · : α → α → Prop)]
-    [i₁ : Std.Asymm (· < · : α → α → Prop)]
-    [i₂ : Std.Antisymm (¬ · < · : α → α → Prop)]
-    [i₃ : Trans (¬ · < · : α → α → Prop) (¬ · < ·) (¬ · < ·)]
+protected theorem lt_of_le_of_lt [LT α] [LE α] [IsLinearOrder α] [LawfulOrderLT α]
     {l₁ l₂ l₃ : List α} (h₁ : l₁ ≤ l₂) (h₂ : l₂ < l₃) : l₁ < l₃ := by
   induction h₂ generalizing l₁ with
   | nil => simp_all
@@ -179,11 +186,8 @@ protected theorem lt_of_le_of_lt [LT α]
     | nil => simp_all
     | cons c l₁ =>
       apply Lex.rel
-      replace h₁ := not_lt_of_cons_le_cons h₁
-      apply Classical.byContradiction
-      intro h₂
-      have := i₃.trans h₁ h₂
-      contradiction
+      replace h₁ := left_le_left_of_cons_le_cons h₁
+      exact lt_of_le_of_lt h₁ hab
   | cons w₃ ih =>
     rename_i a as bs
     cases l₁ with
@@ -193,21 +197,34 @@ protected theorem lt_of_le_of_lt [LT α]
       by_cases w₅ : a = c
       · subst w₅
         exact Lex.cons (ih (le_of_cons_le_cons h₁))
-      · exact Lex.rel (Classical.byContradiction fun w₆ => w₅ (i₂.antisymm _ _ w₄ w₆))
+      · simp only [not_lt] at w₄
+        exact Lex.rel (lt_of_le_of_ne w₄ (w₅.imp Eq.symm))
 
-protected theorem le_trans [LT α]
-    [Std.Irrefl (· < · : α → α → Prop)]
+@[deprecated List.lt_of_le_of_lt (since := "2025-08-01")]
+protected theorem lt_of_le_of_lt' [LT α]
+    [Std.Asymm (· < · : α → α → Prop)]
+    [Std.Antisymm (¬ · < · : α → α → Prop)]
+    [Trans (¬ · < · : α → α → Prop) (¬ · < ·) (¬ · < ·)]
+    {l₁ l₂ l₃ : List α} (h₁ : l₁ ≤ l₂) (h₂ : l₂ < l₃) : l₁ < l₃ :=
+  letI : LE α := .ofLT α
+  haveI : IsLinearOrder α := IsLinearOrder.of_lt
+  List.lt_of_le_of_lt h₁ h₂
+
+protected theorem le_trans [LT α] [LE α] [IsLinearOrder α] [LawfulOrderLT α]
+    {l₁ l₂ l₃ : List α} (h₁ : l₁ ≤ l₂) (h₂ : l₂ ≤ l₃) : l₁ ≤ l₃ :=
+  fun h₃ => h₁ (List.lt_of_le_of_lt h₂ h₃)
+
+@[deprecated List.le_trans (since := "2025-08-01")]
+protected theorem le_trans' [LT α]
     [Std.Asymm (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)]
     [Trans (¬ · < · : α → α → Prop) (¬ · < ·) (¬ · < ·)]
     {l₁ l₂ l₃ : List α} (h₁ : l₁ ≤ l₂) (h₂ : l₂ ≤ l₃) : l₁ ≤ l₃ :=
-  fun h₃ => h₁ (List.lt_of_le_of_lt h₂ h₃)
+  letI := LE.ofLT α
+  haveI : IsLinearOrder α := IsLinearOrder.of_lt
+  List.le_trans h₁ h₂
 
-instance [LT α]
-    [Std.Irrefl (· < · : α → α → Prop)]
-    [Std.Asymm (· < · : α → α → Prop)]
-    [Std.Antisymm (¬ · < · : α → α → Prop)]
-    [Trans (¬ · < · : α → α → Prop) (¬ · < ·) (¬ · < ·)] :
+instance [LT α] [LE α] [IsLinearOrder α] [LawfulOrderLT α] :
     Trans (· ≤ · : List α → List α → Prop) (· ≤ ·) (· ≤ ·) where
   trans h₁ h₂ := List.le_trans h₁ h₂
 
@@ -247,14 +264,21 @@ theorem not_lex_total {r : α → α → Prop}
     obtain (_ | _) := not_lex_total h l₁ l₂ <;> contradiction
 
 protected theorem le_total [LT α]
-    [i : Std.Total (¬ · < · : α → α → Prop)] (l₁ l₂ : List α) : l₁ ≤ l₂ ∨ l₂ ≤ l₁ :=
-  not_lex_total i.total l₂ l₁
+    [i : Std.Asymm (· < · : α → α → Prop)] (l₁ l₂ : List α) : l₁ ≤ l₂ ∨ l₂ ≤ l₁ :=
+  not_lex_total i.total_not.total l₂ l₁
 
-instance [LT α]
-    [Std.Total (¬ · < · : α → α → Prop)] :
+protected theorem le_total_of_asymm [LT α]
+    [i : Std.Asymm (· < · : α → α → Prop)] (l₁ l₂ : List α) : l₁ ≤ l₂ ∨ l₂ ≤ l₁ :=
+  List.le_total l₁ l₂
+
+instance [LT α] [Std.Asymm (· < · : α → α → Prop)] :
     Std.Total (· ≤ · : List α → List α → Prop) where
   total := List.le_total
 
+@[no_expose]
+instance instIsLinearOrder [LT α] [LE α] [IsLinearOrder α] [LawfulOrderLT α] :
+    IsLinearOrder (List α) := IsLinearOrder.of_le
+
 @[simp] protected theorem not_lt [LT α]
     {l₁ l₂ : List α} : ¬ l₁ < l₂ ↔ l₂ ≤ l₁ := Iff.rfl
 
@@ -262,7 +286,7 @@ instance [LT α]
     {l₁ l₂ : List α} : ¬ l₂ ≤ l₁ ↔ l₁ < l₂ := Classical.not_not
 
 protected theorem le_of_lt [LT α]
-    [i : Std.Total (¬ · < · : α → α → Prop)]
+    [i : Std.Asymm (· < · : α → α → Prop)]
     {l₁ l₂ : List α} (h : l₁ < l₂) : l₁ ≤ l₂ := by
   obtain (h' | h') := List.le_total l₁ l₂
   · exact h'
@@ -272,7 +296,7 @@ protected theorem le_of_lt [LT α]
 protected theorem le_iff_lt_or_eq [LT α]
     [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)]
-    [Std.Total (¬ · < · : α → α → Prop)]
+    [Std.Asymm (· < · : α → α → Prop)]
     {l₁ l₂ : List α} : l₁ ≤ l₂ ↔ l₁ < l₂ ∨ l₁ = l₂ := by
   constructor
   · intro h
@@ -456,7 +480,6 @@ protected theorem lt_iff_exists [LT α] {l₁ l₂ : List α} :
   simp
 
 protected theorem le_iff_exists [LT α]
-    [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Asymm (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)] {l₁ l₂ : List α} :
     l₁ ≤ l₂ ↔
@@ -480,7 +503,6 @@ theorem append_left_lt [LT α] {l₁ l₂ l₃ : List α} (h : l₂ < l₃) :
   | cons a l₁ ih => simp [cons_lt_cons_iff, ih]
 
 theorem append_left_le [LT α]
-    [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Asymm (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)]
     {l₁ l₂ l₃ : List α} (h : l₂ ≤ l₃) :
@@ -514,10 +536,8 @@ protected theorem map_lt [LT α] [LT β]
     simp [cons_lt_cons_iff, w, h]
 
 protected theorem map_le [LT α] [LT β]
-    [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Asymm (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)]
-    [Std.Irrefl (· < · : β → β → Prop)]
     [Std.Asymm (· < · : β → β → Prop)]
     [Std.Antisymm (¬ · < · : β → β → Prop)]
     {l₁ l₂ : List α} {f : α → β} (w : ∀ x y, x < y → f x < f y) (h : l₁ ≤ l₂) :

src/Init/Data/List/MapIdx.lean

@@ -61,7 +61,7 @@ proof that the index is valid.
 `List.mapIdxM` is a variant that does not provide the function with evidence that the index is
 valid.
 -/
-@[inline] def mapFinIdxM [Monad m] (as : List α) (f : (i : Nat) → α → (h : i < as.length) → m β) : m (List β) :=
+@[inline, expose] def mapFinIdxM [Monad m] (as : List α) (f : (i : Nat) → α → (h : i < as.length) → m β) : m (List β) :=
   go as #[] (by simp)
 where
   /-- Auxiliary for `mapFinIdxM`:
@@ -78,7 +78,7 @@ found, returning the list of results.
 `List.mapFinIdxM` is a variant that additionally provides the function with a proof that the index
 is valid.
 -/
-@[inline] def mapIdxM [Monad m] (f : Nat → α → m β) (as : List α) : m (List β) := go as #[] where
+@[inline, expose] def mapIdxM [Monad m] (f : Nat → α → m β) (as : List α) : m (List β) := go as #[] where
   /-- Auxiliary for `mapIdxM`:
   `mapIdxM.go [a₀, a₁, ...] acc = acc.toList ++ [f acc.size a₀, f (acc.size + 1) a₁, ...]` -/
   @[specialize] go : List α → Array β → m (List β)

src/Init/Data/List/MinMax.lean

@@ -8,9 +8,14 @@ module
 prelude
 public import Init.Data.List.Lemmas
 public import Init.Data.List.Pairwise
+public import Init.Data.Order.Factories
+public import Init.Data.Subtype.Order
+import Init.Data.Order.Lemmas
 
 public section
 
+open Std
+
 /-!
 # Lemmas about `List.min?` and `List.max?.
 -/
@@ -55,7 +60,7 @@ theorem min?_eq_head? {α : Type u} [Min α] {l : List α}
       have hx : min x y = x := rel_of_pairwise_cons h mem_cons_self
       rw [foldl_cons, ih _ (hx.symm ▸ h.sublist (by simp)), hx]
 
-theorem min?_mem [Min α] (min_eq_or : ∀ a b : α, min a b = a ∨ min a b = b) :
+theorem min?_mem [Min α] [MinEqOr α] :
     {xs : List α} → xs.min? = some a → a ∈ xs := by
   intro xs
   match xs with
@@ -72,13 +77,10 @@ theorem min?_mem [Min α] (min_eq_or : ∀ a b : α, min a b = a ∨ min a b = b
       have p := ind _ eq
       cases p with
       | inl p =>
-        cases min_eq_or x y with | _ q => simp [p, q]
+        cases MinEqOr.min_eq_or x y with | _ q => simp [p, q]
       | inr p => simp [p, mem_cons]
 
--- See also `Init.Data.List.Nat.Basic` for specialisations of the next two results to `Nat`.
-
-theorem le_min?_iff [Min α] [LE α]
-    (le_min_iff : ∀ a b c : α, a ≤ min b c ↔ a ≤ b ∧ a ≤ c) :
+theorem le_min?_iff [Min α] [LE α] [LawfulOrderInf α] :
     {xs : List α} → xs.min? = some a → ∀ {x}, x ≤ a ↔ ∀ b, b ∈ xs → x ≤ b
   | nil => by simp
   | cons x xs => by
@@ -93,34 +95,60 @@ theorem le_min?_iff [Min α] [LE α]
       simp at eq
       simp [ih _ eq, le_min_iff, and_assoc]
 
--- This could be refactored by designing appropriate typeclasses to replace `le_refl`, `min_eq_or`,
--- and `le_min_iff`.
-theorem min?_eq_some_iff [Min α] [LE α]
-    (le_refl : ∀ a : α, a ≤ a)
-    (min_eq_or : ∀ a b : α, min a b = a ∨ min a b = b)
-    (le_min_iff : ∀ a b c : α, a ≤ min b c ↔ a ≤ b ∧ a ≤ c) {xs : List α}
-    (anti : ∀ a b, a ∈ xs → b ∈ xs → a ≤ b → b ≤ a → a = b := by
-      exact fun a b _ _ => Std.Antisymm.antisymm a b) :
+theorem min?_eq_some_iff [Min α] [LE α] {xs : List α} [IsLinearOrder α] [LawfulOrderMin α] :
     xs.min? = some a ↔ a ∈ xs ∧ ∀ b, b ∈ xs → a ≤ b := by
-  refine ⟨fun h => ⟨min?_mem min_eq_or h, (le_min?_iff le_min_iff h).1 (le_refl _)⟩, ?_⟩
+  refine ⟨fun h => ⟨min?_mem h, (le_min?_iff h).1 (le_refl _)⟩, ?_⟩
   intro ⟨h₁, h₂⟩
   cases xs with
   | nil => simp at h₁
   | cons x xs =>
-    exact congrArg some <| anti _ _ (min?_mem min_eq_or rfl) h₁
-      ((le_min?_iff le_min_iff (xs := x::xs) rfl).1 (le_refl _) _ h₁)
-      (h₂ _ (min?_mem min_eq_or (xs := x::xs) rfl))
+    rw [List.min?]
+    exact congrArg some <| le_antisymm
+      ((le_min?_iff (xs := x :: xs) rfl).1 (le_refl _) _ h₁)
+      (h₂ _ (min?_mem (xs := x :: xs) rfl))
 
-theorem min?_replicate [Min α] {n : Nat} {a : α} (w : min a a = a) :
+private theorem min?_attach [Min α] [MinEqOr α] {xs : List α} :
+    xs.attach.min? = (xs.min?.pmap (fun m hm => ⟨m, min?_mem hm⟩) (fun _ => id)) := by
+  cases xs with
+  | nil => simp
+  | cons x xs =>
+    simp only [min?, attach_cons, Option.some.injEq, Option.pmap_some]
+    rw [foldl_map]
+    simp only [Subtype.ext_iff]
+    rw [← foldl_attach (l := xs)]
+    apply Eq.trans (foldl_hom (f := Subtype.val) ?_).symm
+    · rfl
+    · intros; rfl
+
+theorem min?_eq_min?_attach [Min α] [MinEqOr α] {xs : List α} :
+    xs.min? = (xs.attach.min?.map Subtype.val) := by
+  simp [min?_attach, Option.map_pmap]
+
+theorem min?_eq_some_iff_subtype [Min α] [LE α] {xs : List α}
+    [MinEqOr α] [IsLinearOrder (Subtype (· ∈ xs))] [LawfulOrderMin (Subtype (· ∈ xs))] :
+    xs.min? = some a ↔ a ∈ xs ∧ ∀ b, b ∈ xs → a ≤ b := by
+  have := fun a => min?_eq_some_iff (xs := xs.attach) (a := a)
+  rw [min?_eq_min?_attach]
+  simp [min?_eq_some_iff]
+  constructor
+  · rintro ⟨ha, h⟩
+    exact ⟨ha, h⟩
+  · rintro ⟨ha, h⟩
+    exact ⟨ha, h⟩
+
+theorem min?_replicate [Min α] [Std.IdempotentOp (min : α → α → α)] {n : Nat} {a : α} :
     (replicate n a).min? = if n = 0 then none else some a := by
   induction n with
   | zero => rfl
-  | succ n ih => cases n <;> simp_all [replicate_succ, min?_cons']
+  | succ n ih => cases n <;> simp_all [replicate_succ, min?_cons', Std.IdempotentOp.idempotent]
 
-@[simp] theorem min?_replicate_of_pos [Min α] {n : Nat} {a : α} (w : min a a = a) (h : 0 < n) :
+@[simp] theorem min?_replicate_of_pos [Min α] [MinEqOr α] {n : Nat} {a : α} (h : 0 < n) :
     (replicate n a).min? = some a := by
-  simp [min?_replicate, Nat.ne_of_gt h, w]
+  simp [min?_replicate, Nat.ne_of_gt h]
 
+/--
+Requirements are satisfied for `[OrderData α] [Min α] [IsLinearOrder α] [LawfulOrderMin α]`
+-/
 theorem foldl_min [Min α] [Std.IdempotentOp (min : α → α → α)] [Std.Associative (min : α → α → α)]
     {l : List α} {a : α} : l.foldl (init := a) min = min a (l.min?.getD a) := by
   cases l <;> simp [min?, foldl_assoc, Std.IdempotentOp.idempotent]
@@ -144,54 +172,120 @@ theorem isSome_max?_of_mem {l : List α} [Max α] {a : α} (h : a ∈ l) :
     l.max?.isSome := by
   cases l <;> simp_all [max?_cons']
 
-theorem max?_mem [Max α] (min_eq_or : ∀ a b : α, max a b = a ∨ max a b = b) :
-    {xs : List α} → xs.max? = some a → a ∈ xs
-  | nil => by simp
-  | cons x xs => by
-    rw [max?]; rintro ⟨⟩
-    induction xs generalizing x with simp at *
-    | cons y xs ih =>
-      rcases ih (max x y) with h | h <;> simp [h]
-      simp [← or_assoc, min_eq_or x y]
-
--- See also `Init.Data.List.Nat.Basic` for specialisations of the next two results to `Nat`.
-
-theorem max?_le_iff [Max α] [LE α]
-    (max_le_iff : ∀ a b c : α, max b c ≤ a ↔ b ≤ a ∧ c ≤ a) :
-    {xs : List α} → xs.max? = some a → ∀ {x}, a ≤ x ↔ ∀ b ∈ xs, b ≤ x
-  | nil => by simp
-  | cons x xs => by
-    rw [max?]; rintro ⟨⟩ y
-    induction xs generalizing x with
+theorem max?_eq_head? {α : Type u} [Max α] {l : List α}
+    (h : l.Pairwise (fun a b => max a b = a)) : l.max? = l.head? := by
+  cases l with
+  | nil => rfl
+  | cons x l =>
+    rw [head?_cons, max?_cons', Option.some.injEq]
+    induction l generalizing x with
     | nil => simp
-    | cons y xs ih => simp [ih, max_le_iff, and_assoc]
+    | cons y l ih =>
+      have hx : max x y = x := rel_of_pairwise_cons h mem_cons_self
+      rw [foldl_cons, ih _ (hx.symm ▸ h.sublist (by simp)), hx]
 
--- This could be refactored by designing appropriate typeclasses to replace `le_refl`, `max_eq_or`,
--- and `le_min_iff`.
-theorem max?_eq_some_iff [Max α] [LE α] [anti : Std.Antisymm (· ≤ · : α → α → Prop)]
-    (le_refl : ∀ a : α, a ≤ a)
-    (max_eq_or : ∀ a b : α, max a b = a ∨ max a b = b)
-    (max_le_iff : ∀ a b c : α, max b c ≤ a ↔ b ≤ a ∧ c ≤ a) {xs : List α} :
-    xs.max? = some a ↔ a ∈ xs ∧ ∀ b ∈ xs, b ≤ a := by
-  refine ⟨fun h => ⟨max?_mem max_eq_or h, (max?_le_iff max_le_iff h).1 (le_refl _)⟩, ?_⟩
+theorem max?_mem [Max α] [MaxEqOr α] :
+    {xs : List α} → xs.max? = some a → a ∈ xs := by
+  intro xs
+  match xs with
+  | nil => simp
+  | x :: xs =>
+    simp only [max?_cons', Option.some.injEq, mem_cons]
+    intro eq
+    induction xs generalizing x with
+    | nil =>
+      simp at eq
+      simp [eq]
+    | cons y xs ind =>
+      simp at eq
+      have p := ind _ eq
+      cases p with
+      | inl p =>
+        cases MaxEqOr.max_eq_or x y with | _ q => simp [p, q]
+      | inr p => simp [p, mem_cons]
+
+theorem max?_le_iff [Max α] [LE α] [LawfulOrderSup α] :
+    {xs : List α} → xs.max? = some a → ∀ {x}, a ≤ x ↔ ∀ b, b ∈ xs → b ≤ x
+  | nil => by simp
+  | cons x xs => by
+    rw [max?]
+    intro eq y
+    simp only [Option.some.injEq] at eq
+    induction xs generalizing x with
+    | nil =>
+      simp at eq
+      simp [eq]
+    | cons z xs ih =>
+      simp at eq
+      simp [ih _ eq, max_le_iff, and_assoc]
+
+theorem max?_eq_some_iff [Max α] [LE α] {xs : List α} [IsLinearOrder (α)]
+    [LawfulOrderMax α] : xs.max? = some a ↔ a ∈ xs ∧ ∀ b, b ∈ xs → b ≤ a := by
+  refine ⟨fun h => ⟨max?_mem h, (max?_le_iff h).1 (le_refl _)⟩, ?_⟩
   intro ⟨h₁, h₂⟩
   cases xs with
   | nil => simp at h₁
   | cons x xs =>
-    exact congrArg some <| anti.1 _ _
-      (h₂ _ (max?_mem max_eq_or (xs := x::xs) rfl))
-      ((max?_le_iff max_le_iff (xs := x::xs) rfl).1 (le_refl _) _ h₁)
+    rw [List.max?]
+    exact congrArg some <| le_antisymm
+      (h₂ _ (max?_mem (xs := x :: xs) rfl))
+      ((max?_le_iff (xs := x :: xs) rfl).1 (le_refl _) _ h₁)
 
-theorem max?_replicate [Max α] {n : Nat} {a : α} (w : max a a = a) :
+private theorem max?_attach [Max α] [MaxEqOr α] {xs : List α} :
+    xs.attach.max? = (xs.max?.pmap (fun m hm => ⟨m, max?_mem hm⟩) (fun _ => id)) := by
+  cases xs with
+  | nil => simp
+  | cons x xs =>
+    simp only [max?, attach_cons, Option.some.injEq, Option.pmap_some]
+    rw [foldl_map]
+    simp only [Subtype.ext_iff]
+    rw [← foldl_attach (l := xs)]
+    apply Eq.trans (foldl_hom (f := Subtype.val) ?_).symm
+    · rfl
+    · intros; rfl
+
+theorem max?_eq_max?_attach [Max α] [MaxEqOr α] {xs : List α} :
+    xs.max? = (xs.attach.max?.map Subtype.val) := by
+  simp [max?_attach, Option.map_pmap]
+
+theorem max?_eq_some_iff_subtype [Max α] [LE α] {xs : List α}
+    [MaxEqOr α] [IsLinearOrder (Subtype (· ∈ xs))]
+    [LawfulOrderMax (Subtype (· ∈ xs))] :
+    xs.max? = some a ↔ a ∈ xs ∧ ∀ b, b ∈ xs → b ≤ a := by
+  have := fun a => max?_eq_some_iff (xs := xs.attach) (a := a)
+  rw [max?_eq_max?_attach]
+  simp [max?_eq_some_iff]
+  constructor
+  · rintro ⟨ha, h⟩
+    exact ⟨ha, h⟩
+  · rintro ⟨ha, h⟩
+    exact ⟨ha, h⟩
+
+@[deprecated max?_eq_some_iff (since := "2025-08-01")]
+theorem max?_eq_some_iff_legacy [Max α] [LE α] [anti : Std.Antisymm (· ≤ · : α → α → Prop)]
+    (le_refl : ∀ a : α, a ≤ a)
+    (max_eq_or : ∀ a b : α, max a b = a ∨ max a b = b)
+    (max_le_iff : ∀ a b c : α, max b c ≤ a ↔ b ≤ a ∧ c ≤ a) {xs : List α} :
+    xs.max? = some a ↔ a ∈ xs ∧ ∀ b ∈ xs, b ≤ a := by
+  haveI : MaxEqOr α := ⟨max_eq_or⟩
+  haveI : LawfulOrderMax α := .of_le (fun _ _ _ => max_le_iff _ _ _) max_eq_or
+  haveI : Refl (α := α) (· ≤ ·) := ⟨le_refl⟩
+  haveI : IsLinearOrder α := .of_refl_of_antisymm_of_lawfulOrderMax
+  apply max?_eq_some_iff
+
+theorem max?_replicate [Max α] [Std.IdempotentOp (max : α → α → α)] {n : Nat} {a : α} :
     (replicate n a).max? = if n = 0 then none else some a := by
   induction n with
   | zero => rfl
-  | succ n ih => cases n <;> simp_all [replicate_succ, max?_cons']
+  | succ n ih => cases n <;> simp_all [replicate_succ, max?_cons', Std.IdempotentOp.idempotent]
 
-@[simp] theorem max?_replicate_of_pos [Max α] {n : Nat} {a : α} (w : max a a = a) (h : 0 < n) :
+@[simp] theorem max?_replicate_of_pos [Max α] [MaxEqOr α] {n : Nat} {a : α} (h : 0 < n) :
     (replicate n a).max? = some a := by
-  simp [max?_replicate, Nat.ne_of_gt h, w]
+  simp [max?_replicate, Nat.ne_of_gt h]
 
+/--
+Requirements are satisfied for `[OrderData α] [Max α] [LinearOrder α] [LawfulOrderMax α]`
+-/
 theorem foldl_max [Max α] [Std.IdempotentOp (max : α → α → α)] [Std.Associative (max : α → α → α)]
     {l : List α} {a : α} : l.foldl (init := a) max = max a (l.max?.getD a) := by
   cases l <;> simp [max?, foldl_assoc, Std.IdempotentOp.idempotent]

src/Init/Data/List/Nat/Basic.lean

@@ -10,6 +10,7 @@ public import Init.Data.List.Count
 public import Init.Data.List.Find
 public import Init.Data.List.MinMax
 public import Init.Data.Nat.Lemmas
+import Init.Data.Nat.Order
 
 public section
 
@@ -210,12 +211,10 @@ theorem mem_eraseIdx_iff_getElem? {x : α} {l} {k} : x ∈ eraseIdx l k ↔ ∃
 /-! ### min? -/
 
 -- A specialization of `min?_eq_some_iff` to Nat.
+@[deprecated min?_eq_some_iff (since := "2025-08-08")]
 theorem min?_eq_some_iff' {xs : List Nat} :
-    xs.min? = some a ↔ (a ∈ xs ∧ ∀ b ∈ xs, a ≤ b) :=
-  min?_eq_some_iff
-    (le_refl := Nat.le_refl)
-    (min_eq_or := fun _ _ => Nat.min_def .. ▸ by split <;> simp)
-    (le_min_iff := fun _ _ _ => Nat.le_min)
+    xs.min? = some a ↔ (a ∈ xs ∧ ∀ b ∈ xs, a ≤ b) := by
+  exact min?_eq_some_iff
 
 theorem min?_get_le_of_mem {l : List Nat} {a : Nat} (h : a ∈ l) :
     l.min?.get (isSome_min?_of_mem h) ≤ a := by
@@ -237,12 +236,10 @@ theorem min?_getD_le_of_mem {l : List Nat} {a k : Nat} (h : a ∈ l) : l.min?.ge
 /-! ### max? -/
 
 -- A specialization of `max?_eq_some_iff` to Nat.
+@[deprecated max?_eq_some_iff (since := "2025-08-08")]
 theorem max?_eq_some_iff' {xs : List Nat} :
     xs.max? = some a ↔ (a ∈ xs ∧ ∀ b ∈ xs, b ≤ a) :=
   max?_eq_some_iff
-    (le_refl := Nat.le_refl)
-    (max_eq_or := fun _ _ => Nat.max_def .. ▸ by split <;> simp)
-    (max_le_iff := fun _ _ _ => Nat.max_le)
 
 theorem le_max?_get_of_mem {l : List Nat} {a : Nat} (h : a ∈ l) :
     a ≤ l.max?.get (isSome_max?_of_mem h) := by

src/Init/Data/Nat.lean

@@ -11,6 +11,7 @@ public import Init.Data.Nat.Div
 public import Init.Data.Nat.Dvd
 public import Init.Data.Nat.Gcd
 public import Init.Data.Nat.MinMax
+public import Init.Data.Nat.Order
 public import Init.Data.Nat.Bitwise
 public import Init.Data.Nat.Control
 public import Init.Data.Nat.Log2
@@ -23,5 +24,6 @@ public import Init.Data.Nat.Lcm
 public import Init.Data.Nat.Compare
 public import Init.Data.Nat.Simproc
 public import Init.Data.Nat.Fold
+public import Init.Data.Nat.Order
 
 public section

src/Init/Data/Nat/Order.lean

@@ -0,0 +1,41 @@
+/-
+Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Paul Reichert
+-/
+module
+
+prelude
+public import Init.Data.Nat.Basic
+import Init.Data.Nat.MinMax
+public import Init.Data.Order.Factories
+
+open Std
+
+namespace Nat
+
+public instance instIsLinearOrder : IsLinearOrder Nat := by
+  apply IsLinearOrder.of_le
+  · constructor; apply Nat.le_antisymm
+  · constructor; apply Nat.le_trans
+  · constructor; apply Nat.le_total
+
+public instance : LawfulOrderLT Nat := by
+  apply LawfulOrderLT.of_le
+  simp [Nat.lt_iff_le_and_ne]
+
+public instance : LawfulOrderMin Nat := by
+  apply LawfulOrderMin.of_le
+  · apply Nat.le_min
+  · intro a b
+    simp only [Nat.min_def]
+    split <;> simp
+
+public instance : LawfulOrderMax Nat := by
+  apply LawfulOrderMax.of_le
+  · apply Nat.max_le
+  · intro a b
+    simp only [Nat.max_def]
+    split <;> simp
+
+end Nat

src/Init/Data/Order.lean

@@ -0,0 +1,12 @@
+/-
+Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Paul Reichert
+-/
+module
+
+prelude
+public import Init.Data.Order.Classes
+public import Init.Data.Order.Lemmas
+public import Init.Data.Order.Factories
+public import Init.Data.Subtype.Order

src/Init/Data/Order/Classes.lean

@@ -0,0 +1,173 @@
+/-
+Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Paul Reichert
+-/
+module
+
+prelude
+public import Init.Core
+
+namespace Std
+
+/-!
+# Order-related typeclasses
+
+This module provides the typeclasses used to state that basic operations on some type `α`
+reflect a certain well-behaved order structure on `α`.
+
+The basic operations are provided by the typeclasses `LE α`, `LT α`, `BEq α`, `Ord α`, `Min α` and
+`Max α`.
+All of them describe at least some way to compare elements in `α`. Usually, any subset of them
+is available and one can/must show that these comparisons are well-behaved in some sense.
+
+For example, one could merely require that the available operations reflect a preorder
+(where the less-or-equal relation only needs to be reflexive and transitive). Alternatively,
+one could require a full linear order (additionally requiring antisymmetry and totality of the
+less-or-equal relation).
+
+There are many ways to characterize, say, linear orders:
+
+* `(· ≤ ·)` is reflexive, transitive, antisymmetric and total.
+* `(· ≤ ·)` is antisymmetric, `a < b ↔ ¬ b ≤ a` and `(· < ·)` is irreflexive, transitive and asymmetric.
+* `min a b` is either `a` or `b`, is symmetric and satisfies the
+  following property: `min c (min a b) = c` if and only if `min c a = c` and `min c b = c`.
+
+It is desirable that lemmas about linear orders state this hypothesis in a canonical way.
+Therefore, the classes defining preorders, partial orders, linear preorders and linear orders
+are all formulated purely in terms of `LE`. For other operations, there are
+classes for compatibility of `LE` with other operations. Hence, a lemma may look like:
+
+```lean
+theorem lt_trans {α : Type u} [LE α] [LT α]
+    [IsPreorder α] -- The order on `α` induced by `LE α` is, among other things, transitive.
+    [LawfulOrderLT α] -- `<` is the less-than relation induced by `LE α`.
+    {a b : α} : a < b → b < c → a < c := by
+  sorry
+```
+-/
+
+/--
+This typeclass states that the order structure on `α`, represented by an `LE α` instance,
+is a preorder. In other words, the less-or-equal relation is reflexive and transitive.
+-/
+public class IsPreorder (α : Type u) [LE α] where
+  le_refl : ∀ a : α, a ≤ a
+  le_trans : ∀ a b c : α, a ≤ b → b ≤ c → a ≤ c
+
+/--
+This typeclass states that the order structure on `α`, represented by an `LE α` instance,
+is a partial order.
+In other words, the less-or-equal relation is reflexive, transitive and antisymmetric.
+-/
+public class IsPartialOrder (α : Type u) [LE α] extends IsPreorder α where
+  le_antisymm : ∀ a b : α, a ≤ b → b ≤ a → a = b
+
+/--
+This typeclass states that the order structure on `α`, represented by an `LE α` instance,
+is a linear preorder.
+In other words, the less-or-equal relation is reflexive, transitive and total.
+-/
+public class IsLinearPreorder (α : Type u) [LE α] extends IsPreorder α where
+  le_total : ∀ a b : α, a ≤ b ∨ b ≤ a
+
+/--
+This typeclass states that the order structure on `α`, represented by an `LE α` instance,
+is a linear order.
+In other words, the less-or-equal relation is reflexive, transitive, antisymmetric and total.
+-/
+public class IsLinearOrder (α : Type u) [LE α] extends IsPartialOrder α, IsLinearPreorder α
+
+section LT
+
+/--
+This typeclass states that the synthesized `LT α` instance is compatible with the `LE α`
+instance. This means that `LT.lt a b` holds if and only if `a` is less or equal to `b` according
+to the `LE α` instance, but `b` is not less or equal to `a`.
+
+`LawfulOrderLT α` automatically entails that `LT α` is asymmetric: `a < b` and `b < a` can never
+be true simultaneously.
+
+`LT α` does not uniquely determine the `LE α`: There can be only one compatible order data
+instance that is total, but there can be others that are not total.
+-/
+public class LawfulOrderLT (α : Type u) [LT α] [LE α] where
+  lt_iff : ∀ a b : α, a < b ↔ a ≤ b ∧ ¬ b ≤ a
+
+end LT
+
+section Min
+
+/--
+This typeclass states that `Min.min a b` returns one of its arguments, either `a` or `b`.
+-/
+public class MinEqOr (α : Type u) [Min α] where
+  min_eq_or : ∀ a b : α, min a b = a ∨ min a b = b
+
+/--
+If both `a` and `b` satisfy some property `P`, then so does `min a b`, because it is equal to
+either `a` or `b`.
+-/
+public def MinEqOr.elim {α : Type u} [Min α] [MinEqOr α] {P : α → Prop} {a b : α} (ha : P a) (hb : P b) :
+    P (min a b) := by
+  cases MinEqOr.min_eq_or a b <;> rename_i h
+  case inl => exact h.symm ▸ ha
+  case inr => exact h.symm ▸ hb
+
+/--
+This typeclass states that being less or equal to `min a b` is equivalent to being less or
+equal to both `a` and `b`..
+-/
+public class LawfulOrderInf (α : Type u) [Min α] [LE α] where
+  le_min_iff : ∀ a b c : α, a ≤ (min b c) ↔ a ≤ b ∧ a ≤ c
+
+/--
+This typeclass bundles `MinEqOr α` and `LawfulOrderInf α`. It characterizes when a `Min α`
+instance reasonably computes minima in some type `α` that has an `LE α` instance.
+
+As long as `α` is a preorder (see `IsPreorder α`), this typeclass implies that the order on
+`α` is total and that `Min.min a b` returns either `a` or `b`, whichever is less or equal to
+the other.
+-/
+public class LawfulOrderMin (α : Type u) [Min α] [LE α] extends MinEqOr α, LawfulOrderInf α
+
+end Min
+
+section Max
+
+/--
+This typeclass states that `Max.max a b` returns one of its arguments, either `a` or `b`.
+-/
+public class MaxEqOr (α : Type u) [Max α] where
+  max_eq_or : ∀ a b : α, max a b = a ∨ max a b = b
+
+/--
+If both `a` and `b` satisfy some property `P`, then so does `max a b`, because it is equal to
+either `a` or `b`.
+-/
+public def MaxEqOr.elim {α : Type u} [Max α] [MaxEqOr α] {P : α → Prop} {a b : α} (ha : P a) (hb : P b) :
+    P (max a b) := by
+  cases MaxEqOr.max_eq_or a b <;> rename_i h
+  case inl => exact h.symm ▸ ha
+  case inr => exact h.symm ▸ hb
+
+/--
+This typeclass states that being less or equal to `Max.max a b` is equivalent to being less or
+equal to both `a` and `b`.
+-/
+public class LawfulOrderSup (α : Type u) [Max α] [LE α] where
+  max_le_iff : ∀ a b c : α, (max a b) ≤ c ↔ a ≤ c ∧ b ≤ c
+
+/--
+This typeclass bundles `MaxEqOr α` and `LawfulOrderSup α`. It characterizes when a `Max α`
+instance reasonably computes maxima in some type `α` that has an `LE α` instance.
+
+As long as `α` is a preorder (see `IsPreorder α`), this typeclass implies that the order on
+`α` is total and that `Min.min a b` returns either `a` or `b`, whichever is greater or equal to
+the other.
+-/
+public class LawfulOrderMax (α : Type u) [Max α] [LE α] extends MaxEqOr α, LawfulOrderSup α
+
+end Max
+
+end Std

src/Init/Data/Order/Factories.lean

@@ -0,0 +1,236 @@
+/-
+Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Paul Reichert
+-/
+module
+
+prelude
+public import Init.Data.Order.Classes
+import Init.Classical
+
+namespace Std
+
+/-!
+This module provides utilities for the creation of order-related typeclass instances.
+-/
+
+section OfLE
+
+/--
+This instance is only publicly defined in `Init.Data.Order.Lemmas`.
+-/
+instance {r : α → α → Prop} [Total r] : Refl r where
+  refl a := by simpa using Total.total a a
+
+/--
+If an `LE α` instance is reflexive and transitive, then it represents a preorder.
+-/
+public theorem IsPreorder.of_le {α : Type u} [LE α]
+    (le_refl : Std.Refl (α := α) (· ≤ ·) := by exact inferInstance)
+    (le_trans : Trans (α := α) (· ≤ ·) (· ≤ ·) (· ≤ ·) := by exact inferInstance) :
+    IsPreorder α where
+  le_refl := le_refl.refl
+  le_trans _ _ _ := le_trans.trans
+
+/--
+If an `LE α` instance is transitive and total, then it represents a linear preorder.
+-/
+public theorem IsLinearPreorder.of_le {α : Type u} [LE α]
+    (le_trans : Trans (α := α) (· ≤ ·) (· ≤ ·) (· ≤ ·) := by exact inferInstance)
+    (le_total : Total (α := α) (· ≤ ·) := by exact inferInstance) :
+    IsLinearPreorder α where
+  toIsPreorder := .of_le
+  le_total := le_total.total
+
+/--
+If an `LE α` is reflexive, antisymmetric and transitive, then it represents a partial order.
+-/
+public theorem IsPartialOrder.of_le {α : Type u} [LE α]
+    (le_refl : Std.Refl (α := α) (· ≤ ·) := by exact inferInstance)
+    (le_antisymm : Std.Antisymm (α := α) (· ≤ ·) := by exact inferInstance)
+    (le_trans : Trans (α := α) (· ≤ ·) (· ≤ ·) (· ≤ ·) := by exact inferInstance) :
+    IsPartialOrder α where
+  toIsPreorder := .of_le
+  le_antisymm := le_antisymm.antisymm
+
+/--
+If an `LE α` instance is antisymmetric, transitive and total, then it represents a linear order.
+-/
+public theorem IsLinearOrder.of_le {α : Type u} [LE α]
+    (le_antisymm : Std.Antisymm (α := α) (· ≤ ·) := by exact inferInstance)
+    (le_trans : Trans (α := α) (· ≤ ·) (· ≤ ·) (· ≤ ·) := by exact inferInstance)
+    (le_total : Total (α := α) (· ≤ ·) := by exact inferInstance) :
+    IsLinearOrder α where
+  toIsLinearPreorder := .of_le
+  le_antisymm := le_antisymm.antisymm
+
+/--
+Returns a `LawfulOrderLT α` instance given certain properties.
+
+If an `OrderData α` instance is compatible with an `LE α` instance, then this lemma derives
+a `LawfulOrderLT α` instance from a property relating the `LE α` and `LT α` instances.
+-/
+public theorem LawfulOrderLT.of_le {α : Type u} [LT α] [LE α]
+    (lt_iff : ∀ a b : α, a < b ↔ a ≤ b ∧ ¬ b ≤ a) : LawfulOrderLT α where
+  lt_iff := lt_iff
+
+/--
+This lemma characterizes in terms of `LE α` when a `Min α` instance "behaves like an infimum
+operator".
+-/
+public theorem LawfulOrderInf.of_le {α : Type u} [Min α] [LE α]
+    (le_min_iff : ∀ a b c : α, a ≤ min b c ↔ a ≤ b ∧ a ≤ c) : LawfulOrderInf α where
+  le_min_iff := le_min_iff
+
+/--
+Returns a `LawfulOrderMin α` instance given certain properties.
+
+This lemma derives a `LawfulOrderMin α` instance from two properties involving `LE α` and `Min α`
+instances.
+
+The produced instance entails `LawfulOrderInf α` and `MinEqOr α`.
+-/
+public theorem LawfulOrderMin.of_le {α : Type u} [Min α] [LE α]
+    (le_min_iff : ∀ a b c : α, a ≤ min b c ↔ a ≤ b ∧ a ≤ c)
+    (min_eq_or : ∀ a b : α, min a b = a ∨ min a b = b) : LawfulOrderMin α where
+  toLawfulOrderInf := .of_le le_min_iff
+  toMinEqOr := ⟨min_eq_or⟩
+
+/--
+This lemma characterizes in terms of `LE α` when a `Max α` instance "behaves like a supremum
+operator".
+-/
+public def LawfulOrderSup.of_le {α : Type u} [Max α] [LE α]
+    (max_le_iff : ∀ a b c : α, max a b ≤ c ↔ a ≤ c ∧ b ≤ c) : LawfulOrderSup α where
+  max_le_iff := max_le_iff
+
+/--
+Returns a `LawfulOrderMax α` instance given certain properties.
+
+This lemma derives a `LawfulOrderMax α` instance from two properties involving `LE α` and `Max α`
+instances.
+
+The produced instance entails `LawfulOrderSup α` and `MaxEqOr α`.
+-/
+public def LawfulOrderMax.of_le {α : Type u} [Max α] [LE α]
+    (max_le_iff : ∀ a b c : α, max a b ≤ c ↔ a ≤ c ∧ b ≤ c)
+    (max_eq_or : ∀ a b : α, max a b = a ∨ max a b = b) : LawfulOrderMax α where
+  toLawfulOrderSup := .of_le max_le_iff
+  toMaxEqOr := ⟨max_eq_or⟩
+
+end OfLE
+
+section OfLT
+
+/--
+Creates a *total* `LE α` instance from an `LT α` instance.
+
+This only makes sense for asymmetric `LT α` instances (see `Std.Asymm`).
+-/
+public def LE.ofLT (α : Type u) [LT α] : LE α where
+  le a b := ¬ b < a
+
+/--
+The `LE α` instance obtained from an asymmetric `LT α` instance is compatible with said
+`LT α` instance.
+-/
+public instance LawfulOrderLT.of_lt {α : Type u} [LT α] [i : Asymm (α := α) (· < ·)] :
+    haveI := LE.ofLT α
+    LawfulOrderLT α :=
+  letI := LE.ofLT α
+  { lt_iff a b := by simpa [LE.ofLT, Classical.not_not] using i.asymm a b }
+
+/--
+If an `LT α` instance is asymmetric and its negation is transitive, then `LE.ofLT α` represents a
+linear preorder.
+-/
+public theorem IsLinearPreorder.of_lt {α : Type u} [LT α]
+    (lt_asymm : Asymm (α := α) (· < ·) := by exact inferInstance)
+    (not_lt_trans : Trans (α := α) (¬ · < ·) (¬ · < ·) (¬ · < ·) := by exact inferInstance) :
+    haveI := LE.ofLT α
+    IsLinearPreorder α :=
+  letI := LE.ofLT α
+  { le_trans := by simpa [LE.ofLT] using fun a b c hab hbc => not_lt_trans.trans hbc hab
+    le_total a b := by
+      apply Or.symm
+      open Classical in simpa [LE.ofLT, Decidable.imp_iff_not_or] using lt_asymm.asymm a b
+    le_refl a := by
+      open Classical in simpa [LE.ofLT] using lt_asymm.asymm a a }
+
+/--
+If an `LT α` instance is asymmetric and its negation is transitive and antisymmetric, then
+`LE.ofLT α` represents a linear order.
+-/
+public theorem IsLinearOrder.of_lt {α : Type u} [LT α]
+    (lt_asymm : Asymm (α := α) (· < ·) := by exact inferInstance)
+    (not_lt_trans : Trans (α := α) (¬ · < ·) (¬ · < ·) (¬ · < ·) := by exact inferInstance)
+    (not_lt_antisymm : Antisymm (α := α) (¬ · < ·) := by exact inferInstance) :
+    haveI := LE.ofLT α
+    IsLinearOrder α :=
+  letI := LE.ofLT α
+  haveI : IsLinearPreorder α := .of_lt
+  { le_antisymm := by
+      simpa [LE.ofLT] using fun a b hab hba => not_lt_antisymm.antisymm a b hba hab }
+
+/--
+This lemma characterizes in terms of `LT α` when a `Min α` instance
+"behaves like an infimum operator" with respect to `LE.ofLT α`.
+-/
+public theorem LawfulOrderInf.of_lt {α : Type u} [Min α] [LT α]
+    (min_lt_iff : ∀ a b c : α, min b c < a ↔ b < a ∨ c < a) :
+    haveI := LE.ofLT α
+    LawfulOrderInf α :=
+  letI := LE.ofLT α
+  { le_min_iff a b c := by
+      open Classical in
+      simp only [LE.ofLT, ← Decidable.not_iff_not (a := ¬ min b c < a)]
+      simpa [Decidable.imp_iff_not_or] using min_lt_iff a b c }
+
+/--
+Derives a `LawfulOrderMin α` instance for `OrderData.ofLT` from two properties involving
+`LT α` and `Min α` instances.
+
+The produced instance entails `LawfulOrderInf α` and `MinEqOr α`.
+-/
+public theorem LawfulOrderMin.of_lt {α : Type u} [Min α] [LT α]
+    (min_lt_iff : ∀ a b c : α, min b c < a ↔ b < a ∨ c < a)
+    (min_eq_or : ∀ a b : α, min a b = a ∨ min a b = b) :
+    haveI := LE.ofLT α
+    LawfulOrderMin α :=
+  letI := LE.ofLT α
+  { toLawfulOrderInf := .of_lt min_lt_iff
+    toMinEqOr := ⟨min_eq_or⟩ }
+
+/--
+This lemma characterizes in terms of `LT α` when a `Max α` instance
+"behaves like an supremum operator" with respect to `OrderData.ofLT α`.
+-/
+public def LawfulOrderSup.of_lt {α : Type u} [Max α] [LT α]
+    (lt_max_iff : ∀ a b c : α, c < max a b ↔ c < a ∨ c < b) :
+    haveI := LE.ofLT α
+    LawfulOrderSup α :=
+  letI := LE.ofLT α
+  { max_le_iff a b c := by
+      open Classical in
+      simp only [LE.ofLT, ← Decidable.not_iff_not ( a := ¬ c < max a b)]
+      simpa [Decidable.imp_iff_not_or] using lt_max_iff a b c }
+
+/--
+Derives a `LawfulOrderMax α` instance for `OrderData.ofLT` from two properties involving `LT α` and
+`Max α` instances.
+
+The produced instance entails `LawfulOrderSup α` and `MaxEqOr α`.
+-/
+public def LawfulOrderMax.of_lt {α : Type u} [Max α] [LT α]
+    (lt_max_iff : ∀ a b c : α, c < max a b ↔ c < a ∨ c < b)
+    (max_eq_or : ∀ a b : α, max a b = a ∨ max a b = b) :
+    haveI := LE.ofLT α
+    LawfulOrderMax α :=
+  letI := LE.ofLT α
+  { toLawfulOrderSup := .of_lt lt_max_iff
+    toMaxEqOr := ⟨max_eq_or⟩ }
+
+end OfLT
+
+end Std

src/Init/Data/Order/Lemmas.lean

@@ -0,0 +1,342 @@
+/-
+Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Paul Reichert
+-/
+module
+
+prelude
+public import Init.Data.Order.Classes
+public import Init.Data.Order.Factories
+import Init.SimpLemmas
+import Init.Classical
+
+namespace Std
+
+/-!
+This module provides typeclass instances and lemmas about order-related typeclasses.
+-/
+
+section AxiomaticInstances
+
+public instance (r : α → α → Prop) [Asymm r] : Irrefl r where
+  irrefl a h := Asymm.asymm a a h h
+
+public instance {r : α → α → Prop} [Total r] : Refl r where
+  refl a := by simpa using Total.total a a
+
+public instance Total.asymm_of_total_not {r : α → α → Prop} [i : Total (¬ r · ·)] : Asymm r where
+  asymm a b h := by cases i.total a b <;> trivial
+
+public theorem Asymm.total_not {r : α → α → Prop} [i : Asymm r] : Total (¬ r · ·) where
+  total a b := by
+    apply Classical.byCases (p := r a b) <;> intro hab
+    · exact Or.inr <| i.asymm a b hab
+    · exact Or.inl hab
+
+public instance {α : Type u} [LE α] [IsPartialOrder α] :
+    Std.Antisymm (α := α) (· ≤ ·) where
+  antisymm := IsPartialOrder.le_antisymm
+
+public instance {α : Type u} [LE α] [IsPreorder α] :
+    Trans (α := α) (· ≤ ·) (· ≤ ·) (· ≤ ·) where
+      trans := IsPreorder.le_trans _ _ _
+
+public instance {α : Type u} [LE α] [IsPreorder α] :
+    Std.Refl (α := α) (· ≤ ·) where
+  refl a := IsPreorder.le_refl a
+
+public instance {α : Type u} [LE α] [IsLinearPreorder α] :
+    Std.Total (α := α) (· ≤ ·) where
+  total a b := IsLinearPreorder.le_total a b
+
+end AxiomaticInstances
+
+section LE
+
+public theorem le_refl {α : Type u} [LE α] [Refl (α := α) (· ≤ ·)] (a : α) : a ≤ a := by
+  simp [Refl.refl]
+
+public theorem le_antisymm {α : Type u} [LE α] [Std.Antisymm (α := α) (· ≤ ·)] {a b : α}
+    (hab : a ≤ b) (hba : b ≤ a) : a = b :=
+  Std.Antisymm.antisymm _ _ hab hba
+
+public theorem le_trans {α : Type u} [LE α] [Trans (α := α) (· ≤ ·) (· ≤ ·) (· ≤ ·)] {a b c : α}
+    (hab : a ≤ b) (hbc : b ≤ c) : a ≤ c :=
+  Trans.trans hab hbc
+
+public theorem le_total {α : Type u} [LE α] [Std.Total (α := α) (· ≤ ·)] {a b : α} :
+    a ≤ b ∨ b ≤ a :=
+  Std.Total.total a b
+
+public instance {α : Type u} [LE α] [IsPreorder α] :
+    Refl (α := α) (· ≤ ·) where
+  refl := IsPreorder.le_refl
+
+public instance {α : Type u} [LE α] [IsPreorder α] :
+    Trans (α := α) (· ≤ ·) (· ≤ ·) (· ≤ ·) where
+  trans := IsPreorder.le_trans _ _ _
+
+public instance {α : Type u} [LE α] [IsLinearPreorder α] :
+    Total (α := α) (· ≤ ·) where
+  total := IsLinearPreorder.le_total
+
+public instance {α : Type u} [LE α] [IsPartialOrder α] :
+    Antisymm (α := α) (· ≤ ·) where
+  antisymm := IsPartialOrder.le_antisymm
+
+end LE
+
+section LT
+
+public theorem lt_iff_le_and_not_ge {α : Type u} [LT α] [LE α] [LawfulOrderLT α] {a b : α} :
+    a < b ↔ a ≤ b ∧ ¬ b ≤ a :=
+  LawfulOrderLT.lt_iff a b
+
+public theorem not_lt {α : Type u} [LT α] [LE α] [Std.Total (α := α) (· ≤ ·)] [LawfulOrderLT α]
+    {a b : α} : ¬ a < b ↔ b ≤ a := by
+  simp [lt_iff_le_and_not_ge, Classical.not_not, Std.Total.total]
+
+public theorem not_gt_of_lt {α : Type u} [LT α] [i : Std.Asymm (α := α) (· < ·)] {a b : α}
+    (h : a < b) : ¬ b < a :=
+  i.asymm a b h
+
+public instance {α : Type u} [LT α] [LE α] [LawfulOrderLT α] :
+    Std.Asymm (α := α) (· < ·) where
+  asymm a b := by
+    simp only [LawfulOrderLT.lt_iff]
+    intro h h'
+    exact h.2.elim h'.1
+
+public instance {α : Type u} [LT α] [LE α] [IsPreorder α] [LawfulOrderLT α] :
+    Std.Irrefl (α := α) (· < ·) := inferInstance
+
+public instance {α : Type u} [LT α] [LE α]
+    [Trans (α := α) (· ≤ ·) (· ≤ ·) (· ≤ ·) ] [LawfulOrderLT α] :
+    Trans (α := α) (· < ·) (· < ·) (· < ·) where
+  trans {a b c} hab hbc := by
+    simp only [lt_iff_le_and_not_ge] at hab hbc ⊢
+    apply And.intro
+    · exact le_trans hab.1 hbc.1
+    · intro hca
+      exact hab.2.elim (le_trans hbc.1 hca)
+
+public instance {α : Type u} {_ : LT α} [LE α] [LawfulOrderLT α]
+    [Total (α := α) (· ≤ ·)] [Antisymm (α := α) (· ≤ ·)] :
+    Antisymm (α := α) (¬ · < ·) where
+  antisymm a b hab hba := by
+    simp only [not_lt] at hab hba
+    exact Antisymm.antisymm (r := (· ≤ ·)) a b hba hab
+
+public instance {α : Type u} {_ : LT α} [LE α] [LawfulOrderLT α]
+    [Total (α := α) (· ≤ ·)] [Trans (α := α) (· ≤ ·) (· ≤ ·) (· ≤ ·)] :
+    Trans (α := α) (¬ · < ·) (¬ · < ·) (¬ · < ·) where
+  trans {a b c} hab hbc := by
+    simp only [not_lt] at hab hbc ⊢
+    exact le_trans hbc hab
+
+public instance {α : Type u} {_ : LT α} [LE α] [LawfulOrderLT α] [Total (α := α) (· ≤ ·)] :
+    Total (α := α) (¬ · < ·) where
+  total a b := by simp [not_lt, Std.Total.total]
+
+public theorem lt_of_le_of_lt {α : Type u} [LE α] [LT α]
+    [Trans (α := α) (· ≤ ·) (· ≤ ·) (· ≤ ·)] [LawfulOrderLT α] {a b c : α} (hab : a ≤ b)
+    (hbc : b < c) : a < c := by
+  simp only [lt_iff_le_and_not_ge] at hbc ⊢
+  apply And.intro
+  · exact le_trans hab hbc.1
+  · intro hca
+    exact hbc.2.elim (le_trans hca hab)
+
+public theorem lt_of_le_of_ne {α : Type u} [LE α] [LT α]
+    [Std.Antisymm (α := α) (· ≤ ·)] [LawfulOrderLT α] {a b : α}
+    (hle : a ≤ b) (hne : a ≠ b) : a < b := by
+  apply Classical.byContradiction
+  simp only [lt_iff_le_and_not_ge, hle, true_and, Classical.not_not, imp_false]
+  intro hge
+  exact hne.elim <| Std.Antisymm.antisymm a b hle hge
+
+end LT
+end Std
+
+namespace Classical.Order
+open Std
+
+public scoped instance instLT {α : Type u} [LE α] :
+    LT α where
+  lt a b := a ≤ b ∧ ¬ b ≤ a
+
+public instance instLawfulOrderLT {α : Type u} [LE α] :
+    LawfulOrderLT α where
+  lt_iff _ _ := Iff.rfl
+
+end Classical.Order
+
+namespace Std
+section Min
+
+public theorem min_self {α : Type u} [Min α] [Std.IdempotentOp (min : α → α → α)] {a : α} :
+    min a a = a :=
+  Std.IdempotentOp.idempotent a
+
+public theorem le_min_iff {α : Type u} [Min α] [LE α]
+    [LawfulOrderInf α] {a b c : α} :
+    a ≤ min b c ↔ a ≤ b ∧ a ≤ c :=
+  LawfulOrderInf.le_min_iff a b c
+
+public theorem min_le_left {α : Type u} [Min α] [LE α] [Refl (α := α) (· ≤ ·)] [LawfulOrderInf α]
+    {a b : α} : min a b ≤ a :=
+  le_min_iff.mp (le_refl _) |>.1
+
+public theorem min_le_right {α : Type u} [Min α] [LE α] [Refl (α := α) (· ≤ ·)] [LawfulOrderInf α]
+    {a b : α} : min a b ≤ b :=
+  le_min_iff.mp (le_refl _) |>.2
+
+public theorem min_le {α : Type u} [Min α] [LE α] [IsPreorder α] [LawfulOrderMin α] {a b c : α} :
+    min a b ≤ c ↔ a ≤ c ∨ b ≤ c := by
+  cases MinEqOr.min_eq_or a b <;> rename_i h
+  · simpa [h] using le_trans (h ▸ min_le_right (a := a) (b := b))
+  · simpa [h] using le_trans (h ▸ min_le_left (a := a) (b := b))
+
+public theorem min_eq_or {α : Type u} [Min α] [MinEqOr α] {a b : α} :
+    min a b = a ∨ min a b = b :=
+  MinEqOr.min_eq_or a b
+
+public instance {α : Type u} [LE α] [Min α] [IsLinearOrder α] [LawfulOrderInf α] :
+    MinEqOr α where
+  min_eq_or a b := by
+    open Classical.Order in
+    cases le_total (a := a) (b := b)
+    · apply Or.inl
+      apply le_antisymm
+      · apply min_le_left
+      · rw [le_min_iff]
+        exact ⟨le_refl a, ‹_›⟩
+    · apply Or.inr
+      apply le_antisymm
+      · apply min_le_right
+      · rw [le_min_iff]
+        exact ⟨‹_›, le_refl b⟩
+
+/--
+If a `Min α` instance satisfies typical properties in terms of a reflexive and antisymmetric `LE α`
+instance, then the `LE α` instance represents a linear order.
+-/
+public theorem IsLinearOrder.of_refl_of_antisymm_of_lawfulOrderMin {α : Type u} [LE α]
+    [LE α] [Min α] [Refl (α := α) (· ≤ ·)] [Antisymm (α := α) (· ≤ ·)] [LawfulOrderMin α] :
+    IsLinearOrder α := by
+  apply IsLinearOrder.of_le
+  · infer_instance
+  · constructor
+    intro a b c hab hbc
+    have : b = min b c := by
+      apply le_antisymm
+      · rw [le_min_iff]
+        exact ⟨le_refl b, hbc⟩
+      · apply min_le_left
+    rw [this, le_min_iff] at hab
+    exact hab.2
+  · constructor
+    intro a b
+    cases min_eq_or (a := a) (b := b) <;> rename_i h
+    · exact Or.inl (h ▸ min_le_right)
+    · exact Or.inr (h ▸ min_le_left)
+
+public instance {α : Type u} [Min α] [MinEqOr α] :
+    Std.IdempotentOp (min : α → α → α) where
+  idempotent a := by cases MinEqOr.min_eq_or a a <;> assumption
+
+open Classical.Order in
+public instance {α : Type u} [LE α] [Min α] [IsLinearOrder α] [LawfulOrderMin α] :
+    Std.Associative (min : α → α → α) where
+  assoc a b c := by apply le_antisymm <;> simp [min_le, le_min_iff, le_refl]
+
+end Min
+
+section Max
+
+public theorem max_self {α : Type u} [Max α] [Std.IdempotentOp (max : α → α → α)] {a : α} :
+    max a a = a :=
+  Std.IdempotentOp.idempotent a
+
+public theorem max_le_iff {α : Type u} [Max α] [LE α] [LawfulOrderSup α] {a b c : α} :
+    max a b ≤ c ↔ a ≤ c ∧ b ≤ c :=
+  LawfulOrderSup.max_le_iff a b c
+
+public theorem left_le_max {α : Type u} [Max α] [LE α] [Refl (α := α) (· ≤ ·)] [LawfulOrderSup α]
+    {a b : α} : a ≤ max a b :=
+  max_le_iff.mp (le_refl _) |>.1
+
+public theorem right_le_max {α : Type u} [Max α] [LE α] [Refl (α := α) (· ≤ ·)]
+    [LawfulOrderSup α] {a b : α} : b ≤ max a b :=
+  max_le_iff.mp (le_refl _) |>.2
+
+public theorem le_max {α : Type u} [Max α] [LE α] [IsPreorder α] [LawfulOrderMax α] {a b c : α} :
+    a ≤ max b c ↔ a ≤ b ∨ a ≤ c := by
+  cases MaxEqOr.max_eq_or b c <;> rename_i h
+  · simpa [h] using (le_trans · (h ▸ right_le_max))
+  · simpa [h] using (le_trans · (h ▸ left_le_max))
+
+public theorem max_eq_or {α : Type u} [Max α] [MaxEqOr α] {a b : α} :
+    max a b = a ∨ max a b = b :=
+  MaxEqOr.max_eq_or a b
+
+public instance {α : Type u} [LE α] [Max α] [IsLinearOrder α] [LawfulOrderSup α] :
+    MaxEqOr α where
+  max_eq_or a b := by
+    open Classical.Order in
+    cases le_total (a := a) (b := b)
+    · apply Or.inr
+      apply le_antisymm
+      · rw [max_le_iff]
+        exact ⟨‹_›, le_refl b⟩
+      · apply right_le_max
+    · apply Or.inl
+      apply le_antisymm
+      · rw [max_le_iff]
+        exact ⟨le_refl a, ‹_›⟩
+      · apply left_le_max
+
+/--
+If a `Max α` instance satisfies typical properties in terms of a reflexive and antisymmetric `LE α`
+instance, then the `LE α` instance represents a linear order.
+-/
+public theorem IsLinearOrder.of_refl_of_antisymm_of_lawfulOrderMax {α : Type u} [LE α] [Max α]
+    [Refl (α := α) (· ≤ ·)] [Antisymm (α := α) (· ≤ ·)] [LawfulOrderMax α] :
+    IsLinearOrder α := by
+  apply IsLinearOrder.of_le
+  · infer_instance
+  · constructor
+    intro a b c hab hbc
+    have : b = max a b := by
+      apply le_antisymm
+      · exact right_le_max
+      · rw [max_le_iff]
+        exact ⟨hab, le_refl b⟩
+    rw [this, max_le_iff] at hbc
+    exact hbc.1
+  · constructor
+    intro a b
+    cases max_eq_or (a := a) (b := b) <;> rename_i h
+    · exact Or.inr (h ▸ right_le_max)
+    · exact Or.inl (h ▸ left_le_max)
+
+public instance {α : Type u} [Max α] [MaxEqOr α] {P : α → Prop} : Max (Subtype P) where
+  max a b := ⟨Max.max a.val b.val, MaxEqOr.elim a.property b.property⟩
+
+public instance {α : Type u} [Max α] [MaxEqOr α] :
+    Std.IdempotentOp (max : α → α → α) where
+  idempotent a := by cases MaxEqOr.max_eq_or a a <;> assumption
+
+open Classical.Order in
+public instance {α : Type u} [LE α] [Max α] [IsLinearOrder α] [LawfulOrderMax α] :
+    Std.Associative (max : α → α → α) where
+  assoc a b c := by
+    apply le_antisymm
+    all_goals
+      simp only [max_le_iff]
+      simp [le_max, le_refl]
+
+end Max
+
+end Std

src/Init/Data/Random.lean

@@ -36,7 +36,14 @@ structure StdGen where
   s1 : Nat
   s2 : Nat
 
-instance : Inhabited StdGen := ⟨{ s1 := 0, s2 := 0 }⟩
+/-- Returns a standard number generator. -/
+def mkStdGen (s : Nat := 0) : StdGen :=
+  let q  := s / 2147483562
+  let s1 := s % 2147483562
+  let s2 := q % 2147483398
+  ⟨s1 + 1, s2 + 1⟩
+
+instance : Inhabited StdGen := ⟨mkStdGen⟩
 
 /-- The range of values returned by `StdGen` -/
 def stdRange := (1, 2147483562)
@@ -77,13 +84,6 @@ instance : RandomGen StdGen := {
   split  := stdSplit
 }
 
-/-- Returns a standard number generator. -/
-def mkStdGen (s : Nat := 0) : StdGen :=
-  let q  := s / 2147483562
-  let s1 := s % 2147483562
-  let s2 := q % 2147483398
-  ⟨s1 + 1, s2 + 1⟩
-
 /--
 Auxiliary function for randomNatVal.
 Generate random values until we exceed the target magnitude.

src/Init/Data/Range/Polymorphic/RangeIterator.lean

@@ -441,7 +441,7 @@ instance RangeIterator.instIteratorLoop {su} [UpwardEnumerable α] [SupportsUppe
         (f : (out : α) → UpwardEnumerable.LE least out → SupportsUpperBound.IsSatisfied upperBound out → (c : γ) → n (Subtype (fun s : ForInStep γ => Pl out c s)))
         (next : α) (hl : UpwardEnumerable.LE least next) (hu : SupportsUpperBound.IsSatisfied upperBound next) : n γ := do
       match ← f next hl hu acc with
-      | ⟨.yield acc', h⟩ =>
+      | ⟨.yield acc', _⟩ =>
         match hs : UpwardEnumerable.succ? next with
         | some next' =>
           if hu : SupportsUpperBound.IsSatisfied upperBound next' then

src/Init/Data/SInt/Lemmas.lean

@@ -15,9 +15,12 @@ public import Init.Data.Int.LemmasAux
 public import all Init.Data.UInt.Basic
 public import Init.Data.UInt.Lemmas
 public import Init.System.Platform
+import Init.Data.Order.Lemmas
 
 public section
 
+open Std
+
 open Lean in
 set_option hygiene false in
 macro "declare_int_theorems" typeName:ident _bits:term:arg : command => do
@@ -3025,6 +3028,56 @@ protected theorem Int64.lt_asymm {a b : Int64} : a < b → ¬b < a :=
 protected theorem ISize.lt_asymm {a b : ISize} : a < b → ¬b < a :=
   fun hab hba => ISize.lt_irrefl (ISize.lt_trans hab hba)
 
+instance Int8.instIsLinearOrder : IsLinearOrder Int8 := by
+  apply IsLinearOrder.of_le
+  case le_antisymm => constructor; apply Int8.le_antisymm
+  case le_total => constructor; apply Int8.le_total
+  case le_trans => constructor; apply Int8.le_trans
+
+instance : LawfulOrderLT Int8 where
+  lt_iff := by
+    simp [← Int8.not_le, Decidable.imp_iff_not_or, Std.Total.total]
+
+instance Int16.instIsLinearOrder : IsLinearOrder Int16 := by
+  apply IsLinearOrder.of_le
+  case le_antisymm => constructor; apply Int16.le_antisymm
+  case le_total => constructor; apply Int16.le_total
+  case le_trans => constructor; apply Int16.le_trans
+
+instance : LawfulOrderLT Int16 where
+  lt_iff := by
+    simp [← Int16.not_le, Decidable.imp_iff_not_or, Std.Total.total]
+
+instance Int32.instIsLinearOrder : IsLinearOrder Int32 := by
+  apply IsLinearOrder.of_le
+  case le_antisymm => constructor; apply Int32.le_antisymm
+  case le_total => constructor; apply Int32.le_total
+  case le_trans => constructor; apply Int32.le_trans
+
+instance : LawfulOrderLT Int32 where
+  lt_iff := by
+    simp [← Int32.not_le, Decidable.imp_iff_not_or, Std.Total.total]
+
+instance Int64.instIsLinearOrder : IsLinearOrder Int64 := by
+  apply IsLinearOrder.of_le
+  case le_antisymm => constructor; apply Int64.le_antisymm
+  case le_total => constructor; apply Int64.le_total
+  case le_trans => constructor; apply Int64.le_trans
+
+instance : LawfulOrderLT Int64 where
+  lt_iff := by
+    simp [← Int64.not_le, Decidable.imp_iff_not_or, Std.Total.total]
+
+instance ISize.instIsLinearOrder : IsLinearOrder ISize := by
+  apply IsLinearOrder.of_le
+  case le_antisymm => constructor; apply ISize.le_antisymm
+  case le_total => constructor; apply ISize.le_total
+  case le_trans => constructor; apply ISize.le_trans
+
+instance : LawfulOrderLT ISize where
+  lt_iff := by
+    simp [← ISize.not_le, Decidable.imp_iff_not_or, Std.Total.total]
+
 protected theorem Int8.add_neg_eq_sub {a b : Int8} : a + -b = a - b := Int8.toBitVec_inj.1 BitVec.add_neg_eq_sub
 protected theorem Int16.add_neg_eq_sub {a b : Int16} : a + -b = a - b := Int16.toBitVec_inj.1 BitVec.add_neg_eq_sub
 protected theorem Int32.add_neg_eq_sub {a b : Int32} : a + -b = a - b := Int32.toBitVec_inj.1 BitVec.add_neg_eq_sub

src/Init/Data/String/Basic.lean

@@ -485,6 +485,7 @@ Examples:
 * `"tea".firstDiffPos "teas" = ⟨3⟩`
 * `"teas".firstDiffPos "tea" = ⟨3⟩`
 -/
+@[expose]
 def firstDiffPos (a b : String) : Pos :=
   let stopPos := a.endPos.min b.endPos
   let rec loop (i : Pos) : Pos :=
@@ -511,7 +512,7 @@ Examples:
 * `"red green blue".extract ⟨4⟩ ⟨100⟩ = "green blue"`
 * `"L∃∀N".extract ⟨2⟩ ⟨100⟩ = "green blue"`
 -/
-@[extern "lean_string_utf8_extract"]
+@[extern "lean_string_utf8_extract", expose]
 def extract : (@& String) → (@& Pos) → (@& Pos) → String
   | ⟨s⟩, b, e => if b.byteIdx ≥ e.byteIdx then "" else ⟨go₁ s 0 b e⟩
 where

src/Init/Data/String/Lemmas.lean

@@ -6,11 +6,15 @@ Authors: Leonardo de Moura
 module
 
 prelude
+public import Init.Data.Char.Order
 public import Init.Data.Char.Lemmas
 public import Init.Data.List.Lex
+import Init.Data.Order.Lemmas
 
 public section
 
+open Std
+
 namespace String
 
 protected theorem data_eq_of_eq {a b : String} (h : a = b) : a.data = b.data :=
@@ -34,4 +38,14 @@ protected theorem ne_of_lt {a b : String} (h : a < b) : a ≠ b := by
   have := String.lt_irrefl a
   intro h; subst h; contradiction
 
+instance instIsLinearOrder : IsLinearOrder String := by
+  apply IsLinearOrder.of_le
+  case le_antisymm => constructor; apply String.le_antisymm
+  case le_trans => constructor; apply String.le_trans
+  case le_total => constructor; apply String.le_total
+
+instance : LawfulOrderLT String where
+  lt_iff a b := by
+    simp [← String.not_le, Decidable.imp_iff_not_or, Std.Total.total]
+
 end String

src/Init/Data/Subtype.lean

@@ -1,32 +1,11 @@
 /-
-Copyright (c) 2017 Johannes Hölzl. All rights reserved.
+Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
 Released under Apache 2.0 license as described in the file LICENSE.
-Authors: Johannes Hölzl
+Authors: Paul Reichert
 -/
 module
 
 prelude
-public import Init.Ext
-public import Init.Core
-
-public section
-
-namespace Subtype
-
-universe u
-variable {α : Sort u} {p q : α → Prop}
-
-@[ext]
-protected theorem ext : ∀ {a1 a2 : { x // p x }}, (a1 : α) = (a2 : α) → a1 = a2
-  | ⟨_, _⟩, ⟨_, _⟩, rfl => rfl
-
-@[simp]
-protected theorem «forall» {q : { a // p a } → Prop} : (∀ x, q x) ↔ ∀ a b, q ⟨a, b⟩ :=
-  ⟨fun h a b ↦ h ⟨a, b⟩, fun h ⟨a, b⟩ ↦ h a b⟩
-
-@[simp]
-protected theorem «exists» {q : { a // p a } → Prop} :
-    (Exists fun x => q x) ↔ Exists fun a => Exists fun b => q ⟨a, b⟩ :=
-  ⟨fun ⟨⟨a, b⟩, h⟩ ↦ ⟨a, b, h⟩, fun ⟨a, b, h⟩ ↦ ⟨⟨a, b⟩, h⟩⟩
-
-end Subtype
+public import Init.Data.Subtype.Basic
+public import Init.Data.Subtype.Order
+public import Init.Data.Subtype.OrderExtra

src/Init/Data/Subtype/Basic.lean

@@ -0,0 +1,32 @@
+/-
+Copyright (c) 2017 Johannes Hölzl. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Johannes Hölzl
+-/
+module
+
+prelude
+public import Init.Ext
+public import Init.Core
+
+public section
+
+namespace Subtype
+
+universe u
+variable {α : Sort u} {p q : α → Prop}
+
+@[ext]
+protected theorem ext : ∀ {a1 a2 : { x // p x }}, (a1 : α) = (a2 : α) → a1 = a2
+  | ⟨_, _⟩, ⟨_, _⟩, rfl => rfl
+
+@[simp]
+protected theorem «forall» {q : { a // p a } → Prop} : (∀ x, q x) ↔ ∀ a b, q ⟨a, b⟩ :=
+  ⟨fun h a b ↦ h ⟨a, b⟩, fun h ⟨a, b⟩ ↦ h a b⟩
+
+@[simp]
+protected theorem «exists» {q : { a // p a } → Prop} :
+    (Exists fun x => q x) ↔ Exists fun a => Exists fun b => q ⟨a, b⟩ :=
+  ⟨fun ⟨⟨a, b⟩, h⟩ ↦ ⟨a, b, h⟩, fun ⟨a, b, h⟩ ↦ ⟨⟨a, b⟩, h⟩⟩
+
+end Subtype

src/Init/Data/Subtype/Order.lean

@@ -0,0 +1,94 @@
+/-
+Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Paul Reichert
+-/
+module
+
+prelude
+import Init.SimpLemmas
+public import Init.Data.Order.Classes
+public import Init.Data.Order.Lemmas
+import Init.Data.Order.Factories
+import Init.Data.Subtype.Basic
+
+namespace Std
+
+public instance {α : Type u} [LE α] {P : α → Prop} : LE (Subtype P) where
+  le a b := a.val ≤ b.val
+
+public instance {α : Type u} [LT α] {P : α → Prop} : LT (Subtype P) where
+  lt a b := a.val < b.val
+
+public instance {α : Type u} [LT α] [LE α] [LawfulOrderLT α]
+    {P : α → Prop} : LawfulOrderLT (Subtype P) where
+  lt_iff a b := by simp [LT.lt, LE.le, LawfulOrderLT.lt_iff]
+
+public instance {α : Type u} [BEq α] {P : α → Prop} : BEq (Subtype P) where
+  beq a b := a.val == b.val
+
+public instance {α : Type u} [Min α] [MinEqOr α] {P : α → Prop} : Min (Subtype P) where
+  min a b := ⟨Min.min a.val b.val, MinEqOr.elim a.property b.property⟩
+
+public instance {α : Type u} [Max α] [MaxEqOr α] {P : α → Prop} : Max (Subtype P) where
+  max a b := ⟨max a.val b.val, MaxEqOr.elim a.property b.property⟩
+
+public instance {α : Type u} [LE α] [i : Refl (α := α) (· ≤ ·)] {P : α → Prop} :
+    Refl (α := Subtype P) (· ≤ ·) where
+  refl a := i.refl a.val
+
+public instance {α : Type u} [LE α] [i : Antisymm (α := α) (· ≤ ·)] {P : α → Prop} :
+    Antisymm (α := Subtype P) (· ≤ ·) where
+  antisymm a b hab hba := private Subtype.ext <| i.antisymm a.val b.val hab hba
+
+public instance {α : Type u} [LE α] [i : Total (α := α) (· ≤ ·)] {P : α → Prop} :
+    Total (α := Subtype P) (· ≤ ·) where
+  total a b := i.total a.val b.val
+
+public instance {α : Type u} [LE α] [i : Trans (α := α) (· ≤ ·) (· ≤ ·) (· ≤ ·)]
+    {P : α → Prop} :
+    Trans (α := Subtype P) (· ≤ ·) (· ≤ ·) (· ≤ ·) where
+  trans := i.trans
+
+public instance {α : Type u} [Min α] [MinEqOr α] {P : α → Prop} :
+    MinEqOr (Subtype P) where
+  min_eq_or a b := by
+    cases min_eq_or (a := a.val) (b := b.val) <;> rename_i h
+    · exact Or.inl <| Subtype.ext h
+    · exact Or.inr <| Subtype.ext h
+
+public instance {α : Type u} [LE α] [Min α] [LawfulOrderMin α] {P : α → Prop} :
+    LawfulOrderMin (Subtype P) where
+  le_min_iff _ _ _ := by
+    exact le_min_iff (α := α)
+
+public instance {α : Type u} [Max α] [MaxEqOr α] {P : α → Prop} :
+    MaxEqOr (Subtype P) where
+  max_eq_or a b := by
+    cases max_eq_or (a := a.val) (b := b.val) <;> rename_i h
+    · exact Or.inl <| Subtype.ext h
+    · exact Or.inr <| Subtype.ext h
+
+public instance {α : Type u} [LE α] [Max α] [LawfulOrderMax α] {P : α → Prop} :
+    LawfulOrderMax (Subtype P) where
+  max_le_iff _ _ _ := by
+    open Classical.Order in
+    exact max_le_iff (α := α)
+
+public instance {α : Type u} [LE α] [IsPreorder α] {P : α → Prop} :
+    IsPreorder (Subtype P) :=
+  IsPreorder.of_le
+
+public instance {α : Type u} [LE α] [IsLinearPreorder α] {P : α → Prop} :
+    IsLinearPreorder (Subtype P) :=
+  IsLinearPreorder.of_le
+
+public instance {α : Type u} [LE α] [IsPartialOrder α] {P : α → Prop} :
+    IsPartialOrder (Subtype P) :=
+  IsPartialOrder.of_le
+
+public instance {α : Type u} [LE α] [IsLinearOrder α] {P : α → Prop} :
+    IsLinearOrder (Subtype P) :=
+  IsLinearOrder.of_le
+
+end Std

src/Init/Data/Subtype/OrderExtra.lean

@@ -0,0 +1,13 @@
+/-
+Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Paul Reichert
+-/
+module
+
+prelude
+public import Init.Data.Subtype.Order
+public import Init.Data.Ord
+
+public instance {α : Type u} [Ord α] {P : α → Prop} : Ord (Subtype P) where
+  compare a b := compare a.val b.val

src/Init/Data/UInt/Basic.lean

@@ -8,9 +8,13 @@ module
 prelude
 public import Init.Data.UInt.BasicAux
 public import Init.Data.BitVec.Basic
+public import Init.Data.Order.Classes
+import Init.Data.Order.Factories
 
 @[expose] public section
 
+open Std
+
 set_option linter.missingDocs true
 
 open Nat

src/Init/Data/UInt/Lemmas.lean

@@ -15,9 +15,13 @@ public import all Init.Data.BitVec.Basic
 public import Init.Data.BitVec.Lemmas
 public import Init.Data.Nat.Div.Lemmas
 public import Init.System.Platform
+public import Init.Data.Order.Factories
+import Init.Data.Order.Lemmas
 
 public section
 
+open Std
+
 open Lean in
 set_option hygiene false in
 macro "declare_uint_theorems" typeName:ident bits:term:arg : command => do
@@ -206,6 +210,19 @@ macro "declare_uint_theorems" typeName:ident bits:term:arg : command => do
   protected theorem le_antisymm {a b : $typeName} (h₁ : a ≤ b) (h₂ : b ≤ a) : a = b :=
     le_antisymm_iff.2 ⟨h₁, h₂⟩
 
+  open $typeName renaming
+    le_refl → le_refl', le_antisymm → le_antisymm', le_total → le_total', le_trans → le_trans' in
+  instance instIsLinearOrder : IsLinearOrder $typeName := by
+    apply IsLinearOrder.of_le
+    case le_antisymm => constructor; apply le_antisymm'
+    case le_total => constructor; apply le_total'
+    case le_trans => constructor; apply le_trans'
+
+open $typeName renaming not_le → not_le'
+instance : LawfulOrderLT $typeName where
+  lt_iff _ _ := by
+    simp [← not_le', Decidable.imp_iff_not_or, Std.Total.total]
+
   @[simp] protected theorem ofNat_one : ofNat 1 = 1 := (rfl)
 
   @[simp] protected theorem ofNat_toNat {x : $typeName} : ofNat x.toNat = x := by

src/Init/Data/Vector/Lex.lean

@@ -11,15 +11,17 @@ public import Init.Data.Vector.Lemmas
 public import all Init.Data.Array.Lex.Basic
 public import Init.Data.Array.Lex.Lemmas
 import Init.Data.Range.Polymorphic.Lemmas
+import Init.Data.Order.Lemmas
 
 public section
 
+open Std
+
 set_option linter.listVariables true -- Enforce naming conventions for `List`/`Array`/`Vector` variables.
 set_option linter.indexVariables true -- Enforce naming conventions for index variables.
 
 namespace Vector
 
-
 /-! ### Lexicographic ordering -/
 
 @[simp] theorem lt_toArray [LT α] {xs ys : Vector α n} : xs.toArray < ys.toArray ↔ xs < ys := Iff.rfl
@@ -96,27 +98,35 @@ instance [LT α]
     Trans (· < · : Vector α n → Vector α n → Prop) (· < ·) (· < ·) where
   trans h₁ h₂ := Vector.lt_trans h₁ h₂
 
-protected theorem lt_of_le_of_lt [LT α]
-    [i₀ : Std.Irrefl (· < · : α → α → Prop)]
-    [i₁ : Std.Asymm (· < · : α → α → Prop)]
-    [i₂ : Std.Antisymm (¬ · < · : α → α → Prop)]
-    [i₃ : Trans (¬ · < · : α → α → Prop) (¬ · < ·) (¬ · < ·)]
+protected theorem lt_of_le_of_lt [LT α] [LE α] [LawfulOrderLT α] [IsLinearOrder α]
     {xs ys zs : Vector α n} (h₁ : xs ≤ ys) (h₂ : ys < zs) : xs < zs :=
   Array.lt_of_le_of_lt h₁ h₂
 
-protected theorem le_trans [LT α]
-    [Std.Irrefl (· < · : α → α → Prop)]
+@[deprecated Vector.lt_of_le_of_lt (since := "2025-08-01")]
+protected theorem lt_of_le_of_lt' [LT α]
+    [Std.Asymm (· < · : α → α → Prop)]
+    [Std.Antisymm (¬ · < · : α → α → Prop)]
+    [Trans (¬ · < · : α → α → Prop) (¬ · < ·) (¬ · < ·)]
+    {xs ys zs : Vector α n} (h₁ : xs ≤ ys) (h₂ : ys < zs) : xs < zs :=
+  letI := LE.ofLT α
+  haveI : IsLinearOrder α := IsLinearOrder.of_lt
+  Array.lt_of_le_of_lt h₁ h₂
+
+protected theorem le_trans [LT α] [LE α] [LawfulOrderLT α] [IsLinearOrder α]
+    {xs ys zs : Vector α n} (h₁ : xs ≤ ys) (h₂ : ys ≤ zs) : xs ≤ zs :=
+  fun h₃ => h₁ (Vector.lt_of_le_of_lt h₂ h₃)
+
+@[deprecated Vector.le_trans (since := "2025-08-01")]
+protected theorem le_trans' [LT α]
     [Std.Asymm (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)]
     [Trans (¬ · < · : α → α → Prop) (¬ · < ·) (¬ · < ·)]
     {xs ys zs : Vector α n} (h₁ : xs ≤ ys) (h₂ : ys ≤ zs) : xs ≤ zs :=
-  fun h₃ => h₁ (Vector.lt_of_le_of_lt h₂ h₃)
+  letI := LE.ofLT α
+  haveI : IsLinearOrder α := IsLinearOrder.of_lt
+  Array.le_trans h₁ h₂
 
-instance [LT α]
-    [Std.Irrefl (· < · : α → α → Prop)]
-    [Std.Asymm (· < · : α → α → Prop)]
-    [Std.Antisymm (¬ · < · : α → α → Prop)]
-    [Trans (¬ · < · : α → α → Prop) (¬ · < ·) (¬ · < ·)] :
+instance [LT α] [LE α] [LawfulOrderLT α] [IsLinearOrder α] :
     Trans (· ≤ · : Vector α n → Vector α n → Prop) (· ≤ ·) (· ≤ ·) where
   trans h₁ h₂ := Vector.le_trans h₁ h₂
 
@@ -129,30 +139,44 @@ instance [LT α]
     Std.Asymm (· < · : Vector α n → Vector α n → Prop) where
   asymm _ _ := Vector.lt_asymm
 
-protected theorem le_total [LT α]
-    [i : Std.Total (¬ · < · : α → α → Prop)] (xs ys : Vector α n) : xs ≤ ys ∨ ys ≤ xs :=
+protected theorem le_total [LT α] [i : Std.Asymm (· < · : α → α → Prop)] (xs ys : Vector α n) :
+    xs ≤ ys ∨ ys ≤ xs :=
   Array.le_total _ _
 
-instance [LT α]
-    [Std.Total (¬ · < · : α → α → Prop)] :
+protected theorem le_antisymm [LT α] [LE α] [IsLinearOrder α] [LawfulOrderLT α]
+    {xs ys : Vector α n} (h₁ : xs ≤ ys) (h₂ : ys ≤ xs) : xs = ys :=
+  Vector.toArray_inj.mp <| Array.le_antisymm h₁ h₂
+
+instance [LT α] [Std.Asymm (· < · : α → α → Prop)] :
     Std.Total (· ≤ · : Vector α n → Vector α n → Prop) where
   total := Vector.le_total
 
+instance [LT α] [LE α] [IsLinearOrder α] [LawfulOrderLT α] :
+    IsLinearOrder (Vector α n) := by
+  apply IsLinearOrder.of_le
+  case le_antisymm => constructor; apply Vector.le_antisymm
+  case le_total => constructor; apply Vector.le_total
+  case le_trans => constructor; apply Vector.le_trans
+
 @[simp] protected theorem not_lt [LT α]
     {xs ys : Vector α n} : ¬ xs < ys ↔ ys ≤ xs := Iff.rfl
 
 @[simp] protected theorem not_le [LT α]
     {xs ys : Vector α n} : ¬ ys ≤ xs ↔ xs < ys := Classical.not_not
 
+instance [LT α] [Std.Asymm (· < · : α → α → Prop)] : LawfulOrderLT (Vector α n) where
+  lt_iff _ _ := by
+    open Classical in
+    simp [← Vector.not_le, Decidable.imp_iff_not_or, Std.Total.total]
+
 protected theorem le_of_lt [LT α]
-    [i : Std.Total (¬ · < · : α → α → Prop)]
+    [i : Std.Asymm (· < · : α → α → Prop)]
     {xs ys : Vector α n} (h : xs < ys) : xs ≤ ys :=
   Array.le_of_lt h
 
 protected theorem le_iff_lt_or_eq [LT α]
-    [Std.Irrefl (· < · : α → α → Prop)]
+    [Std.Asymm (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)]
-    [Std.Total (¬ · < · : α → α → Prop)]
     {xs ys : Vector α n} : xs ≤ ys ↔ xs < ys ∨ xs = ys := by
   simpa using Array.le_iff_lt_or_eq (xs := xs.toArray) (ys := ys.toArray)
 
@@ -222,7 +246,6 @@ protected theorem lt_iff_exists [LT α] {xs ys : Vector α n} :
   simp_all [Array.lt_iff_exists]
 
 protected theorem le_iff_exists [LT α]
-    [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Asymm (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)] {xs ys : Vector α n} :
     xs ≤ ys ↔
@@ -237,7 +260,6 @@ theorem append_left_lt [LT α] {xs : Vector α n} {ys ys' : Vector α m} (h : ys
   simpa using Array.append_left_lt h
 
 theorem append_left_le [LT α]
-    [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Asymm (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)]
     {xs : Vector α n} {ys ys' : Vector α m} (h : ys ≤ ys') :
@@ -250,10 +272,8 @@ protected theorem map_lt [LT α] [LT β]
   simpa using Array.map_lt w h
 
 protected theorem map_le [LT α] [LT β]
-    [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Asymm (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)]
-    [Std.Irrefl (· < · : β → β → Prop)]
     [Std.Asymm (· < · : β → β → Prop)]
     [Std.Antisymm (¬ · < · : β → β → Prop)]
     {xs ys : Vector α n} {f : α → β} (w : ∀ x y, x < y → f x < f y) (h : xs ≤ ys) :

src/Init/Tactics.lean

@@ -713,7 +713,7 @@ A `simpArg` is either a `*`, `-lemma` or a simp lemma specification
 meta def simpArg := simpStar.binary `orelse (simpErase.binary `orelse simpLemma)
 
 /-- A simp args list is a list of `simpArg`. This is the main argument to `simp`. -/
-syntax simpArgs := " [" simpArg,* "]"
+syntax simpArgs := " [" simpArg,*,? "]"
 
 /--
 A `dsimpArg` is similar to `simpArg`, but it does not have the `simpStar` form
@@ -722,7 +722,7 @@ because it does not make sense to use hypotheses in `dsimp`.
 meta def dsimpArg := simpErase.binary `orelse simpLemma
 
 /-- A dsimp args list is a list of `dsimpArg`. This is the main argument to `dsimp`. -/
-syntax dsimpArgs := " [" dsimpArg,* "]"
+syntax dsimpArgs := " [" dsimpArg,*,? "]"
 
 /-- The common arguments of `simp?` and `simp?!`. -/
 syntax simpTraceArgsRest := optConfig (discharger)? (&" only")? (simpArgs)? (ppSpace location)?

src/Lean/AddDecl.lean

@@ -177,8 +177,8 @@ where
       catch _ => pure ()
 
 
-def addAndCompile (decl : Declaration) : CoreM Unit := do
+def addAndCompile (decl : Declaration) (logCompileErrors : Bool := true) : CoreM Unit := do
   addDecl decl
-  compileDecl decl
+  compileDecl decl (logErrors := logCompileErrors)
 
 end Lean

src/Lean/Compiler/IR/RC.lean

@@ -8,7 +8,6 @@ module
 prelude
 public import Lean.Runtime
 public import Lean.Compiler.IR.CompilerM
-public import Lean.Compiler.IR.LiveVars
 
 public section
 
@@ -19,17 +18,99 @@ This transformation is applied before lower level optimizations
 that introduce the instructions `release` and `set`
 -/
 
+structure VarProjInfo where
+  parent? : Option VarId
+  children : VarIdSet
+  deriving Inhabited
+
+abbrev VarProjMap := Std.HashMap VarId VarProjInfo
+
+namespace CollectProjInfo
+
+structure State where
+  varMap : VarProjMap := {}
+  borrowedParams : VarIdSet := {}
+
+abbrev M := StateM State
+
+private def visitParam (p : Param) : M Unit :=
+  modify fun s => { s with
+    varMap := s.varMap.insert p.x {
+      parent? := none
+      children := {}
+    }
+    borrowedParams :=
+      if p.borrow && p.ty.isPossibleRef then
+        s.borrowedParams.insert p.x
+      else s.borrowedParams
+  }
+
+private partial def visitFnBody (b : FnBody) : M Unit := do
+  match b with
+  | .vdecl x _ e b =>
+    match e with
+    | .proj _ parent =>
+      modify fun s => { s with
+        varMap := s.varMap.modify parent fun info =>
+          { info with children := info.children.insert x }
+      }
+      modify fun s => { s with
+        varMap := s.varMap.insert x {
+          parent? := some parent
+          children := {}
+        }
+      }
+    | .reset _ x =>
+      if let some (some parent) := (← get).varMap.get? x |>.map (·.parent?) then
+        modify fun s => { s with
+          varMap := s.varMap.modify parent fun info =>
+            { info with children := info.children.erase x }
+        }
+    | _ => pure ()
+    visitFnBody b
+  | .jdecl _ ps v b =>
+    ps.forM visitParam
+    visitFnBody v
+    visitFnBody b
+  | .case _ _ _ alts => alts.forM (visitFnBody ·.body)
+  | _ => if !b.isTerminal then visitFnBody b.body
+
+private partial def collectProjInfo (ps : Array Param) (b : FnBody)
+    : VarProjMap × VarIdSet := Id.run do
+  let ⟨_, { varMap, borrowedParams }⟩ := go |>.run { }
+  return ⟨varMap, borrowedParams⟩
+where go : M Unit := do
+  ps.forM visitParam
+  visitFnBody b
+
+end CollectProjInfo
+
 structure VarInfo where
-  type : IRType
+  isPossibleRef : Bool
+  isDefiniteRef: Bool
   persistent : Bool
-  inheritsBorrowFromParam : Bool
   deriving Inhabited
 
 abbrev VarMap := Std.TreeMap VarId VarInfo (fun x y => compare x.idx y.idx)
 
+structure LiveVars where
+  vars : VarIdSet
+  borrows : VarIdSet := {}
+  deriving Inhabited
+
+@[inline]
+def LiveVars.merge (liveVars1 liveVars2 : LiveVars) : LiveVars :=
+  let vars := liveVars1.vars.merge liveVars2.vars
+  let borrows := liveVars1.borrows.merge liveVars2.borrows
+  { vars, borrows }
+
+abbrev JPLiveVarMap := Std.TreeMap JoinPointId LiveVars (fun x y => compare x.idx y.idx)
+
 structure Context where
   env            : Environment
   decls          : Array Decl
+  borrowedParams : VarIdSet
+  varProjMap     : VarProjMap
   varMap         : VarMap := {}
   jpLiveVarMap   : JPLiveVarMap := {} -- map: join point => live variables
   localCtx       : LocalContext := {} -- we use it to store the join point declarations
@@ -43,31 +124,93 @@ def getVarInfo (ctx : Context) (x : VarId) : VarInfo :=
 def getJPParams (ctx : Context) (j : JoinPointId) : Array Param :=
   ctx.localCtx.getJPParams j |>.get!
 
-def getJPLiveVars (ctx : Context) (j : JoinPointId) : LiveVarSet :=
-  ctx.jpLiveVarMap.get? j |>.getD {}
+@[specialize]
+private partial def addDescendants (ctx : Context) (x : VarId) (s : VarIdSet)
+    (shouldAdd : VarId → Bool := fun _ => true) : VarIdSet :=
+  if let some info := ctx.varProjMap.get? x then
+    info.children.foldl (init := s) fun s child =>
+      let s := if shouldAdd child then s.insert child else s
+      addDescendants ctx child s shouldAdd
+  else s
 
-def mustConsume (ctx : Context) (x : VarId) : Bool :=
-  let info := getVarInfo ctx x
-  info.type.isPossibleRef && !info.inheritsBorrowFromParam
+private def mkRetLiveVars (ctx : Context) : LiveVars :=
+  let borrows := ctx.borrowedParams.foldl (init := {}) fun borrows x =>
+    addDescendants ctx x (borrows.insert x)
+  { vars := {}, borrows }
+
+def getJPLiveVars (ctx : Context) (j : JoinPointId) : LiveVars :=
+  ctx.jpLiveVarMap.get! j
+
+@[specialize]
+private def useVar (ctx : Context) (x : VarId) (liveVars : LiveVars)
+    (shouldBorrow : VarId → Bool := fun _ => true) : LiveVars := Id.run do
+  let ⟨contains, vars⟩ := liveVars.vars.containsThenInsert x
+  let borrows := if contains then
+      liveVars.borrows
+    else
+      addDescendants ctx x liveVars.borrows fun y =>
+        !liveVars.vars.contains y && shouldBorrow y
+  return { vars, borrows }
+
+@[inline]
+private def bindVar (x : VarId) (liveVars : LiveVars) : LiveVars :=
+  let vars := liveVars.vars.erase x
+  let borrows := liveVars.borrows.erase x
+  { vars, borrows }
+
+@[inline]
+private def useArg (ctx : Context) (args : Array Arg) (arg : Arg) (liveVars : LiveVars) : LiveVars :=
+  match arg with
+  | .var x => useVar ctx x liveVars fun y =>
+    args.all fun arg =>
+      match arg with
+      | .var z => y != z
+      | .erased => true
+  | .erased => liveVars
+
+private def useArgs (ctx : Context) (args : Array Arg) (liveVars : LiveVars) : LiveVars :=
+  args.foldl (init := liveVars) fun liveVars arg => useArg ctx args arg liveVars
+
+private def useExpr (ctx : Context) (e : Expr) (liveVars : LiveVars) : LiveVars :=
+  match e with
+  | .proj _ x | .uproj _ x | .sproj _ _ x | .box _ x | .unbox x | .reset _ x | .isShared x =>
+    useVar ctx x liveVars
+  | .ctor _ ys | .fap _ ys | .pap _ ys =>
+    useArgs ctx ys liveVars
+  | .ap x ys | .reuse x _ _ ys =>
+    let liveVars := useVar ctx x liveVars
+    useArgs ctx ys liveVars
+  | .lit _ => liveVars
 
 @[inline] def addInc (ctx : Context) (x : VarId) (b : FnBody) (n := 1) : FnBody :=
   let info := getVarInfo ctx x
-  if n == 0 then b else .inc x n (!info.type.isDefiniteRef) info.persistent b
+  if n == 0 then b else .inc x n (!info.isDefiniteRef) info.persistent b
 
 @[inline] def addDec (ctx : Context) (x : VarId) (b : FnBody) : FnBody :=
   let info := getVarInfo ctx x
-  .dec x 1 (!info.type.isDefiniteRef) info.persistent b
+  .dec x 1 (!info.isDefiniteRef) info.persistent b
 
 private def updateRefUsingCtorInfo (ctx : Context) (x : VarId) (c : CtorInfo) : Context :=
   let m := ctx.varMap
   { ctx with
     varMap := match m.get? x with
-    | some info => m.insert x { info with type := c.type }
-    | none      => m }
+    | some info =>
+      let isPossibleRef := c.type.isPossibleRef
+      let isDefiniteRef := c.type.isDefiniteRef
+      m.insert x { info with isPossibleRef, isDefiniteRef }
+    | none => m
+  }
 
-private def addDecForAlt (ctx : Context) (caseLiveVars altLiveVars : LiveVarSet) (b : FnBody) : FnBody :=
-  caseLiveVars.foldl (init := b) fun b x =>
-    if !altLiveVars.contains x && mustConsume ctx x then addDec ctx x b else b
+private def addDecForAlt (ctx : Context) (caseLiveVars altLiveVars : LiveVars) (b : FnBody) : FnBody :=
+  caseLiveVars.vars.foldl (init := b) fun b x =>
+    let info := getVarInfo ctx x
+    if !altLiveVars.vars.contains x then
+      if info.isPossibleRef && !caseLiveVars.borrows.contains x then
+        addDec ctx x b
+      else b
+    else if caseLiveVars.borrows.contains x && !altLiveVars.borrows.contains x then
+      addInc ctx x b
+    else b
 
 /-- `isFirstOcc xs x i = true` if `xs[i]` is the first occurrence of `xs[i]` in `xs` -/
 private def isFirstOcc (xs : Array Arg) (i : Nat) : Bool :=
@@ -98,29 +241,29 @@ private def getNumConsumptions (x : VarId) (ys : Array Arg) (consumeParamPred :
     | .erased => n
     | .var y  => if x == y && consumeParamPred i then n+1 else n
 
-private def addIncBeforeAux (ctx : Context) (xs : Array Arg) (consumeParamPred : Nat → Bool) (b : FnBody) (liveVarsAfter : LiveVarSet) : FnBody :=
+private def addIncBeforeAux (ctx : Context) (xs : Array Arg) (consumeParamPred : Nat → Bool) (b : FnBody) (liveVarsAfter : LiveVars) : FnBody :=
   xs.size.fold (init := b) fun i _ b =>
     let x := xs[i]
     match x with
     | .erased => b
     | .var x =>
       let info := getVarInfo ctx x
-      if !info.type.isPossibleRef || !isFirstOcc xs i then b
+      if !info.isPossibleRef || !isFirstOcc xs i then b
       else
         let numConsumptions := getNumConsumptions x xs consumeParamPred
         let numIncs :=
-          if info.inheritsBorrowFromParam ||
-             liveVarsAfter.contains x ||          -- `x` is live after executing instruction
+          if liveVarsAfter.vars.contains x ||          -- `x` is live after executing instruction
+             liveVarsAfter.borrows.contains x ||
              isBorrowParamAux x xs consumeParamPred  -- `x` is used in a position that is passed as a borrow reference
           then numConsumptions
           else numConsumptions - 1
         addInc ctx x b numIncs
 
-private def addIncBefore (ctx : Context) (xs : Array Arg) (ps : Array Param) (b : FnBody) (liveVarsAfter : LiveVarSet) : FnBody :=
+private def addIncBefore (ctx : Context) (xs : Array Arg) (ps : Array Param) (b : FnBody) (liveVarsAfter : LiveVars) : FnBody :=
   addIncBeforeAux ctx xs (fun i => ! ps[i]!.borrow) b liveVarsAfter
 
 /-- See `addIncBeforeAux`/`addIncBefore` for the procedure that inserts `inc` operations before an application.  -/
-private def addDecAfterFullApp (ctx : Context) (xs : Array Arg) (ps : Array Param) (b : FnBody) (bLiveVars : LiveVarSet) : FnBody :=
+private def addDecAfterFullApp (ctx : Context) (xs : Array Arg) (ps : Array Param) (b : FnBody) (bLiveVars : LiveVars) : FnBody :=
   xs.size.fold (init := b) fun i _ b =>
     match xs[i] with
     | .erased => b
@@ -129,22 +272,27 @@ private def addDecAfterFullApp (ctx : Context) (xs : Array Arg) (ps : Array Para
         and it has been borrowed by the application.
         Remark: `x` may occur multiple times in the application (e.g., `f x y x`).
         This is why we check whether it is the first occurrence. -/
-      if mustConsume ctx x && isFirstOcc xs i && isBorrowParam x xs ps && !bLiveVars.contains x then
+      let info := getVarInfo ctx x
+      if info.isPossibleRef &&
+         isFirstOcc xs i &&
+         isBorrowParam x xs ps &&
+         !bLiveVars.vars.contains x &&
+         !bLiveVars.borrows.contains x then
         addDec ctx x b
       else b
 
-private def addIncBeforeConsumeAll (ctx : Context) (xs : Array Arg) (b : FnBody) (liveVarsAfter : LiveVarSet) : FnBody :=
+private def addIncBeforeConsumeAll (ctx : Context) (xs : Array Arg) (b : FnBody) (liveVarsAfter : LiveVars) : FnBody :=
   addIncBeforeAux ctx xs (fun _ => true) b liveVarsAfter
 
 /-- Add `dec` instructions for parameters that are references, are not alive in `b`, and are not borrow.
    That is, we must make sure these parameters are consumed. -/
-private def addDecForDeadParams (ctx : Context) (ps : Array Param) (b : FnBody) (bLiveVars : LiveVarSet) : FnBody × LiveVarSet :=
+private def addDecForDeadParams (ctx : Context) (ps : Array Param) (b : FnBody) (bLiveVars : LiveVars) : FnBody × LiveVars :=
   ps.foldl (init := ⟨b, bLiveVars⟩) fun ⟨b, bLiveVars⟩ p =>
     let b :=
-      if !p.borrow && p.ty.isPossibleRef && !bLiveVars.contains p.x then
+      if !p.borrow && p.ty.isPossibleRef && !bLiveVars.vars.contains p.x then
         addDec ctx p.x b
       else b
-    let bLiveVars := bLiveVars.erase p.x
+    let bLiveVars := bindVar p.x bLiveVars
     ⟨b, bLiveVars⟩
 
 private def isPersistent : Expr → Bool
@@ -165,30 +313,32 @@ private def typeForScalarBoxedInTaggedPtr? (v : Expr) : Option IRType :=
   | _ => none
 
 private def updateVarInfo (ctx : Context) (x : VarId) (t : IRType) (v : Expr) : Context :=
-  let inheritsBorrowFromParam :=
-    match v with
-    | .proj _ x => match ctx.varMap.get? x with
-      | some info => info.inheritsBorrowFromParam
-      | none => false
-    | _ => false
+  let type := typeForScalarBoxedInTaggedPtr? v |>.getD t
+  let isPossibleRef := type.isPossibleRef
+  let isDefiniteRef := type.isDefiniteRef
   { ctx with
     varMap := ctx.varMap.insert x {
-        type := typeForScalarBoxedInTaggedPtr? v |>.getD t
+        isPossibleRef
+        isDefiniteRef
         persistent := isPersistent v,
-        inheritsBorrowFromParam
     }
   }
 
-private def addDecIfNeeded (ctx : Context) (x : VarId) (b : FnBody) (bLiveVars : LiveVarSet) : FnBody :=
-  if mustConsume ctx x && !bLiveVars.contains x then addDec ctx x b else b
+private def addDecIfNeeded (ctx : Context) (x : VarId) (b : FnBody) (bLiveVars : LiveVars) : FnBody :=
+  let info := getVarInfo ctx x
+  if info.isPossibleRef &&
+     !bLiveVars.vars.contains x &&
+     !bLiveVars.borrows.contains x then
+    addDec ctx x b
+  else b
 
-private def processVDecl (ctx : Context) (z : VarId) (t : IRType) (v : Expr) (b : FnBody) (bLiveVars : LiveVarSet) : FnBody × LiveVarSet :=
+private def processVDecl (ctx : Context) (z : VarId) (t : IRType) (v : Expr) (b : FnBody) (bLiveVars : LiveVars) : FnBody × LiveVars :=
   let b := match v with
     | .ctor _ ys | .reuse _ _ _ ys | .pap _ ys =>
       addIncBeforeConsumeAll ctx ys (.vdecl z t v b) bLiveVars
     | .proj _ x =>
       let b := addDecIfNeeded ctx x b bLiveVars
-      let b := if !(getVarInfo ctx x).inheritsBorrowFromParam then addInc ctx z b else b
+      let b := if !bLiveVars.borrows.contains z then addInc ctx z b else b
       .vdecl z t v b
     | .uproj _ x | .sproj _ _ x | .unbox x =>
       .vdecl z t v (addDecIfNeeded ctx x b bLiveVars)
@@ -202,16 +352,19 @@ private def processVDecl (ctx : Context) (z : VarId) (t : IRType) (v : Expr) (b
       addIncBeforeConsumeAll ctx ysx (.vdecl z t v b) bLiveVars
     | .lit _ | .box .. | .reset .. | .isShared _ =>
       .vdecl z t v b
-  let liveVars := updateLiveVars v bLiveVars
-  let liveVars := liveVars.erase z
+  let liveVars := useExpr ctx v bLiveVars
+  let liveVars := bindVar z liveVars
   ⟨b, liveVars⟩
 
 def updateVarInfoWithParams (ctx : Context) (ps : Array Param) : Context :=
   let m := ps.foldl (init := ctx.varMap) fun m p =>
-    m.insert p.x { type := p.ty, persistent := false, inheritsBorrowFromParam := p.borrow }
+    m.insert p.x {
+      isPossibleRef := p.ty.isPossibleRef
+      isDefiniteRef := p.ty.isDefiniteRef
+      persistent := false }
   { ctx with varMap := m }
 
-partial def visitFnBody (b : FnBody) (ctx : Context) : FnBody × LiveVarSet :=
+partial def visitFnBody (b : FnBody) (ctx : Context) : FnBody × LiveVars :=
   match b with
   | .vdecl x t v b =>
     let ctx := updateVarInfo ctx x t v
@@ -230,15 +383,15 @@ partial def visitFnBody (b : FnBody) (ctx : Context) : FnBody × LiveVarSet :=
   | .uset x i y b =>
     let ⟨b, s⟩ := visitFnBody b ctx
     -- We don't need to insert `y` since we only need to track live variables that are references at runtime
-    let s      := s.insert x
+    let s := useVar ctx x s
     ⟨.uset x i y b, s⟩
   | .sset x i o y t b =>
     let ⟨b, s⟩ := visitFnBody b ctx
     -- We don't need to insert `y` since we only need to track live variables that are references at runtime
-    let s      := s.insert x
+    let s := useVar ctx x s
     ⟨.sset x i o y t b, s⟩
   | .case tid x xType alts =>
-    let alts : Array (Alt × LiveVarSet) := alts.map fun alt => match alt with
+    let alts : Array (Alt × LiveVars) := alts.map fun alt => match alt with
       | .ctor c b =>
         let ctx := updateRefUsingCtorInfo ctx x c
         let ⟨b, altLiveVars⟩ := visitFnBody b ctx
@@ -246,9 +399,10 @@ partial def visitFnBody (b : FnBody) (ctx : Context) : FnBody × LiveVarSet :=
       | .default b =>
         let ⟨b, altLiveVars⟩ := visitFnBody b ctx
         ⟨.default b, altLiveVars⟩
-    let caseLiveVars : LiveVarSet := alts.foldl (init := {}) fun liveVars ⟨_, altLiveVars⟩ =>
-      liveVars.merge altLiveVars
-    let caseLiveVars := caseLiveVars.insert x
+    let caseLiveVars := alts.foldl (init := { vars := {}, borrows := {} })
+      fun liveVars ⟨_, altLiveVars⟩ =>
+        liveVars.merge altLiveVars
+    let caseLiveVars := useVar ctx x caseLiveVars
     let alts := alts.map fun ⟨alt, altLiveVars⟩ => match alt with
       | .ctor c b =>
         let ctx := updateRefUsingCtorInfo ctx x c
@@ -258,29 +412,32 @@ partial def visitFnBody (b : FnBody) (ctx : Context) : FnBody × LiveVarSet :=
         let b := addDecForAlt ctx caseLiveVars altLiveVars b
         .default b
     ⟨.case tid x xType alts, caseLiveVars⟩
-  | .ret x =>
-    match x with
-    | .var x =>
-      let info := getVarInfo ctx x
-      let b :=
-        if info.type.isPossibleRef && info.inheritsBorrowFromParam then
-          addInc ctx x b
-        else b
-      ⟨b, mkLiveVarSet x⟩
-    | .erased => ⟨b, {}⟩
   | .jmp j xs =>
     let jLiveVars := getJPLiveVars ctx j
     let ps        := getJPParams ctx j
     let b         := addIncBefore ctx xs ps b jLiveVars
-    let bLiveVars := collectLiveVars b ctx.jpLiveVarMap
+    let bLiveVars := useArgs ctx xs jLiveVars
     ⟨b, bLiveVars⟩
-  | .unreachable => ⟨.unreachable, {}⟩
-  | _ => ⟨b, {}⟩ -- unreachable if well-formed
+  | .ret x =>
+    let liveVars := mkRetLiveVars ctx
+    match x with
+    | .var x =>
+      let info := ctx.varMap.get! x
+      let liveVars := useVar ctx x liveVars
+      let b :=
+        if info.isPossibleRef && liveVars.borrows.contains x then
+          addInc ctx x b
+        else b
+      ⟨b, liveVars⟩
+    | .erased => ⟨b, liveVars⟩
+  | .unreachable => ⟨.unreachable, mkRetLiveVars ctx⟩
+  | .set .. | .setTag .. | .inc .. | .dec .. | .del .. => unreachable!
 
 partial def visitDecl (env : Environment) (decls : Array Decl) (d : Decl) : Decl :=
   match d with
   | .fdecl (xs := xs) (body := b) .. =>
-    let ctx := updateVarInfoWithParams { env, decls } xs
+    let ⟨varProjMap, borrowedParams⟩ := CollectProjInfo.collectProjInfo xs b
+    let ctx := updateVarInfoWithParams { env, decls, borrowedParams, varProjMap } xs
     let ⟨b, bLiveVars⟩ := visitFnBody b ctx
     let ⟨b, _⟩ := addDecForDeadParams ctx xs b bLiveVars
     d.updateBody! b

src/Lean/Compiler/LCNF/CompilerM.lean

@@ -23,7 +23,7 @@ inductive Phase where
   | base
   /-- In this phase polymorphism has been eliminated. -/
   | mono
-  deriving Inhabited
+  deriving Inhabited, BEq
 
 /--
 The state managed by the `CompilerM` `Monad`.

src/Lean/Compiler/LCNF/Main.lean

@@ -108,20 +108,31 @@ def run (declNames : Array Name) : CompilerM (Array IR.Decl) := withAtLeastMaxRe
       if let some info ← getDeclInfo? declName then
         if !(isValidMainType info.type) then
           throwError "`main` function must have type `(List String →)? IO (UInt32 | Unit | PUnit)`"
-  let mut decls ← declNames.mapM toDecl
-  decls := markRecDecls decls
+  let decls ← declNames.mapM toDecl
+  let decls := markRecDecls decls
   let manager ← getPassManager
   let isCheckEnabled := compiler.check.get (← getOptions)
-  for pass in manager.passes do
-    decls ← withTraceNode `Compiler (fun _ => return m!"compiler phase: {pass.phase}, pass: {pass.name}") do
-      withPhase pass.phase <| pass.run decls
-    withPhase pass.phaseOut <| checkpoint pass.name decls (isCheckEnabled || pass.shouldAlwaysRunCheck)
+  let decls ← profileitM Exception "compilation (LCNF base)" (← getOptions) do
+    let mut decls := decls
+    for pass in manager.basePasses do
+      decls ← withTraceNode `Compiler (fun _ => return m!"compiler phase: {pass.phase}, pass: {pass.name}") do
+        withPhase pass.phase <| pass.run decls
+      withPhase pass.phaseOut <| checkpoint pass.name decls (isCheckEnabled || pass.shouldAlwaysRunCheck)
+    return decls
+  let decls ← profileitM Exception "compilation (LCNF mono)" (← getOptions) do
+    let mut decls := decls
+    for pass in manager.monoPasses do
+      decls ← withTraceNode `Compiler (fun _ => return m!"compiler phase: {pass.phase}, pass: {pass.name}") do
+        withPhase pass.phase <| pass.run decls
+      withPhase pass.phaseOut <| checkpoint pass.name decls (isCheckEnabled || pass.shouldAlwaysRunCheck)
+    return decls
   if (← Lean.isTracingEnabledFor `Compiler.result) then
     for decl in decls do
       let decl ← normalizeFVarIds decl
       Lean.addTrace `Compiler.result m!"size: {decl.size}\n{← ppDecl' decl}"
-  let irDecls ← IR.toIR decls
-  IR.compile irDecls
+  profileitM Exception "compilation (IR)" (← getOptions) do
+    let irDecls ← IR.toIR decls
+    IR.compile irDecls
 
 end PassManager
 
@@ -134,9 +145,8 @@ def showDecl (phase : Phase) (declName : Name) : CoreM Format := do
 
 @[export lean_lcnf_compile_decls]
 def main (declNames : Array Name) : CoreM Unit := do
-  profileitM Exception "compilation" (← getOptions) do
-    withTraceNode `Compiler (fun _ => return m!"compiling: {declNames}") do
-      CompilerM.run <| discard <| PassManager.run declNames
+  withTraceNode `Compiler (fun _ => return m!"compiling: {declNames}") do
+    CompilerM.run <| discard <| PassManager.run declNames
 
 builtin_initialize
   registerTraceClass `Compiler.init (inherited := true)

src/Lean/Compiler/LCNF/PassManager.lean

@@ -73,6 +73,8 @@ Can be used to install, remove, replace etc. passes by tagging a declaration
 of type `PassInstaller` with the `cpass` attribute.
 -/
 structure PassInstaller where
+  /-- Affected phase. -/
+  phase : Phase
   /--
   When the installer is run this function will receive a list of all
   current `Pass`es and return a new one, this can modify the list (and
@@ -86,7 +88,8 @@ The `PassManager` used to store all `Pass`es that will be run within
 pipeline.
 -/
 structure PassManager where
-  passes : Array Pass
+  basePasses : Array Pass
+  monoPasses : Array Pass
   deriving Inhabited
 
 instance : ToString Phase where
@@ -106,40 +109,51 @@ end Pass
 
 namespace PassManager
 
-def validate (manager : PassManager) : CoreM Unit := do
-  let mut current := .base
-  for pass in manager.passes do
-    if ¬(current ≤ pass.phase) then
-      throwError s!"{pass.name} has phase {pass.phase} but should at least have {current}"
-    current := pass.phase
+private def validatePasses (phase : Phase) (passes : Array Pass) : CoreM Unit := do
+  for pass in passes do
+    if pass.phase != phase then
+      throwError s!"{pass.name} has phase {pass.phase} but should have {phase}"
 
-def findHighestOccurrence (targetName : Name) (passes : Array Pass) : CoreM Nat := do
+def validate (manager : PassManager) : CoreM Unit := do
+  validatePasses .base manager.basePasses
+  validatePasses .mono manager.monoPasses
+
+def findOccurrenceBounds (targetName : Name) (passes : Array Pass) : CoreM (Nat × Nat) := do
+  let mut lowest := none
   let mut highest := none
   for pass in passes do
       if pass.name == targetName then
+        lowest := if lowest.isNone then some pass.occurrence else lowest
         highest := some pass.occurrence
-  let some val := highest | throwError s!"Could not find any occurrence of {targetName}"
-  return val
+  let ⟨some lowestVal, some highestVal⟩ := Prod.mk lowest highest | throwError s!"Could not find any occurrence of {targetName}"
+  return ⟨lowestVal, highestVal⟩
 
 end PassManager
 
 namespace PassInstaller
 
-def installAtEnd (p : Pass) : PassInstaller where
+def installAtEnd (phase : Phase) (p : Pass) : PassInstaller where
+  phase
   install passes := return passes.push p
 
-def append (passesNew : Array Pass) : PassInstaller where
+def append (phase : Phase) (passesNew : Array Pass) : PassInstaller where
+  phase
   install passes := return passes ++ passesNew
 
-def withEachOccurrence (targetName : Name) (f : Nat → PassInstaller) : PassInstaller where
+def withEachOccurrence (phase : Phase) (targetName : Name) (f : Nat → PassInstaller) : PassInstaller where
+  phase
   install passes := do
-    let highestOccurrence ← PassManager.findHighestOccurrence targetName passes
+    let ⟨lowestOccurrence, highestOccurrence⟩ ← PassManager.findOccurrenceBounds targetName passes
     let mut passes := passes
-    for occurrence in *...=highestOccurrence do
-      passes ← f occurrence |>.install passes
+    for occurrence in lowestOccurrence...=highestOccurrence do
+      let installer := f occurrence
+      if installer.phase != phase then
+        panic! "phase mismatch"
+      passes ← installer.install passes
     return passes
 
-def installAfter (targetName : Name) (p : Pass → Pass) (occurrence : Nat := 0) : PassInstaller where
+def installAfter (phase : Phase) (targetName : Name) (p : Pass → Pass) (occurrence : Nat := 0) : PassInstaller where
+  phase
   install passes :=
     if let some idx := passes.findFinIdx? (fun p => p.name == targetName && p.occurrence == occurrence) then
       let passUnderTest := passes[idx]
@@ -147,10 +161,11 @@ def installAfter (targetName : Name) (p : Pass → Pass) (occurrence : Nat := 0)
     else
       throwError s!"Tried to insert pass after {targetName}, occurrence {occurrence} but {targetName} is not in the pass list"
 
-def installAfterEach (targetName : Name) (p : Pass → Pass) : PassInstaller :=
-    withEachOccurrence targetName (installAfter targetName p ·)
+def installAfterEach (phase : Phase) (targetName : Name) (p : Pass → Pass) : PassInstaller :=
+    withEachOccurrence phase targetName (installAfter phase targetName p ·)
 
-def installBefore (targetName : Name) (p : Pass → Pass) (occurrence : Nat := 0): PassInstaller where
+def installBefore (phase : Phase) (targetName : Name) (p : Pass → Pass) (occurrence : Nat := 0): PassInstaller where
+  phase
   install passes :=
     if let some idx := passes.findFinIdx? (fun p => p.name == targetName && p.occurrence == occurrence) then
       let passUnderTest := passes[idx]
@@ -158,19 +173,24 @@ def installBefore (targetName : Name) (p : Pass → Pass) (occurrence : Nat := 0
     else
       throwError s!"Tried to insert pass after {targetName}, occurrence {occurrence} but {targetName} is not in the pass list"
 
-def installBeforeEachOccurrence (targetName : Name) (p : Pass → Pass) : PassInstaller :=
-    withEachOccurrence targetName (installBefore targetName p ·)
+def installBeforeEachOccurrence (phase : Phase) (targetName : Name) (p : Pass → Pass) : PassInstaller :=
+    withEachOccurrence phase targetName (installBefore phase targetName p ·)
 
-def replacePass (targetName : Name) (p : Pass → Pass) (occurrence : Nat := 0) : PassInstaller where
+def replacePass (phase : Phase) (targetName : Name) (p : Pass → Pass) (occurrence : Nat := 0) : PassInstaller where
+  phase
   install passes := do
     let some idx := passes.findIdx? (fun p => p.name == targetName && p.occurrence == occurrence) | throwError s!"Tried to replace {targetName}, occurrence {occurrence} but {targetName} is not in the pass list"
     return passes.modify idx p
 
-def replaceEachOccurrence (targetName : Name) (p : Pass → Pass) : PassInstaller :=
-    withEachOccurrence targetName (replacePass targetName p ·)
+def replaceEachOccurrence (phase : Phase) (targetName : Name) (p : Pass → Pass) : PassInstaller :=
+    withEachOccurrence phase targetName (replacePass phase targetName p ·)
 
 def run (manager : PassManager) (installer : PassInstaller) : CoreM PassManager := do
-  return { manager with passes := (← installer.install manager.passes) }
+  match installer.phase with
+  | .base =>
+    return { manager with basePasses := (← installer.install manager.basePasses) }
+  | .mono =>
+    return { manager with monoPasses := (← installer.install manager.monoPasses) }
 
 private unsafe def getPassInstallerUnsafe (declName : Name) : CoreM PassInstaller := do
   ofExcept <| (← getEnv).evalConstCheck PassInstaller (← getOptions) ``PassInstaller declName
@@ -180,7 +200,7 @@ private opaque getPassInstaller (declName : Name) : CoreM PassInstaller
 
 def runFromDecl (manager : PassManager) (declName : Name) : CoreM PassManager := do
   let installer ← getPassInstaller declName
-  let newState ← installer.run manager
+  let newState ← PassInstaller.run manager installer
   newState.validate
   return newState
 

src/Lean/Compiler/LCNF/Passes.lean

@@ -69,7 +69,7 @@ end Pass
 open Pass
 
 def builtinPassManager : PassManager := {
-  passes := #[
+  basePasses := #[
     init,
     pullInstances,
     cse (shouldElimFunDecls := false),
@@ -93,6 +93,8 @@ def builtinPassManager : PassManager := {
     -- pass must be run for each phase; see `base/monoTransparentDeclsExt`
     inferVisibility (phase := .base),
     toMono,
+  ]
+  monoPasses := #[
     simp (occurrence := 3) (phase := .mono),
     reduceJpArity (phase := .mono),
     structProjCases,

src/Lean/Compiler/LCNF/Simp/InlineProj.lean

@@ -75,7 +75,7 @@ where
         let some decl ← getDecl? declName | failure
         match decl.value with
         | .code code =>
-          guard (decl.getArity == args.size)
+          guard (!decl.recursive && decl.getArity == args.size)
           let params := decl.instantiateParamsLevelParams us
           let code := code.instantiateValueLevelParams decl.levelParams us
           let code ← betaReduce params code args (mustInline := true)

src/Lean/Compiler/LCNF/Testing.lean

@@ -110,35 +110,35 @@ private def assertAfterTest (test : SimpleTest) : TestInstallerM (Pass → Pass)
 Install an assertion pass right after a specific occurrence of a pass,
 default is first.
 -/
-def assertAfter (test : SimpleTest) (occurrence : Nat := 0): TestInstaller := do
+def assertAfter (phase : Phase) (test : SimpleTest) (occurrence : Nat := 0): TestInstaller := do
   let passUnderTestName := (←read).passUnderTestName
   let assertion ← assertAfterTest test
-  return .installAfter passUnderTestName assertion occurrence
+  return .installAfter phase passUnderTestName assertion occurrence
 
 /--
 Install an assertion pass right after each occurrence of a pass.
 -/
-def assertAfterEachOccurrence (test : SimpleTest) : TestInstaller := do
+def assertAfterEachOccurrence (phase : Phase) (test : SimpleTest) : TestInstaller := do
   let passUnderTestName := (←read).passUnderTestName
   let assertion ← assertAfterTest test
-  return .installAfterEach passUnderTestName assertion
+  return .installAfterEach phase passUnderTestName assertion
 
 /--
 Install an assertion pass right after a specific occurrence of a pass,
 default is first. The assertion operates on a per declaration basis.
 -/
-def assertForEachDeclAfter (assertion : Pass → Decl → Bool) (msg : String) (occurrence : Nat := 0) : TestInstaller :=
+def assertForEachDeclAfter (phase : Phase) (assertion : Pass → Decl → Bool) (msg : String) (occurrence : Nat := 0) : TestInstaller :=
   let assertion := do
     let pass ← getPassUnderTest
     (←getDecls).forM (fun decl => assert (assertion pass decl) msg)
-  assertAfter assertion occurrence
+  assertAfter phase assertion occurrence
 
 /--
 Install an assertion pass right after the each occurrence of a pass. The
 assertion operates on a per declaration basis.
 -/
-def assertForEachDeclAfterEachOccurrence (assertion : Pass → Decl → Bool) (msg : String) : TestInstaller :=
-  assertAfterEachOccurrence <| do
+def assertForEachDeclAfterEachOccurrence (phase : Phase) (assertion : Pass → Decl → Bool) (msg : String) : TestInstaller :=
+  assertAfterEachOccurrence phase <| do
     let pass ← getPassUnderTest
     (←getDecls).forM (fun decl => assert (assertion pass decl) msg)
 
@@ -160,20 +160,20 @@ Replace a specific occurrence, default is first, of a pass with a wrapper one th
 the user to provide an assertion which takes into account both the
 declarations that were sent to and produced by the pass under test.
 -/
-def assertAround (test : InOutTest) (occurrence : Nat := 0) : TestInstaller := do
+def assertAround (phase : Phase) (test : InOutTest) (occurrence : Nat := 0) : TestInstaller := do
   let passUnderTestName := (←read).passUnderTestName
   let assertion ← assertAroundTest test
-  return .replacePass passUnderTestName assertion occurrence
+  return .replacePass phase passUnderTestName assertion occurrence
 
 /--
 Replace all occurrences of a pass with a wrapper one that allows
 the user to provide an assertion which takes into account both the
 declarations that were sent to and produced by the pass under test.
 -/
-def assertAroundEachOccurrence (test : InOutTest) : TestInstaller := do
+def assertAroundEachOccurrence (phase : Phase) (test : InOutTest) : TestInstaller := do
   let passUnderTestName := (←read).passUnderTestName
   let assertion ← assertAroundTest test
-  return .replaceEachOccurrence passUnderTestName assertion
+  return .replaceEachOccurrence phase passUnderTestName assertion
 
 private def throwFixPointError (err : String) (firstResult secondResult : Array Decl) : CompilerM Unit := do
   let mut err := err
@@ -189,7 +189,7 @@ Insert a pass after `passUnderTestName`, that ensures, that if
 `passUnderTestName` is executed twice in a row, no change in the resulting
 expression will occur, i.e. the pass is at a fix point.
 -/
-def assertIsAtFixPoint : TestInstaller :=
+def assertIsAtFixPoint (phase : Phase) : TestInstaller :=
   let test := do
     let passUnderTest ← getPassUnderTest
     let decls ← getDecls
@@ -203,51 +203,51 @@ def assertIsAtFixPoint : TestInstaller :=
     else if decls != secondResult then
       let err := s!"Pass {passUnderTest.name} did not reach a fixpoint, it either changed declarations or their order:\n"
       throwFixPointError err decls secondResult
-  assertAfterEachOccurrence test
+  assertAfterEachOccurrence phase test
 
 /--
 Compare the overall sizes of the input and output of `passUnderTest` with `assertion`.
 If `assertion inputSize outputSize` is `false` throw an exception with `msg`.
 -/
-def assertSize (assertion : Nat → Nat → Bool) (msg : String) : TestInstaller :=
+def assertSize (phase : Phase) (assertion : Nat → Nat → Bool) (msg : String) : TestInstaller :=
   let sumDeclSizes := fun decls => decls.map Decl.size |>.foldl (init := 0) (· + ·)
   let assertion := (fun inputS outputS => Testing.assert (assertion inputS outputS) s!"{msg}: input size {inputS} output size {outputS}")
-  assertAroundEachOccurrence (do assertion (sumDeclSizes (←getInputDecls)) (sumDeclSizes (←getOutputDecls)))
+  assertAroundEachOccurrence phase (do assertion (sumDeclSizes (←getInputDecls)) (sumDeclSizes (←getOutputDecls)))
 
 /--
 Assert that the overall size of the `Decl`s in the compilation pipeline does not change
 after `passUnderTestName`.
 -/
-def assertPreservesSize (msg : String) : TestInstaller :=
-  assertSize (· == ·) msg
+def assertPreservesSize (phase : Phase) (msg : String) : TestInstaller :=
+  assertSize phase (· == ·) msg
 
 /--
 Assert that the overall size of the `Decl`s in the compilation pipeline gets reduced by `passUnderTestName`.
 -/
-def assertReducesSize (msg : String) : TestInstaller :=
-  assertSize (· > ·) msg
+def assertReducesSize (phase : Phase) (msg : String) : TestInstaller :=
+  assertSize phase (· > ·) msg
 
 /--
 Assert that the overall size of the `Decl`s in the compilation pipeline gets reduced or stays unchanged
 by `passUnderTestName`.
 -/
-def assertReducesOrPreservesSize (msg : String) : TestInstaller :=
-  assertSize (· ≥ ·) msg
+def assertReducesOrPreservesSize (phase : Phase) (msg : String) : TestInstaller :=
+  assertSize phase (· ≥ ·) msg
 
 /--
 Assert that the pass under test produces `Decl`s that do not contain
 `Expr.const constName` in their `Code.let` values anymore.
 -/
-def assertDoesNotContainConstAfter (constName : Name) (msg : String) : TestInstaller :=
-  assertForEachDeclAfterEachOccurrence
+def assertDoesNotContainConstAfter (phase : Phase) (constName : Name) (msg : String) : TestInstaller :=
+  assertForEachDeclAfterEachOccurrence phase
     fun _ decl =>
       match decl.value with
       | .code c => !c.containsConst constName
       | .extern .. => true
     msg
 
-def assertNoFun : TestInstaller :=
-  assertAfter do
+def assertNoFun (phase : Phase) : TestInstaller :=
+  assertAfter phase do
     for decl in (← getDecls) do
       decl.value.forCodeM fun
         | .fun .. => throwError "declaration `{decl.name}` contains a local function declaration"

src/Lean/Compiler/LCNF/ToMono.lean

@@ -90,8 +90,18 @@ partial def LetValue.toMono (e : LetValue) (resultFVar : FVarId) : ToMonoM LetVa
       -- Decidable.decide is the identity function since Decidable
       -- and Bool have the same runtime representation.
       return args[1]!.toLetValue
-    else if declName == ``Quot.mk || declName == ``Quot.lcInv then
+    else if declName == ``Quot.mk then
       return args[2]!.toLetValue
+    else if declName == ``Quot.lcInv then
+      match args[2]! with
+      | .fvar fvarId =>
+        let mut extraArgs : Array Arg := .emptyWithCapacity (args.size - 3)
+        for i in 3...args.size do
+          let arg ← argToMono args[i]!
+          extraArgs := extraArgs.push arg
+        return .fvar fvarId extraArgs
+      | .erased | .type _ =>
+        return .erased
     else if declName == ``Nat.zero then
       return .lit (.nat 0)
     else if declName == ``Nat.succ then

src/Lean/CoreM.lean

@@ -570,8 +570,8 @@ register_builtin_option stderrAsMessages : Bool := {
 Creates snapshot reporting given `withIsolatedStreams` output and diagnostics and traces from the
 given state.
 -/
-def mkSnapshot (output : String) (ctx : Context) (st : State)
-    (desc : String := by exact decl_name%.toString) : BaseIO Language.SnapshotTree := do
+def mkSnapshot? (output : String) (ctx : Context) (st : State)
+    (desc : String := by exact decl_name%.toString) : BaseIO (Option Language.SnapshotTree) := do
   let mut msgs := st.messages
   if !output.isEmpty then
     msgs := msgs.add {
@@ -580,7 +580,9 @@ def mkSnapshot (output : String) (ctx : Context) (st : State)
       pos      := ctx.fileMap.toPosition <| ctx.ref.getPos?.getD 0
       data     := output
     }
-  return .mk {
+  if !msgs.hasUnreported && st.traceState.traces.isEmpty && st.snapshotTasks.isEmpty then
+    return none
+  return some <| .mk {
     desc
     diagnostics := (← Language.Snapshot.Diagnostics.ofMessageLog msgs)
     traces := st.traceState
@@ -617,7 +619,8 @@ def wrapAsyncAsSnapshot {α : Type} (act : α → CoreM Unit) (cancelTk? : Optio
   let ctx ← readThe Core.Context
   return fun a => do
     match (← (f a).toBaseIO) with
-    | .ok (output, st) => mkSnapshot output ctx st desc
+    | .ok (output, st) =>
+      return (← mkSnapshot? output ctx st desc).getD (toSnapshotTree (default : SnapshotLeaf))
     -- interrupt or abort exception as `try catch` above should have caught any others
     | .error _ => default
 

src/Lean/Elab/BuiltinNotation.lean

@@ -556,13 +556,12 @@ def elabUnsafe : TermElab := fun stx expectedType? =>
     let .const unsafeFn unsafeLvls .. := t.getAppFn | unreachable!
     let .defnInfo unsafeDefn ← getConstInfo unsafeFn | unreachable!
     let implName ← mkAuxName `unsafe_impl
-    addDecl <| Declaration.defnDecl {
+    addDecl <| Declaration.opaqueDecl {
       name        := implName
       type        := unsafeDefn.type
       levelParams := unsafeDefn.levelParams
       value       := (← mkOfNonempty unsafeDefn.type)
-      hints       := .opaque
-      safety      := .safe
+      isUnsafe    := false
     }
     setImplementedBy implName unsafeFn
     return mkAppN (Lean.mkConst implName unsafeLvls) t.getAppArgs

src/Lean/Elab/DeclModifiers.lean

@@ -49,26 +49,21 @@ def checkNotAlreadyDeclared {m} [Monad m] [MonadEnv m] [MonadError m] [MonadFina
       addInfo declName
       throwError "a non-private declaration '{.ofConstName declName true}' has already been declared"
 
-/-- Declaration visibility modifier. That is, whether a declaration is regular, protected or private. -/
+/-- Declaration visibility modifier. That is, whether a declaration is public or private or inherits its visibility from the outer scope. -/
 inductive Visibility where
-  | regular | «protected» | «private» | «public»
+  | regular | «private» | «public»
   deriving Inhabited
 
 instance : ToString Visibility where
   toString
     | .regular   => "regular"
     | .private   => "private"
-    | .protected => "protected"
     | .public    => "public"
 
 def Visibility.isPrivate : Visibility → Bool
   | .private   => true
   | _          => false
 
-def Visibility.isProtected : Visibility → Bool
-  | .protected => true
-  | _          => false
-
 def Visibility.isPublic : Visibility → Bool
   | .public    => true
   | _          => false
@@ -92,6 +87,7 @@ structure Modifiers where
   stx             : TSyntax ``Parser.Command.declModifiers := ⟨.missing⟩
   docString?      : Option (TSyntax ``Parser.Command.docComment) := none
   visibility      : Visibility := Visibility.regular
+  isProtected     : Bool := false
   computeKind     : ComputeKind := .regular
   recKind         : RecKind := RecKind.default
   isUnsafe        : Bool := false
@@ -99,7 +95,6 @@ structure Modifiers where
   deriving Inhabited
 
 def Modifiers.isPrivate (m : Modifiers) : Bool := m.visibility.isPrivate
-def Modifiers.isProtected (m : Modifiers) : Bool := m.visibility.isProtected
 def Modifiers.isPublic (m : Modifiers) : Bool := m.visibility.isPublic
 def Modifiers.isInferredPublic (env : Environment) (m : Modifiers) : Bool :=
   m.visibility.isInferredPublic env
@@ -147,8 +142,8 @@ instance : ToFormat Modifiers := ⟨fun m =>
     ++ (match m.visibility with
      | .regular   => []
      | .private   => [f!"private"]
-     | .protected => [f!"protected"]
      | .public    => [f!"public"])
+    ++ (if m.isProtected then [f!"protected"] else [])
     ++ (match m.computeKind with | .regular => [] | .meta => [f!"meta"] | .noncomputable => [f!"noncomputable"])
     ++ (match m.recKind with | RecKind.partial => [f!"partial"] | RecKind.nonrec => [f!"nonrec"] | _ => [])
     ++ (if m.isUnsafe then [f!"unsafe"] else [])
@@ -176,18 +171,19 @@ def elabModifiers (stx : TSyntax ``Parser.Command.declModifiers) : m Modifiers :
   let docCommentStx := stx.raw[0]
   let attrsStx      := stx.raw[1]
   let visibilityStx := stx.raw[2]
+  let protectedStx  := stx.raw[3]
   let computeKind   :=
-    if stx.raw[3].isNone then
+    if stx.raw[4].isNone then
       .regular
-    else if stx.raw[3][0].getKind == ``Parser.Command.meta then
+    else if stx.raw[4][0].getKind == ``Parser.Command.meta then
       .meta
     else
       .noncomputable
-  let unsafeStx     := stx.raw[4]
+  let unsafeStx     := stx.raw[5]
   let recKind       :=
-    if stx.raw[5].isNone then
+    if stx.raw[6].isNone then
       RecKind.default
-    else if stx.raw[5][0].getKind == ``Parser.Command.partial then
+    else if stx.raw[6][0].getKind == ``Parser.Command.partial then
       RecKind.partial
     else
       RecKind.nonrec
@@ -197,14 +193,14 @@ def elabModifiers (stx : TSyntax ``Parser.Command.declModifiers) : m Modifiers :
     | some v =>
       match v with
       | `(Parser.Command.visibility| private) => pure .private
-      | `(Parser.Command.visibility| protected) => pure .protected
       | `(Parser.Command.visibility| public) => pure .public
       | _ => throwErrorAt v "unexpected visibility modifier"
+  let isProtected := !protectedStx.isNone
   let attrs ← match attrsStx.getOptional? with
     | none       => pure #[]
     | some attrs => elabDeclAttrs attrs
   return {
-    stx, docString?, visibility, computeKind, recKind, attrs,
+    stx, docString?, visibility, isProtected, computeKind, recKind, attrs,
     isUnsafe        := !unsafeStx.isNone
   }
 
@@ -213,12 +209,12 @@ Ensure the function has not already been declared, and apply the given visibilit
 If `private`, return the updated name using our internal encoding for private names.
 If `protected`, register `declName` as protected in the environment.
 -/
-def applyVisibility (visibility : Visibility) (declName : Name) : m Name := do
+def applyVisibility (modifiers : Modifiers) (declName : Name) : m Name := do
   let mut declName := declName
-  if !visibility.isInferredPublic (← getEnv) then
+  if !modifiers.visibility.isInferredPublic (← getEnv) then
     declName := mkPrivateName (← getEnv) declName
   checkNotAlreadyDeclared declName
-  if visibility matches .protected then
+  if modifiers.isProtected then
     modifyEnv fun env => addProtected env declName
   pure declName
 
@@ -246,16 +242,16 @@ def mkDeclName (currNamespace : Name) (modifiers : Modifiers) (shortName : Name)
     shortName := Name.mkSimple s
     currNamespace := p.replacePrefix `_root_ Name.anonymous
   checkIfShadowingStructureField declName
-  let declName ← applyVisibility modifiers.visibility declName
-  match modifiers.visibility with
-  | Visibility.protected =>
+  let declName ← applyVisibility modifiers declName
+  if modifiers.isProtected then
     match currNamespace with
     | .str _ s => return (declName, Name.mkSimple s ++ shortName)
     | _ =>
       if shortName.isAtomic then
         throwError "protected declarations must be in a namespace"
       return (declName, shortName)
-  | _ => return (declName, shortName)
+  else
+    return (declName, shortName)
 
 /--
   `declId` is of the form

src/Lean/Elab/Deriving/Basic.lean

@@ -6,8 +6,10 @@ Authors: Leonardo de Moura, Wojciech Nawrocki
 module
 
 prelude
+public import Lean.Elab.App
 public import Lean.Elab.Command
 public import Lean.Elab.DeclarationRange
+public import Lean.Elab.DeclNameGen
 public meta import Lean.Parser.Command
 
 public section
@@ -18,53 +20,189 @@ open Command
 namespace Term
 open Meta
 
-/-- Result for `mkInst?` -/
-structure MkInstResult where
-  instVal   : Expr
-  instType  : Expr
-  outParams : Array Expr := #[]
+/-- Result for `mkInst` -/
+private structure MkInstResult where
+  instType   : Expr
+  instVal    : Expr
+
+private def throwDeltaDeriveFailure (className declName : Name) (msg? : Option MessageData) (suffix : MessageData := "") : MetaM α :=
+  let suffix := if let some msg := msg? then m!", {msg}{suffix}" else m!".{suffix}"
+  throwError "Failed to delta derive `{.ofConstName className}` instance for `{.ofConstName declName}`{suffix}"
 
 /--
-  Construct an instance for `className out₁ ... outₙ type`.
-  The method support classes with a prefix of `outParam`s (e.g. `MonadReader`). -/
-private partial def mkInst? (className : Name) (type : Expr) : MetaM (Option MkInstResult) := do
-  let rec go? (instType instTypeType : Expr) (outParams : Array Expr) : MetaM (Option MkInstResult) := do
-    let instTypeType ← whnfD instTypeType
-    unless instTypeType.isForall do
-      return none
-    let d := instTypeType.bindingDomain!
-    if d.isOutParam then
-      let mvar ← mkFreshExprMVar d
-      go? (mkApp instType mvar) (instTypeType.bindingBody!.instantiate1 mvar) (outParams.push mvar)
-    else
-      unless (← isDefEqGuarded (← inferType type) d) do
-        return none
-      let instType ← instantiateMVars (mkApp instType type)
-      let instVal ← synthInstance instType
-      return some { instVal, instType, outParams }
-  let instType ← mkConstWithFreshMVarLevels className
-  go? instType (← inferType instType) #[]
+Constructs an instance of the class `classExpr` by figuring out the correct position to insert `val`
+to create a type `className ... val ...` such that there is already an instance for it.
+The `declVal` argument is the value to use in place of `val` when creating the new instance.
 
-def processDefDeriving (className : Name) (declName : Name) : TermElabM Bool := do
-  try
-    let ConstantInfo.defnInfo info ← getConstInfo declName | return false
-    let some result ← mkInst? className info.value | return false
-    let instTypeNew := mkApp result.instType.appFn! (Lean.mkConst declName (info.levelParams.map mkLevelParam))
-    Meta.check instTypeNew
-    let instName ← liftMacroM <| mkUnusedBaseName (declName.appendBefore "inst" |>.appendAfter className.getString!)
-    addAndCompile <| Declaration.defnDecl {
-      name        := instName
-      levelParams := info.levelParams
-      type        := (← instantiateMVars instTypeNew)
-      value       := (← instantiateMVars result.instVal)
-      hints       := info.hints
-      safety      := info.safety
-    }
-    addInstance instName AttributeKind.global (eval_prio default)
-    addDeclarationRangesFromSyntax instName (← getRef)
-    return true
-  catch _ =>
-    return false
+Heuristics:
+- `val` must not use an outParam.
+- `val` should use an explicit parameter, or a parameter that has already been given a value.
+- If there are multiple explicit parameters, we try each possibility.
+- If the class has instance arguments, we require that they be synthesizable while synthesizing this instance.
+  While we could allow synthesis failure and abstract such instances,
+  we leave such conditional instances to be defined by users.
+- If this all fails and `val` is a constant application, we try unfolding it once and try again.
+
+For example, when deriving `MonadReader (ρ : outParam (Type u)) (m : Type u → Type v)`,
+we will skip `ρ` and try using `m`.
+
+Note that we try synthesizing instances even if there are still metavariables in the type.
+If that succeeds, then one can abstract those metavariables and create a parameterized instance.
+The abstraction is not done by this function.
+
+Expects to be run with an empty message log.
+-/
+private partial def mkInst (classExpr : Expr) (declName : Name) (declVal val : Expr) : TermElabM MkInstResult := do
+  let classExpr ← whnfCore classExpr
+  let cls := classExpr.getAppFn
+  let (xs, bis, _) ← forallMetaTelescopeReducing (← inferType cls)
+  for x in xs, y in classExpr.getAppArgs do
+    x.mvarId!.assign y
+  let classExpr := mkAppN cls xs
+  let some className ← isClass? classExpr
+    | throwError "Failed to delta derive instance for `{.ofConstName declName}`, not a class:{indentExpr classExpr}"
+  let mut instMVars := #[]
+  for x in xs, bi in bis do
+    if !(← x.mvarId!.isAssigned) then
+      -- Assumption: assigned inst implicits are already either solved or registered as synthetic
+      if bi.isInstImplicit then
+        x.mvarId!.setKind .synthetic
+        instMVars := instMVars.push x.mvarId!
+  let instVal ← mkFreshExprMVar classExpr (kind := .synthetic)
+  instMVars := instMVars.push instVal.mvarId!
+  let rec go (val : Expr) : TermElabM MkInstResult := do
+    let val ← whnfCore val
+    trace[Elab.Deriving] "Looking for arguments to `{classExpr}` that can be used for the value{indentExpr val}"
+    -- Save the metacontext so that we can try each option in turn
+    let state ← saveState
+    let valTy ← inferType val
+    let mut anyDefEqSuccess := false
+    let mut messages : MessageLog := {}
+    for x in xs, bi in bis, i in 0...xs.size do
+      unless bi.isExplicit do
+        continue
+      let decl ← x.mvarId!.getDecl
+      if decl.type.isOutParam then
+        continue
+      unless ← isMVarApp x do
+        /-
+        This is an argument supplied by the user, and it's not a `_`.
+        This is to avoid counterintuitive behavior, like in the following example.
+        Because `MyNat` unifies with `Nat`, it would otherwise generate an `HAdd MyNat Nat Nat` instance.
+        Instead it generates an `HAdd Nat MyNat Nat` instance.
+        ```
+        def MyNat := Nat
+        deriving instance HAdd Nat for MyNat
+        ```
+        Likely neither of these is the intended result, but the second is more justifiable.
+        It's possible to have it return `MyNat` using `deriving instance HAdd Nat _ MyNat for MyNat`.
+        -/
+        continue
+      unless ← isDefEqGuarded decl.type valTy <&&> isDefEqGuarded x val do
+        restoreState state
+        continue
+      anyDefEqSuccess := true
+      trace[Elab.Deriving] "Argument {i} gives option{indentExpr classExpr}"
+      try
+        -- Finish elaboration
+        synthesizeAppInstMVars instMVars classExpr
+        Term.synthesizeSyntheticMVarsNoPostponing
+      catch ex =>
+        trace[Elab.Deriving] "Option for argument {i} failed"
+        logException ex
+        messages := messages ++ (← Core.getMessageLog)
+        restoreState state
+        continue
+      if (← MonadLog.hasErrors) then
+        -- Sometimes elaboration only logs errors
+        trace[Elab.Deriving] "Option for argument {i} failed, logged errors"
+        messages := messages ++ (← Core.getMessageLog)
+        restoreState state
+        continue
+      -- Success
+      trace[Elab.Deriving] "Argument {i} option succeeded{indentExpr classExpr}"
+      -- Create the type for the declaration itself.
+      let xs' := xs.set! i declVal
+      let instType := mkAppN cls xs'
+      return { instType, instVal }
+    try
+      if let some val' ← unfoldDefinition? val then
+        return ← withTraceNode `Elab.Deriving (fun _ => return m!"Unfolded value to {val'}") <| go val'
+    catch ex =>
+      if !messages.hasErrors then
+        throw ex
+      Core.resetMessageLog
+    if !anyDefEqSuccess then
+      throwDeltaDeriveFailure className declName (m!"the class has no explicit non-out-param parameters where\
+        {indentExpr declVal}\n\
+        can be inserted.")
+    else
+      Core.setMessageLog (messages ++ (← Core.getMessageLog))
+      throwDeltaDeriveFailure className declName none
+        (.note m!"Delta deriving tries the following strategies: \
+            (1) inserting the definition into each explicit non-out-param parameter of a class and \
+            (2) unfolding definitions further.")
+  go val
+
+/--
+Delta deriving handler. Creates an instance of class `classStx` for `decl`.
+The elaborated class expression may be underapplied (e.g. `Decidable` instead of `Decidable _`),
+and may be `decl`.
+If unfolding `decl` results in an underapplied lambda, then this enters the body of the lambda.
+We prevent `classStx` from referring to these local variables; instead it's expected that one uses section variables.
+
+This function can handle being run from within a nontrivial local context,
+and it uses `mkValueTypeClosure` to construct the final instance.
+-/
+def processDefDeriving (classStx : Syntax) (decl : Expr) : TermElabM Unit := do
+  let decl ← whnfCore decl
+  let .const declName _ := decl.getAppFn
+    | throwError "Failed to delta derive instance, expecting a term of the form `C ...` where `C` is a constant, given{indentExpr decl}"
+  -- When the definition is private, the deriving handler will need access to the private scope,
+  -- and we make sure to put the instance in the private scope.
+  withoutExporting (when := isPrivateName declName) do
+  let ConstantInfo.defnInfo info ← getConstInfo declName
+    | throwError "Failed to delta derive instance, `{declName}` is not a definition."
+  let value := info.value.beta decl.getAppArgs
+  let result : Closure.MkValueTypeClosureResult ←
+    -- Assumption: users intend delta deriving to apply to the body of a definition, even if in the source code
+    -- the function is written as a lambda expression.
+    -- Furthermore, we don't use `forallTelescope` because users want to derive instances for monads.
+    lambdaTelescope value fun xs value => withoutErrToSorry do
+      let decl := mkAppN decl xs
+      -- Make these local variables inaccessible.
+      let lctx ← xs.foldlM (init := ← getLCtx) fun lctx x => do
+        pure <| lctx.setUserName x.fvarId! (← mkFreshUserName <| (lctx.find? x.fvarId!).get!.userName)
+      withLCtx' lctx do
+        let msgLog ← Core.getMessageLog
+        Core.resetMessageLog
+        try
+          -- We need to elaborate the class within this context to ensure metavariables can unify with `xs`.
+          let classExpr ← elabTerm classStx none
+          synthesizeSyntheticMVars (postpone := .partial)
+          if (← MonadLog.hasErrors) then
+            throwAbortTerm
+          -- We allow `classExpr` to be a pi type, to support giving more hypotheses to the derived instance.
+          -- (Possibly `classExpr` is not a type due to being underapplied, but `forallTelescopeReducing` tolerates this.)
+          -- We don't reduce because of abbreviations such as `DecidableEq`
+          forallTelescope classExpr fun _ classExpr => do
+            let result ← mkInst classExpr declName decl value
+            Closure.mkValueTypeClosure result.instType result.instVal (zetaDelta := true)
+        finally
+          Core.setMessageLog (msgLog ++ (← Core.getMessageLog))
+  let env ← getEnv
+  let mut instName := (← getCurrNamespace) ++ (← NameGen.mkBaseNameWithSuffix "inst" result.type)
+  -- We don't have a facility to let users override derived names, so make an unused name if needed.
+  instName ← liftMacroM <| mkUnusedBaseName instName
+  -- Make the instance private if the declaration is private.
+  if isPrivateName declName then
+    instName := mkPrivateName env instName
+  let hints := ReducibilityHints.regular (getMaxHeight env result.value + 1)
+  let decl ← mkDefinitionValInferringUnsafe instName result.levelParams.toList result.type result.value hints
+  addAndCompile (logCompileErrors := !(← read).isNoncomputableSection) <| Declaration.defnDecl decl
+  trace[Elab.Deriving] "Derived instance `{.ofConstName instName}`"
+  addInstance instName AttributeKind.global (eval_prio default)
+  addDeclarationRangesFromSyntax instName (← getRef)
 
 end Term
 
@@ -85,39 +223,60 @@ def registerDerivingHandler (className : Name) (handler : DerivingHandler) : IO
     | some handlers => m.insert className (handler :: handlers)
     | none => m.insert className [handler]
 
-def defaultHandler (className : Name) (typeNames : Array Name) : CommandElabM Unit := do
-  throwError "default handlers have not been implemented yet, class: '{className}' types: {typeNames}"
-
 def applyDerivingHandlers (className : Name) (typeNames : Array Name) : CommandElabM Unit := do
   -- When any of the types are private, the deriving handler will need access to the private scope
   -- (and should also make sure to put its outputs in the private scope).
   withoutExporting (when := typeNames.any isPrivateName) do
-  withTraceNode `Elab.Deriving (fun _ => return m!"running deriving handlers for '{className}'") do
+  withTraceNode `Elab.Deriving (fun _ => return m!"running deriving handlers for `{.ofConstName className}`") do
     match (← derivingHandlersRef.get).find? className with
     | some handlers =>
       for handler in handlers do
         if (← handler typeNames) then
           return ()
-      defaultHandler className typeNames
-    | none => defaultHandler className typeNames
+      throwError "None of the deriving handlers for class `{.ofConstName className}` applied to \
+        {.andList <| typeNames.toList.map (m!"`{.ofConstName ·}`")}"
+    | none => throwError "No deriving handlers have been implemented for class `{.ofConstName className}`"
 
-private def tryApplyDefHandler (className : Name) (declName : Name) : CommandElabM Bool :=
-  liftTermElabM do
-    Term.processDefDeriving className declName
+private def applyDefHandler (classStx : Syntax) (declExpr : Expr) : TermElabM Unit :=
+  withTraceNode `Elab.Deriving (fun _ => return m!"running delta deriving handler for `{classStx}` and definition `{declExpr}`") do
+    Term.processDefDeriving classStx declExpr
+
+private def elabDefDeriving (classes decls : Array Syntax) :
+    CommandElabM Unit := runTermElabM fun _ => do
+  for decl in decls do
+    withRef decl <| withLogging do
+      let declExpr ←
+        if decl.isIdent then
+          let declName ← realizeGlobalConstNoOverload decl
+          let info ← getConstInfo declName
+          unless info.isDefinition do
+            throwError (m!"Declaration `{.ofConstName declName}` is not a definition."
+              ++ .note m!"When any declaration is a definition, this command goes into delta deriving mode, \
+                    which applies only to definitions. \
+                    Delta deriving unfolds definitions and infers pre-existing instances.")
+          -- Use the declaration's level parameters, to ensure the instance is fully universe polymorphic
+          mkConstWithLevelParams declName
+        else
+          Term.elabTermAndSynthesize decl none
+      for classStx in classes do
+        withLogging <| applyDefHandler classStx declExpr
 
 @[builtin_command_elab «deriving»] def elabDeriving : CommandElab
-  | `(deriving instance $[$classes],* for $[$declNames],*) => do
-     let declNames ← liftCoreM <| declNames.mapM realizeGlobalConstNoOverloadWithInfo
-     for cls in classes do
-       try
-         let className ← liftCoreM <| realizeGlobalConstNoOverloadWithInfo cls
-         withRef cls do
-           if declNames.size == 1 then
-             if (← tryApplyDefHandler className declNames[0]!) then
-               return ()
-           applyDerivingHandlers className declNames
-       catch ex =>
-         logException ex
+  | `(deriving instance $[$classes],* for $[$decls],*) => do
+    let decls : Array Syntax := decls
+    if decls.all Syntax.isIdent then
+      let declNames ← liftCoreM <| decls.mapM (realizeGlobalConstNoOverloadWithInfo ·)
+      -- If any of the declarations are definitions, then we commit to delta deriving.
+      let infos ← declNames.mapM getConstInfo
+      if infos.any (·.isDefinition) then
+        elabDefDeriving classes decls
+      else
+        -- Otherwise, we commit to using deriving handlers.
+        let classNames ← liftCoreM <| classes.mapM (realizeGlobalConstNoOverloadWithInfo ·)
+        for className in classNames, classIdent in classes do
+          withRef classIdent <| withLogging <| applyDerivingHandlers className declNames
+    else
+      elabDefDeriving classes decls
   | _ => throwUnsupportedSyntax
 
 structure DerivingClassView where

src/Lean/Elab/Deriving/DecEq.lean

@@ -135,15 +135,17 @@ def mkDecEq (declName : Name) : CommandElabM Bool := do
 
 partial def mkEnumOfNat (declName : Name) : MetaM Unit := do
   let indVal ← getConstInfoInduct declName
-  let enumType := mkConst declName
-  let ctors := indVal.ctors.toArray
+  let levels := indVal.levelParams.map Level.param
+  let enumType := mkConst declName levels
+  let u ← getLevel enumType
+  let ctors := indVal.ctors.toArray.map (mkConst · levels)
   withLocalDeclD `n (mkConst ``Nat) fun n => do
-    let cond := mkConst ``cond [1]
+    let cond := mkConst ``cond [u]
     let rec mkDecTree (low high : Nat) : Expr :=
       if low + 1 == high then
-        mkConst ctors[low]!
+        ctors[low]!
       else if low + 2 == high then
-        mkApp4 cond enumType (mkApp2 (mkConst ``Nat.beq) n (mkRawNatLit low)) (mkConst ctors[low]!) (mkConst ctors[low+1]!)
+        mkApp4 cond enumType (mkApp2 (mkConst ``Nat.beq) n (mkRawNatLit low)) ctors[low]! ctors[low+1]!
       else
         let mid := (low + high)/2
         let lowBranch := mkDecTree low mid
@@ -153,7 +155,7 @@ partial def mkEnumOfNat (declName : Name) : MetaM Unit := do
     let type ← mkArrow (mkConst ``Nat) enumType
     addAndCompile <| Declaration.defnDecl {
       name := Name.mkStr declName "ofNat"
-      levelParams := []
+      levelParams := indVal.levelParams
       safety := DefinitionSafety.safe
       hints  := ReducibilityHints.abbrev
       value, type
@@ -161,24 +163,26 @@ partial def mkEnumOfNat (declName : Name) : MetaM Unit := do
 
 def mkEnumOfNatThm (declName : Name) : MetaM Unit := do
   let indVal ← getConstInfoInduct declName
-  let toCtorIdx := mkConst (Name.mkStr declName "toCtorIdx")
-  let ofNat     := mkConst (Name.mkStr declName "ofNat")
-  let enumType  := mkConst declName
-  let eqEnum    := mkApp (mkConst ``Eq [levelOne]) enumType
-  let rflEnum   := mkApp (mkConst ``Eq.refl [levelOne]) enumType
+  let levels := indVal.levelParams.map Level.param
+  let toCtorIdx := mkConst (Name.mkStr declName "toCtorIdx") levels
+  let ofNat     := mkConst (Name.mkStr declName "ofNat") levels
+  let enumType  := mkConst declName levels
+  let u ← getLevel enumType
+  let eqEnum    := mkApp (mkConst ``Eq [u]) enumType
+  let rflEnum   := mkApp (mkConst ``Eq.refl [u]) enumType
   let ctors := indVal.ctors
   withLocalDeclD `x enumType fun x => do
     let resultType := mkApp2 eqEnum (mkApp ofNat (mkApp toCtorIdx x)) x
     let motive     ← mkLambdaFVars #[x] resultType
-    let casesOn    := mkConst (mkCasesOnName declName) [levelZero]
+    let casesOn    := mkConst (mkCasesOnName declName) (levelZero :: levels)
     let mut value  := mkApp2 casesOn motive x
     for ctor in ctors do
-      value := mkApp value (mkApp rflEnum (mkConst ctor))
+      value := mkApp value (mkApp rflEnum (mkConst ctor levels))
     value ← mkLambdaFVars #[x] value
     let type ← mkForallFVars #[x] resultType
     addAndCompile <| Declaration.thmDecl {
       name := Name.mkStr declName "ofNat_toCtorIdx"
-      levelParams := []
+      levelParams := indVal.levelParams
       value, type
     }
 

src/Lean/Elab/Inductive.lean

@@ -60,7 +60,7 @@ private def inductiveSyntaxToView (modifiers : Modifiers) (decl : Syntax) : Term
     checkValidCtorModifier ctorModifiers
     let ctorName := ctor.getIdAt 3
     let ctorName := declName ++ ctorName
-    let ctorName ← withRef ctor[3] <| applyVisibility ctorModifiers.visibility ctorName
+    let ctorName ← withRef ctor[3] <| applyVisibility ctorModifiers ctorName
     let (binders, type?) := expandOptDeclSig ctor[4]
     addDocString' ctorName ctorModifiers.docString?
     addDeclarationRangesFromSyntax ctorName ctor ctor[3]

src/Lean/Elab/MutualDef.lean

@@ -1303,12 +1303,24 @@ where
       addPreDefinitions preDefs
   processDeriving (headers : Array DefViewElabHeader) := do
     for header in headers, view in views do
-      if let some classNamesStx := view.deriving? then
-        for classNameStx in classNamesStx do
-          let className ← realizeGlobalConstNoOverload classNameStx
-          withRef classNameStx do
-            unless (← processDefDeriving className header.declName) do
-              throwError "failed to synthesize instance '{className}' for '{header.declName}'"
+      if let some classStxs := view.deriving? then
+        for classStx in classStxs do
+          withRef classStx <| withLogging <| withLCtx {} {} do
+            /-
+            Assumption: users intend delta deriving to apply to the body of a definition, even if in the source code
+            the function is written as a lambda expression.
+            Furthermore, we don't use `forallTelescope` because users want to derive instances for monads.
+
+            We enter the local context of this body, which is where `classStx` will be elaborated.
+
+            Small complication: we don't know the correlation between the section variables
+            and the parameters in the declaration, so for now we do not allow `classStx`
+            to refer to section variables that were not included.
+            -/
+            let info ← getConstInfo header.declName
+            lambdaTelescope info.value! fun xs _ => do
+              let decl := mkAppN (.const header.declName (info.levelParams.map mkLevelParam)) xs
+              processDefDeriving classStx decl
 
 /--
 Logs a snapshot task that waits for the entire snapshot tree in `defsParsedSnap` and then logs a

src/Lean/Elab/MutualInductive.lean

@@ -1021,8 +1021,8 @@ private def applyComputedFields (indViews : Array InductiveView) : CommandElabM
     for {ref, fieldId, type, matchAlts, modifiers, ..} in indView.computedFields do
       computedFieldDefs := computedFieldDefs.push <| ← do
         let modifiers ← match modifiers with
-          | `(Lean.Parser.Command.declModifiersT| $[$doc:docComment]? $[$attrs:attributes]? $[$vis]? $[noncomputable]?) =>
-            `(Lean.Parser.Command.declModifiersT| $[$doc]? $[$attrs]? $[$vis]? noncomputable)
+          | `(Lean.Parser.Command.declModifiersT| $[$doc:docComment]? $[$attrs:attributes]? $[$vis]? $[protected%$protectedTk]? $[noncomputable]?) =>
+            `(Lean.Parser.Command.declModifiersT| $[$doc]? $[$attrs]? $[$vis]? $[protected%$protectedTk]? noncomputable)
           | _ => do
             withRef modifiers do logError "Unsupported modifiers for computed field"
             `(Parser.Command.declModifiersT| noncomputable)

src/Lean/Elab/Structure.lean

@@ -233,11 +233,12 @@ private def expandCtor (structStx : Syntax) (structModifiers : Modifiers) (struc
     (forcePrivate : Bool) : TermElabM CtorView := do
   let useDefault := do
     let visibility := if forcePrivate then .private else .regular
+    let modifiers := { (default : Modifiers) with visibility }
     let declName := structDeclName ++ defaultCtorName
-    let declName ← applyVisibility visibility declName
+    let declName ← applyVisibility modifiers declName
     let ref := structStx[1].mkSynthetic
     addDeclarationRangesFromSyntax declName ref
-    pure { ref, declId := ref, modifiers := { (default : Modifiers) with visibility }, declName }
+    pure { ref, declId := ref, modifiers, declName }
   if structStx[4].isNone then
     useDefault
   else
@@ -273,7 +274,7 @@ private def expandCtor (structStx : Syntax) (structModifiers : Modifiers) (struc
         throwError m!"Constructor must be `private` because one or more of this structure's fields are `private`" ++ hint
       let name := ctor[1].getId
       let declName := structDeclName ++ name
-      let declName ← applyVisibility ctorModifiers.visibility declName
+      let declName ← applyVisibility ctorModifiers declName
       -- `binders` is type parameter binder overrides; this will be validated when the constructor is created in `Structure.mkCtor`.
       let binders := ctor[2]
       addDocString' declName ctorModifiers.docString?
@@ -379,7 +380,7 @@ private def expandFields (structStx : Syntax) (structModifiers : Modifiers) (str
       unless name.isAtomic do
         throwErrorAt ident "Invalid field name `{name.eraseMacroScopes}`: Field names must be atomic"
       let declName := structDeclName ++ name
-      let declName ← applyVisibility fieldModifiers.visibility declName
+      let declName ← applyVisibility fieldModifiers declName
       addDocString' declName fieldModifiers.docString?
       return views.push {
         ref        := ident
@@ -611,13 +612,11 @@ private def getFieldDefault? (structName : Name) (params : Array Expr) (fieldNam
   else
     return none
 
-private def toVisibility (fieldInfo : StructureFieldInfo) : CoreM Visibility := do
-  if isProtected (← getEnv) fieldInfo.projFn then
-    return Visibility.protected
-  else if isPrivateName fieldInfo.projFn then
-    return Visibility.private
-  else
-    return Visibility.regular
+private def toModifiers (fieldInfo : StructureFieldInfo) : CoreM Modifiers := do
+  return {
+    isProtected := isProtected (← getEnv) fieldInfo.projFn
+    visibility := if isPrivateName fieldInfo.projFn then .private else .regular
+  }
 
 mutual
 
@@ -654,7 +653,7 @@ private partial def withStructField (view : StructView) (sourceStructNames : Lis
        its default value is overridden, otherwise the `declName` is irrelevant, except to ensure a declaration is not already declared. -/
     let mut declName := view.declName ++ fieldName
     if inSubobject?.isNone then
-      declName ← applyVisibility (← toVisibility fieldInfo) declName
+      declName ← applyVisibility (← toModifiers fieldInfo) declName
       -- No need to validate links because this docstring was already added to the environment previously
       addDocStringCore' declName (← findDocString? (← getEnv) fieldInfo.projFn)
       addDeclarationRangesFromSyntax declName (← getRef)

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

@@ -147,8 +147,7 @@ partial def computeMVarBetaPotentialForSPred (xs : Array Expr) (σs : Expr) (e :
     let s ← mkFreshExprMVar σ
     e := e.beta #[s]
     let (r, _) ← simp e ctx
-      -- In practice we only need to reduce `fun s => ...`, `SVal.curry` and functions that operate
-      -- on the state tuple bound by `SVal.curry`.
+      -- In practice we only need to reduce `fun s => ...` and `SPred.pure`.
       -- We could write a custom function should `simp` become a bottleneck.
     e := r.expr
     let count ← countBVarDependentMVars xs e

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

@@ -20,7 +20,7 @@ open Lean Elab Tactic Meta
 -- set_option pp.all true in
 -- #check ⌜False⌝
 private def falseProp (u : Level) (σs : Expr) : Expr := -- ⌜False⌝ standing in for an empty conjunction of hypotheses
-  mkApp3 (mkConst ``SVal.curry [u]) (mkApp (mkConst ``ULift [u, 0]) (.sort .zero)) σs <| mkLambda `tuple .default (mkApp (mkConst ``SVal.StateTuple [u]) σs) (mkApp2 (mkConst ``ULift.up [u, 0]) (.sort .zero) (mkConst ``False))
+  SPred.mkPure u σs (mkConst ``False)
 
 @[builtin_tactic Lean.Parser.Tactic.mexfalso]
 def elabMExfalso : Tactic | _ => do

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

@@ -41,13 +41,10 @@ def SPred.mkType (u : Level) (σs : Expr) : Expr :=
 -- set_option pp.all true in
 -- #check ⌜True⌝
 def SPred.mkPure (u : Level) (σs : Expr) (p : Expr) : Expr :=
-  mkApp3 (mkConst ``SVal.curry [u]) (mkApp (mkConst ``ULift [u, 0]) (.sort .zero)) σs <|
-    mkLambda `tuple .default (mkApp (mkConst ``SVal.StateTuple [u]) σs) <|
-      mkApp2 (mkConst ``ULift.up [u, 0]) (.sort .zero) (Expr.liftLooseBVars p 0 1)
+  mkApp2 (mkConst ``SPred.pure [u]) σs p
 
 def SPred.isPure? : Expr → Option (Level × Expr × Expr)
-  | mkApp3 (.const ``SVal.curry [u]) (mkApp (.const ``ULift _) (.sort .zero)) σs <|
-      .lam _ _ (mkApp2 (.const ``ULift.up _) _ p) _ => some (u, σs, (Expr.lowerLooseBVars p 0 1))
+  | mkApp2 (.const ``SPred.pure [u]) σs p => some (u, σs, p)
   | _ => none
 
 def emptyHypName := `emptyHyp

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

@@ -9,6 +9,7 @@ prelude
 public import Std.Tactic.Do.Syntax
 public import Lean.Elab.Tactic.Do.ProofMode.MGoal
 public import Lean.Elab.Tactic.Do.ProofMode.Focus
+public import Lean.Elab.Tactic.Meta
 
 public section
 
@@ -53,3 +54,9 @@ def elabMPure : Tactic
   | _ => throwUnsupportedSyntax
 
 macro "mpure_intro" : tactic => `(tactic| apply Pure.intro)
+
+def MGoal.triviallyPure (goal : MGoal) : OptionT MetaM Expr := do
+  let mv ← mkFreshExprMVar goal.toExpr
+  let ([], _) ← try runTactic mv.mvarId! (← `(tactic| apply Pure.intro; trivial)) catch _ => failure
+    | failure
+  return mv.consumeMData

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

@@ -96,11 +96,11 @@ partial def dischargeFailEntails (u : Level) (ps : Expr) (Q : Expr) (Q' : Expr)
   if ps.isAppOf ``PostShape.pure then
     return mkConst ``True.intro
   if ← isDefEq Q Q' then
-    return mkApp2 (mkConst ``FailConds.entails.refl [u]) ps Q
-  if ← isDefEq Q (mkApp (mkConst ``FailConds.false [u]) ps) then
-    return mkApp2 (mkConst ``FailConds.entails_false [u]) ps Q'
-  if ← isDefEq Q' (mkApp (mkConst ``FailConds.true [u]) ps) then
-    return mkApp2 (mkConst ``FailConds.entails_true [u]) ps Q
+    return mkApp2 (mkConst ``ExceptConds.entails.refl [u]) ps Q
+  if ← isDefEq Q (mkApp (mkConst ``ExceptConds.false [u]) ps) then
+    return mkApp2 (mkConst ``ExceptConds.entails_false [u]) ps Q'
+  if ← isDefEq Q' (mkApp (mkConst ``ExceptConds.true [u]) ps) then
+    return mkApp2 (mkConst ``ExceptConds.entails_true [u]) ps Q
   -- the remaining cases are recursive.
   if let some (_σ, ps) := ps.app2? ``PostShape.arg then
     return ← dischargeFailEntails u ps Q Q' goalTag
@@ -117,31 +117,29 @@ partial def dischargeFailEntails (u : Level) (ps : Expr) (Q : Expr) (Q' : Expr)
     let prf₂ ← dischargeFailEntails u ps (← mkProj' ``Prod 1 Q) (← mkProj' ``Prod 1 Q') (goalTag ++ `except)
     return ← mkAppM ``And.intro #[prf₁, prf₂] -- This is just a bit too painful to construct by hand
   -- This case happens when decomposing with unknown `ps : PostShape`
-  mkFreshExprSyntheticOpaqueMVar (mkApp3 (mkConst ``FailConds.entails [u]) ps Q Q') goalTag
+  mkFreshExprSyntheticOpaqueMVar (mkApp3 (mkConst ``ExceptConds.entails [u]) ps Q Q') goalTag
 end
 
 def dischargeMGoal (goal : MGoal) (goalTag : Name) : n Expr := do
   liftMetaM <| do trace[Elab.Tactic.Do.spec] "dischargeMGoal: {goal.target}"
   -- simply try one of the assumptions for now. Later on we might want to decompose conjunctions etc; full xsimpl
   -- The `withDefault` ensures that a hyp `⌜s = 4⌝` can be used to discharge `⌜s = 4⌝ s`.
-  -- (Recall that `⌜s = 4⌝ s` is `SVal.curry (σs:=[Nat]) (fun _ => s = 4) s` and `SVal.curry` is
+  -- (Recall that `⌜s = 4⌝ s` is `SPred.pure (σs:=[Nat]) (s = 4) s` and `SPred.pure` is
   -- semi-reducible.)
-  let some prf ← liftMetaM (withDefault <| goal.assumption <|> goal.assumptionPure)
+  -- We also try `mpure_intro; trivial` through `goal.triviallyPure` here because later on an
+  -- assignment like `⌜s = ?c⌝` becomes impossible to discharge because `?c` will get abstracted
+  -- over local bindings that depend on synthetic opaque MVars (such as loop invariants), and then
+  -- the type of the new `?c` will not be defeq to itself. A bug, but we need to work around it for
+  -- now.
+  let some prf ← liftMetaM (withDefault <| goal.assumption <|> goal.assumptionPure <|> goal.triviallyPure)
     | mkFreshExprSyntheticOpaqueMVar goal.toExpr goalTag
   liftMetaM <| do trace[Elab.Tactic.Do.spec] "proof: {prf}"
   return prf
 
-def mkPreTag (goalTag : Name) : Name := Id.run do
-  let dflt := goalTag ++ `pre1
-  let .str p s := goalTag | return dflt
-  unless "pre".isPrefixOf s do return dflt
-  let some n := (s.toSubstring.drop 3).toString.toNat? | return dflt
-  return .str p ("pre" ++ toString (n + 1))
-
 /--
   Returns the proof and the list of new unassigned MVars.
 -/
-def mSpec (goal : MGoal) (elabSpecAtWP : Expr → n SpecTheorem) (goalTag : Name) (mkPreTag := mkPreTag) : n Expr := do
+def mSpec (goal : MGoal) (elabSpecAtWP : Expr → n SpecTheorem) (goalTag : Name) : n Expr := do
   -- First instantiate `fun s => ...` in the target via repeated `mintro ∀s`.
   mIntroForallN goal goal.target.consumeMData.getNumHeadLambdas fun goal => do
   -- Elaborate the spec for the wp⟦e⟧ app in the target
@@ -151,11 +149,8 @@ def mSpec (goal : MGoal) (elabSpecAtWP : Expr → n SpecTheorem) (goalTag : Name
   let wp := T.getArg! 2
   let specThm ← elabSpecAtWP wp
 
-  -- The precondition of `specThm` might look like `⌜?n = ‹Nat›ₛ ∧ ?m = ‹Bool›ₛ⌝`, which expands to
-  -- `SVal.curry (fun tuple => ?n = SVal.uncurry (getThe Nat tuple) ∧ ?m = SVal.uncurry (getThe Bool tuple))`.
-  -- Note that the assignments for `?n` and `?m` depend on the bound variable `tuple`.
-  -- Here, we further eta expand and simplify according to `etaPotential` so that the solutions for
-  -- `?n` and `?m` do not depend on `tuple`.
+  -- The precondition of `specThm` might look like `⌜?n = nₛ ∧ ?m = b⌝`, which expands to
+  -- `SPred.pure (?n = n ∧ ?m = b)`.
   let residualEta := specThm.etaPotential - (T.getAppNumArgs - 4) -- 4 arguments expected for PredTrans.apply
   mIntroForallN goal residualEta fun goal => do
 
@@ -196,7 +191,7 @@ def mSpec (goal : MGoal) (elabSpecAtWP : Expr → n SpecTheorem) (goalTag : Name
   if !HPRfl then
     -- let P := (← reduceProjBeta? P).getD P
     -- Try to avoid creating a longer name if the postcondition does not need to create a goal
-    let tag := if !QQ'Rfl then mkPreTag goalTag else goalTag
+    let tag := if !QQ'Rfl then goalTag ++ `pre else goalTag
     let HPPrf ← dischargeMGoal { goal with target := P } tag
     prePrf := mkApp6 (mkConst ``SPred.entails.trans [u]) goal.σs goal.hyps P goal.target HPPrf
 

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

@@ -18,13 +18,22 @@ namespace Std.Do
 open Lean Parser Meta Elab Term PrettyPrinter Delaborator
 
 open Std.Do in
-@[builtin_delab app.Std.Do.PostCond.total]
-private def unexpandPostCondTotal : Delab := do
+@[builtin_delab PostCond.noThrow]
+private def unexpandPostCondNoThrow : Delab := do
   match ← SubExpr.withAppArg <| delab with
   | `(fun $xs:term* => $e) =>
     let t ← `(⇓ $xs* => $(← SPred.Notation.unpack e))
     return ⟨t.raw⟩
-  | t => `($(mkIdent ``PostCond.total):term $t)
+  | t => `($(mkIdent ``PostCond.noThrow):term $t)
+
+open Std.Do in
+@[builtin_delab PostCond.mayThrow]
+private def unexpandPostCondMayThrow : Delab := do
+  match ← SubExpr.withAppArg <| delab with
+  | `(fun $xs:term* => $e) =>
+    let t ← `(⇓? $xs* => $(← SPred.Notation.unpack e))
+    return ⟨t.raw⟩
+  | t => `($(mkIdent ``PostCond.mayThrow):term $t)
 
 @[inherit_doc Triple, builtin_doc, builtin_term_elab triple]
 private def elabTriple : TermElab

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

@@ -45,7 +45,13 @@ partial def genVCs (goal : MVarId) (ctx : Context) (fuel : Fuel) : MetaM (Array
   mvar.withContext <| withReducible do
     let (prf, state) ← StateRefT'.run (ReaderT.run (onGoal goal (← mvar.getTag)) ctx) { fuel }
     mvar.assign prf
-    return state.vcs
+    for h : idx in [:state.invariants.size] do
+      let mv := state.invariants[idx]
+      mv.setTag (Name.mkSimple ("inv" ++ toString (idx + 1)))
+    for h : idx in [:state.vcs.size] do
+      let mv := state.vcs[idx]
+      mv.setTag (Name.mkSimple ("vc" ++ toString (idx + 1)) ++ (← mv.getTag))
+    return state.invariants ++ state.vcs
 where
   onFail (goal : MGoal) (name : Name) : VCGenM Expr := do
     -- trace[Elab.Tactic.Do.vcgen] "fail {goal.toExpr}"
@@ -70,15 +76,20 @@ where
       mvar.withContext <| do
       -- trace[Elab.Tactic.Do.vcgen] "assignMVars {← mvar.getTag}, isDelayedAssigned: {← mvar.isDelayedAssigned},\n{mvar}"
       let ty ← mvar.getType
-      if (← isProp ty) || ty.isAppOf ``PostCond || ty.isAppOf ``SPred then
-        -- This code path will re-introduce `mvar` as a synthetic opaque goal upon discharge failure.
-        -- This is the right call for (previously natural) holes such as loop invariants, which
-        -- would otherwise lead to spurious instantiations.
-        -- But it's wrong for, e.g., schematic variables. The latter should never be PostConds or
-        -- SPreds, hence the condition.
+      if ← isProp ty then
+        -- Might contain more `P ⊢ₛ wp⟦prog⟧ Q` apps. Try and prove it!
         mvar.assign (← tryGoal ty (← mvar.getTag))
-      else
-        addSubGoalAsVC mvar
+        return
+
+      if ty.isAppOf ``PostCond || ty.isAppOf ``Invariant || ty.isAppOf ``SPred then
+        -- Here we make `mvar` a synthetic opaque goal upon discharge failure.
+        -- This is the right call for (previously natural) holes such as loop invariants, which
+        -- would otherwise lead to spurious instantiations and unwanted renamings (when leaving the
+        -- scope of a local).
+        -- But it's wrong for, e.g., schematic variables. The latter should never be PostConds,
+        -- Invariants or SPreds, hence the condition.
+        mvar.setKind .syntheticOpaque
+      addSubGoalAsVC mvar
 
   onGoal goal name : VCGenM Expr := do
     let T := goal.target
@@ -100,9 +111,8 @@ where
     let args := goal.target.getAppArgs
     let trans := args[2]!
     -- logInfo m!"trans: {trans}"
-    let Q := args[3]!
     let wp ← instantiateMVarsIfMVarApp trans
-    let_expr c@WP.wp m ps instWP α e := wp | onFail goal name
+    let_expr WP.wp m _ps _instWP α e := wp | onFail goal name
     -- NB: e here is a monadic expression, in the "object language"
     let e ← instantiateMVarsIfMVarApp e
     let e := e.headBeta
@@ -150,13 +160,13 @@ where
         let res ← Simp.simp e
         unless res.expr != e do return ← onFail goal name
         burnOne
-        if let .some heq := res.proof? then
-          trace[Elab.Tactic.Do.vcgen] "Simplified"
-          let prf ← onWPApp (goal.withNewProg res.expr) name
-          let prf := mkApp10 (mkConst ``Triple.rewrite_program c.constLevels!) m ps α goal.hyps Q instWP e res.expr heq prf
-          return prf
-        else
-          return ← onWPApp (goal.withNewProg res.expr) name
+        trace[Elab.Tactic.Do.vcgen] "Simplified program to {res.expr}"
+        let prf ← onWPApp (goal.withNewProg res.expr) name
+        -- context = fun e => H ⊢ₛ wp⟦e⟧ Q
+        let context ← withLocalDecl `e .default (mkApp m α) fun e => do
+          mkLambdaFVars #[e] (goal.withNewProg e).toExpr
+        let res ← Simp.mkCongrArg context res
+        return ← res.mkEqMPR prf
       assignMVars specHoles.toList
       return prf
     return ← onFail goal name
@@ -166,18 +176,17 @@ where
   onSplit (goal : MGoal) (info : SplitInfo) (name : Name)
       (withAltCtx : Nat → Array Expr → VCGenM Expr → VCGenM Expr := fun _ _ k => k) : VCGenM Expr := do
     let args := goal.target.getAppArgs
-    let Q := args[3]!
-    let_expr c@WP.wp m ps instWP α e := args[2]! | throwError "Expected wp⟦e⟧ Q in goal.target, got {goal.target}"
+    let_expr WP.wp m _ps _instWP α e := args[2]! | throwError "Expected wp⟦e⟧ Q in goal.target, got {goal.target}"
     -- Bring into simp NF
     let e ← -- returns/continues only if old e is defeq to new e
       if let .some res ← info.simpDiscrs? e then
         burnOne
-        if let .some heq := res.proof? then
-          let prf ← onWPApp (goal.withNewProg res.expr) name
-          let prf := mkApp10 (mkConst ``Triple.rewrite_program c.constLevels!) m ps α goal.hyps Q instWP e res.expr heq prf
-          return prf
-        else
-          pure res.expr
+        let prf ← onWPApp (goal.withNewProg res.expr) name
+        -- context = fun e => H ⊢ₛ wp⟦e⟧ Q
+        let context ← withLocalDecl `e .default (mkApp m α) fun e => do
+          mkLambdaFVars #[e] (goal.withNewProg e).toExpr
+        let res ← Simp.mkCongrArg context res
+        res.mkEqMPR prf
       else
         pure e
     -- Try reduce the matcher

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

@@ -62,13 +62,17 @@ structure Context where
   simpCtx : Simp.Context
   simprocs : Simp.SimprocsArray
   jps : FVarIdMap JumpSiteInfo := {}
+  initialCtxSize : Nat
 
 structure State where
   fuel : Fuel := .unlimited
   simpState : Simp.State := {}
   /--
+  Holes of type `Invariant` that have been generated so far.
+  -/
+  invariants : Array MVarId := #[]
+  /--
   The verification conditions that have been generated so far.
-  Includes `Type`-valued goals arising from instantiation of specifications.
   -/
   vcs : Array MVarId := #[]
 
@@ -87,13 +91,18 @@ def ifOutOfFuel (x : VCGenM α) (k : VCGenM α) : VCGenM α := do
   | Fuel.limited 0 => x
   | _ => k
 
-def emitVC (subGoal : Expr) (name : Name) : VCGenM Expr := do
-  let m ← liftM <| mkFreshExprSyntheticOpaqueMVar subGoal (tag := name)
-  modify fun s => { s with vcs := s.vcs.push m.mvarId! }
-  return m
-
 def addSubGoalAsVC (goal : MVarId) : VCGenM PUnit := do
-  modify fun s => { s with vcs := s.vcs.push goal }
+  let ty ← goal.getType
+  if ty.isAppOf ``Std.Do.Invariant then
+    modify fun s => { s with invariants := s.invariants.push goal }
+  else
+    modify fun s => { s with vcs := s.vcs.push goal }
+
+def emitVC (subGoal : Expr) (name : Name) : VCGenM Expr := do
+  withFreshUserNamesSinceIdx (← read).initialCtxSize do
+    let m ← liftM <| mkFreshExprSyntheticOpaqueMVar subGoal (tag := name)
+    addSubGoalAsVC m.mvarId!
+    return m
 
 def liftSimpM (x : SimpM α) : VCGenM α := do
   let ctx ← read
@@ -239,4 +248,10 @@ def mkSpecContext (optConfig : Syntax) (lemmas : Syntax) (ignoreStarArg := false
           let thm ← mkSpecTheoremFromLocal fvar
           specThms := addSpecTheoremEntry specThms thm
         catch _ => continue
-  return { config, specThms, simpCtx := res.ctx, simprocs := res.simprocs }
+  return {
+    config,
+    specThms,
+    simpCtx := res.ctx,
+    simprocs := res.simprocs
+    initialCtxSize := (← getLCtx).numIndices
+  }

src/Lean/Elab/Tactic/Omega/Frontend.lean

@@ -86,7 +86,7 @@ def mkCoordinateEvalAtomsEq (e : Expr) (n : Nat) : OmegaM Expr := do
     mkEqTrans eq (← mkEqSymm (mkApp2 (.const ``LinearCombo.coordinate_eval []) n atoms))
 
 /-- Construct the linear combination (and its associated proof and new facts) for an atom. -/
-def mkAtomLinearCombo (e : Expr) : OmegaM (LinearCombo × OmegaM Expr × Std.HashSet Expr) := do
+def mkAtomLinearCombo (e : Expr) : OmegaM (LinearCombo × OmegaM Expr × List Expr) := do
   let (n, facts) ← lookup e
   return ⟨LinearCombo.coordinate n, mkCoordinateEvalAtomsEq e n, facts.getD ∅⟩
 
@@ -100,7 +100,7 @@ Gives a small (10%) speedup in testing.
 I tried using a pointer based cache,
 but there was never enough subexpression sharing to make it effective.
 -/
-partial def asLinearCombo (e : Expr) : OmegaM (LinearCombo × OmegaM Expr × Std.HashSet Expr) := do
+partial def asLinearCombo (e : Expr) : OmegaM (LinearCombo × OmegaM Expr × List Expr) := do
   let cache ← get
   match cache.get? e with
   | some (lc, prf) =>
@@ -126,7 +126,7 @@ We also transform the expression as we descend into it:
 * pushing coercions: `↑(x + y)`, `↑(x * y)`, `↑(x / k)`, `↑(x % k)`, `↑k`
 * unfolding `emod`: `x % k` → `x - x / k`
 -/
-partial def asLinearComboImpl (e : Expr) : OmegaM (LinearCombo × OmegaM Expr × Std.HashSet Expr) := do
+partial def asLinearComboImpl (e : Expr) : OmegaM (LinearCombo × OmegaM Expr × List Expr) := do
   trace[omega] "processing {e}"
   match groundInt? e with
   | some i =>
@@ -148,7 +148,7 @@ partial def asLinearComboImpl (e : Expr) : OmegaM (LinearCombo × OmegaM Expr ×
       mkEqTrans
         (← mkAppM ``Int.add_congr #[← prf₁, ← prf₂])
         (← mkEqSymm add_eval)
-    pure (l₁ + l₂, prf, facts₁.union facts₂)
+    pure (l₁ + l₂, prf, facts₁ ++ facts₂)
   | (``HSub.hSub, #[_, _, _, _, e₁, e₂]) => do
     let (l₁, prf₁, facts₁) ← asLinearCombo e₁
     let (l₂, prf₂, facts₂) ← asLinearCombo e₂
@@ -158,7 +158,7 @@ partial def asLinearComboImpl (e : Expr) : OmegaM (LinearCombo × OmegaM Expr ×
       mkEqTrans
         (← mkAppM ``Int.sub_congr #[← prf₁, ← prf₂])
         (← mkEqSymm sub_eval)
-    pure (l₁ - l₂, prf, facts₁.union facts₂)
+    pure (l₁ - l₂, prf, facts₁ ++ facts₂)
   | (``Neg.neg, #[_, _, e']) => do
     let (l, prf, facts) ← asLinearCombo e'
     let prf' : OmegaM Expr := do
@@ -184,7 +184,7 @@ partial def asLinearComboImpl (e : Expr) : OmegaM (LinearCombo × OmegaM Expr ×
           mkEqTrans
             (← mkAppM ``Int.mul_congr #[← xprf, ← yprf])
             (← mkEqSymm mul_eval)
-        pure (some (LinearCombo.mul xl yl, prf, xfacts.union yfacts), true)
+        pure (some (LinearCombo.mul xl yl, prf, xfacts ++ yfacts), true)
       else
         pure (none, false)
     match r? with
@@ -242,7 +242,7 @@ where
   Apply a rewrite rule to an expression, and interpret the result as a `LinearCombo`.
   (We're not rewriting any subexpressions here, just the top level, for efficiency.)
   -/
-  rewrite (lhs rw : Expr) : OmegaM (LinearCombo × OmegaM Expr × Std.HashSet Expr) := do
+  rewrite (lhs rw : Expr) : OmegaM (LinearCombo × OmegaM Expr × List Expr) := do
     trace[omega] "rewriting {lhs} via {rw} : {← inferType rw}"
     match (← inferType rw).eq? with
     | some (_, _lhs', rhs) =>
@@ -250,7 +250,7 @@ where
       let prf' : OmegaM Expr := do mkEqTrans rw (← prf)
       pure (lc, prf', facts)
     | none => panic! "Invalid rewrite rule in 'asLinearCombo'"
-  handleNatCast (e i n : Expr) : OmegaM (LinearCombo × OmegaM Expr × Std.HashSet Expr) := do
+  handleNatCast (e i n : Expr) : OmegaM (LinearCombo × OmegaM Expr × List Expr) := do
     match n with
     | .fvar h =>
       if let some v ← h.getValue? then
@@ -297,7 +297,7 @@ where
     | (``Fin.val, #[n, x]) =>
       handleFinVal e i n x
     | _ => mkAtomLinearCombo e
-  handleFinVal (e i n x : Expr) : OmegaM (LinearCombo × OmegaM Expr × Std.HashSet Expr) := do
+  handleFinVal (e i n x : Expr) : OmegaM (LinearCombo × OmegaM Expr × List Expr) := do
     match x with
     | .fvar h =>
       if let some v ← h.getValue? then
@@ -343,12 +343,11 @@ We solve equalities as they are discovered, as this often results in an earlier
 -/
 def addIntEquality (p : MetaProblem) (h x : Expr) : OmegaM MetaProblem := do
   let (lc, prf, facts) ← asLinearCombo x
-  let newFacts : Std.HashSet Expr := facts.fold (init := ∅) fun s e =>
-    if p.processedFacts.contains e then s else s.insert e
+  let newFacts : List Expr := facts.filter (p.processedFacts.contains · = false)
   trace[omega] "Adding proof of {lc} = 0"
   pure <|
   { p with
-    facts := newFacts.toList ++ p.facts
+    facts := newFacts ++ p.facts
     problem := ← (p.problem.addEquality lc.const lc.coeffs
       (some do mkEqTrans (← mkEqSymm (← prf)) h)) |>.solveEqualities }
 
@@ -359,12 +358,11 @@ We solve equalities as they are discovered, as this often results in an earlier
 -/
 def addIntInequality (p : MetaProblem) (h y : Expr) : OmegaM MetaProblem := do
   let (lc, prf, facts) ← asLinearCombo y
-  let newFacts : Std.HashSet Expr := facts.fold (init := ∅) fun s e =>
-    if p.processedFacts.contains e then s else s.insert e
+  let newFacts : List Expr := facts.filter (p.processedFacts.contains · = false)
   trace[omega] "Adding proof of {lc} ≥ 0"
   pure <|
   { p with
-    facts := newFacts.toList ++ p.facts
+    facts := newFacts ++ p.facts
     problem := ← (p.problem.addInequality lc.const lc.coeffs
       (some do mkAppM ``le_of_le_of_eq #[h, (← prf)])) |>.solveEqualities }
 

src/Lean/Elab/Tactic/Omega/MinNatAbs.lean

@@ -9,7 +9,7 @@ prelude
 public import Init.BinderPredicates
 public import Init.Data.Int.Order
 public import Init.Data.List.MinMax
-public import Init.Data.Nat.MinMax
+public import Init.Data.Nat.Order
 public import Init.Data.Option.Lemmas
 
 public section
@@ -35,20 +35,10 @@ We completely characterize the function via
 -/
 def nonzeroMinimum (xs : List Nat) : Nat := xs.filter (· ≠ 0) |>.min? |>.getD 0
 
--- A specialization of `minimum?_eq_some_iff` to Nat.
--- This is a duplicate `min?_eq_some_iff'` proved in `Init.Data.List.Nat.Basic`,
--- and could be deduplicated but the import hierarchy is awkward.
-theorem min?_eq_some_iff'' {xs : List Nat} :
-    xs.min? = some a ↔ (a ∈ xs ∧ ∀ b ∈ xs, a ≤ b) :=
-  min?_eq_some_iff
-    (le_refl := Nat.le_refl)
-    (min_eq_or := fun _ _ => Nat.min_def .. ▸ by split <;> simp)
-    (le_min_iff := fun _ _ _ => Nat.le_min)
-
 open Classical in
 @[simp] theorem nonzeroMinimum_eq_zero_iff {xs : List Nat} :
     xs.nonzeroMinimum = 0 ↔ ∀ x ∈ xs, x = 0 := by
-  simp [nonzeroMinimum, Option.getD_eq_iff, min?_eq_none_iff, min?_eq_some_iff'',
+  simp [nonzeroMinimum, Option.getD_eq_iff, min?_eq_none_iff, min?_eq_some_iff,
     filter_eq_nil_iff, mem_filter]
 
 theorem nonzeroMinimum_mem {xs : List Nat} (w : xs.nonzeroMinimum ≠ 0) :
@@ -56,7 +46,7 @@ theorem nonzeroMinimum_mem {xs : List Nat} (w : xs.nonzeroMinimum ≠ 0) :
   dsimp [nonzeroMinimum] at *
   generalize h : (xs.filter (· ≠ 0) |>.min?) = m at *
   match m, w with
-  | some (m+1), _ => simp_all [min?_eq_some_iff'', mem_filter]
+  | some (m+1), _ => simp_all [min?_eq_some_iff, mem_filter]
 
 theorem nonzeroMinimum_pos {xs : List Nat} (m : a ∈ xs) (h : a ≠ 0) : 0 < xs.nonzeroMinimum :=
   Nat.pos_iff_ne_zero.mpr fun w => h (nonzeroMinimum_eq_zero_iff.mp w _ m)
@@ -68,7 +58,7 @@ theorem nonzeroMinimum_le {xs : List Nat} (m : a ∈ xs) (h : a ≠ 0) : xs.nonz
     generalize h : (xs.filter (· ≠ 0) |>.min?) = m? at *
     match m?, w with
     | some m?, _ => rfl
-  rw [min?_eq_some_iff''] at this
+  rw [min?_eq_some_iff] at this
   apply this.2
   simp [List.mem_filter]
   exact ⟨m, h⟩

src/Lean/Elab/Tactic/Omega/OmegaM.lean

@@ -168,11 +168,11 @@ def mkEqReflWithExpectedType (a b : Expr) : MetaM Expr := do
 Analyzes a newly recorded atom,
 returning a collection of interesting facts about it that should be added to the context.
 -/
-def analyzeAtom (e : Expr) : OmegaM (Std.HashSet Expr) := do
+def analyzeAtom (e : Expr) : OmegaM (List Expr) := do
   match e.getAppFnArgs with
   | (``Nat.cast, #[.const ``Int [], _, e']) =>
     -- Casts of natural numbers are non-negative.
-    let mut r := (∅ : Std.HashSet Expr).insert (Expr.app (.const ``Int.ofNat_nonneg []) e')
+    let mut r := [Expr.app (.const ``Int.ofNat_nonneg []) e']
     match (← cfg).splitNatSub, e'.getAppFnArgs with
       | true, (``HSub.hSub, #[_, _, _, _, a, b]) =>
         -- `((a - b : Nat) : Int)` gives a dichotomy
@@ -194,9 +194,8 @@ def analyzeAtom (e : Expr) : OmegaM (Std.HashSet Expr) := do
       let ne_zero := mkApp3 (.const ``Ne [1]) (.const ``Int []) k (toExpr (0 : Int))
       let pos := mkApp4 (.const ``LT.lt [0]) (.const ``Int []) (.const ``Int.instLTInt [])
         (toExpr (0 : Int)) k
-      pure <| (∅ : Std.HashSet Expr).insert
-        (mkApp3 (.const ``Int.mul_ediv_self_le []) x k (← mkDecideProof ne_zero)) |>.insert
-          (mkApp3 (.const ``Int.lt_mul_ediv_self_add []) x k (← mkDecideProof pos))
+      pure [mkApp3 (.const ``Int.mul_ediv_self_le []) x k (← mkDecideProof ne_zero),
+            mkApp3 (.const ``Int.lt_mul_ediv_self_add []) x k (← mkDecideProof pos)]
   | (``HMod.hMod, #[_, _, _, _, x, k]) =>
     match k.getAppFnArgs with
     | (``HPow.hPow, #[_, _, _, _, b, exp]) => match natCast? b with
@@ -206,10 +205,9 @@ def analyzeAtom (e : Expr) : OmegaM (Std.HashSet Expr) := do
         let b_pos := mkApp4 (.const ``LT.lt [0]) (.const ``Int []) (.const ``Int.instLTInt [])
           (toExpr (0 : Int)) b
         let pow_pos := mkApp3 (.const ``Lean.Omega.Int.pos_pow_of_pos []) b exp (← mkDecideProof b_pos)
-        pure <| (∅ : Std.HashSet Expr).insert
-          (mkApp3 (.const ``Int.emod_nonneg []) x k
-              (mkApp3 (.const ``Int.ne_of_gt []) k (toExpr (0 : Int)) pow_pos)) |>.insert
-            (mkApp3 (.const ``Int.emod_lt_of_pos []) x k pow_pos)
+        pure [mkApp3 (.const ``Int.emod_nonneg []) x k
+                (mkApp3 (.const ``Int.ne_of_gt []) k (toExpr (0 : Int)) pow_pos),
+              mkApp3 (.const ``Int.emod_lt_of_pos []) x k pow_pos]
     | (``Nat.cast, #[.const ``Int [], _, k']) =>
       match k'.getAppFnArgs with
       | (``HPow.hPow, #[_, _, _, _, b, exp]) => match natCast? b with
@@ -220,28 +218,25 @@ def analyzeAtom (e : Expr) : OmegaM (Std.HashSet Expr) := do
             (toExpr (0 : Nat)) b
           let pow_pos := mkApp3 (.const ``Nat.pos_pow_of_pos []) b exp (← mkDecideProof b_pos)
           let cast_pos := mkApp2 (.const ``Int.ofNat_pos_of_pos []) k' pow_pos
-          pure <| (∅ : Std.HashSet Expr).insert
-            (mkApp3 (.const ``Int.emod_nonneg []) x k
-                (mkApp3 (.const ``Int.ne_of_gt []) k (toExpr (0 : Int)) cast_pos)) |>.insert
-              (mkApp3 (.const ``Int.emod_lt_of_pos []) x k cast_pos)
+          pure [mkApp3 (.const ``Int.emod_nonneg []) x k
+                  (mkApp3 (.const ``Int.ne_of_gt []) k (toExpr (0 : Int)) cast_pos),
+                mkApp3 (.const ``Int.emod_lt_of_pos []) x k cast_pos]
       | _ =>  match x.getAppFnArgs with
         | (``Nat.cast, #[.const ``Int [], _, x']) =>
           -- Since we push coercions inside `%`, we need to record here that
           -- `(x : Int) % (y : Int)` is non-negative.
-          pure <| (∅ : Std.HashSet Expr).insert (mkApp2 (.const ``Int.emod_ofNat_nonneg []) x' k)
+          pure [mkApp2 (.const ``Int.emod_ofNat_nonneg []) x' k]
         | _ => pure ∅
     | _ => pure ∅
   | (``Min.min, #[_, _, x, y]) =>
-    pure <| (∅ : Std.HashSet Expr).insert (mkApp2 (.const ``Int.min_le_left []) x y) |>.insert
-      (mkApp2 (.const ``Int.min_le_right []) x y)
+    pure [mkApp2 (.const ``Int.min_le_left []) x y, mkApp2 (.const ``Int.min_le_right []) x y]
   | (``Max.max, #[_, _, x, y]) =>
-    pure <| (∅ : Std.HashSet Expr).insert (mkApp2 (.const ``Int.le_max_left []) x y) |>.insert
-      (mkApp2 (.const ``Int.le_max_right []) x y)
+    pure [mkApp2 (.const ``Int.le_max_left []) x y, mkApp2 (.const ``Int.le_max_right []) x y]
   | (``ite, #[α, i, dec, t, e]) =>
       if α == (.const ``Int []) then
-        pure <| (∅ : Std.HashSet Expr).insert <| mkApp5 (.const ``ite_disjunction [0]) α i dec t e
+        pure [mkApp5 (.const ``ite_disjunction [0]) α i dec t e]
       else
-        pure {}
+        pure []
   | _ => pure ∅
 
 /--
@@ -254,7 +249,7 @@ Return its index, and, if it is new, a collection of interesting facts about the
 * for each new atom of the form `((a - b : Nat) : Int)`, the fact:
   `b ≤ a ∧ ((a - b : Nat) : Int) = a - b ∨ a < b ∧ ((a - b : Nat) : Int) = 0`
 -/
-def lookup (e : Expr) : OmegaM (Nat × Option (Std.HashSet Expr)) := do
+def lookup (e : Expr) : OmegaM (Nat × Option (List Expr)) := do
   let c ← getThe State
   let e ← canon e
   match c.atoms[e]? with
@@ -264,7 +259,7 @@ def lookup (e : Expr) : OmegaM (Nat × Option (Std.HashSet Expr)) := do
   let facts ← analyzeAtom e
   if ← isTracingEnabledFor `omega then
     unless facts.isEmpty do
-      trace[omega] "New facts: {← facts.toList.mapM fun e => inferType e}"
+      trace[omega] "New facts: {← facts.mapM fun e => inferType e}"
   let i ← modifyGetThe State fun c =>
     (c.atoms.size, { c with atoms := c.atoms.insert e c.atoms.size })
   return (i, some facts)

src/Lean/Environment.lean

@@ -529,13 +529,6 @@ private structure VisibilityMap (α : Type) where
   «public»  : α
 deriving Inhabited, Nonempty
 
-/-- Realization results, to be replayed onto other branches. -/
-private structure RealizationResult where
-  newConsts : VisibilityMap (List AsyncConst)
-  replayKernel : Kernel.Environment → Except Kernel.Exception Kernel.Environment
-  dyn : Dynamic
-deriving Nonempty
-
 /-- Context for `realizeConst` established by `enableRealizationsForConst`. -/
 private structure RealizationContext where
   /--
@@ -545,12 +538,11 @@ private structure RealizationContext where
   /-- Saved options. Empty for imported constants. -/
   opts      : Options
   /--
-  `realizeConst _ c ..` adds a mapping from `c` to a task of the realization results: the newly
-  added constants (incl. extension data in `AsyncConst.exts?`),  a function for replaying the
-  changes onto a derived kernel environment, and auxiliary data (always `SnapshotTree` in builtin
-  uses, but untyped to avoid cyclic module references).
+  `realizeValue _ key ..` adds a mapping from `(typeName key, key)` to a task of the realization
+  result (`RealizeValueResult` when called from `Lean.realizeValue`, `RealizeConstResult` from
+  `Environment.realizeConst`).
   -/
-  constsRef : IO.Ref (NameMap (Task RealizationResult))
+  realizeMapRef : IO.Ref (NameMap NonScalar /- PHashMap α (Task Dynamic) -/)
 
 /--
 Elaboration-specific extension of `Kernel.Environment` that adds tracking of asynchronously
@@ -596,19 +588,19 @@ structure Environment where
   /-- Information about this asynchronous branch of the environment, if any. -/
   private asyncCtx?   : Option AsyncContext := none
   /--
-  Realized constants belonging to imported declarations. Must be initialized by calling
+  Realized values belonging to imported declarations. Must be initialized by calling
   `enableRealizationsForImports`.
   -/
-  private realizedImportedConsts? : Option RealizationContext
+  private importRealizationCtx? : Option RealizationContext
   /--
-  Realized constants belonging to local declarations. This is a map from local declarations, which
+  Realized values belonging to local declarations. This is a map from local declarations, which
   need to be registered synchronously using `enableRealizationsForConst`, to their realization
-  context incl. a ref of realized constants.
+  context.
   -/
-  private realizedLocalConsts  : NameMap RealizationContext := {}
+  private localRealizationCtxMap  : NameMap RealizationContext := {}
   /--
-  Task collecting all realizations from the current and already-forked environment branches, akin to
-  how `checked` collects all declarations. We only use it as a fallback in
+  Task collecting all realized constants from the current and already-forked environment branches,
+  akin to how `checked` collects all declarations. We only use it as a fallback in
   `findAsyncCore?`/`getState`; see there.
   -/
   private allRealizations : Task (NameMap AsyncConst) := .pure {}
@@ -649,7 +641,7 @@ private def asyncConsts (env : Environment) : AsyncConsts :=
 -- both cases, the environment should be temporary and not leak into elaboration.
 @[export lean_elab_environment_of_kernel_env]
 def ofKernelEnv (env : Kernel.Environment) : Environment :=
-  { base.private := env, base.public := env, realizedImportedConsts? := none }
+  { base.private := env, base.public := env, importRealizationCtx? := none }
 
 @[export lean_elab_environment_to_kernel_env]
 def toKernelEnv (env : Environment) : Kernel.Environment :=
@@ -684,7 +676,7 @@ it.
 -/
 def importEnv? (env : Environment) : Option Environment :=
   -- safety: `RealizationContext` is private
-  unsafe env.realizedImportedConsts?.map (unsafeCast (β := Environment) ·.env)
+  unsafe env.importRealizationCtx?.map (unsafeCast (β := Environment) ·.env)
 
 /-- Forgets about the asynchronous context restrictions. Used only for `withoutModifyingEnv`. -/
 def unlockAsync (env : Environment) : Environment :=
@@ -869,25 +861,22 @@ def enableRealizationsForConst (env : Environment) (opts : Options) (c : Name) :
     if !asyncCtx.mayContain c then
       panic! s!"{c} is outside current context {asyncCtx.declPrefix}"
       return env
-  if env.realizedLocalConsts.contains c then
+  if env.localRealizationCtxMap.contains c then
     return env
-  return { env with realizedLocalConsts := env.realizedLocalConsts.insert c {
+  return { env with localRealizationCtxMap := env.localRealizationCtxMap.insert c {
     -- safety: `RealizationContext` is private
     env := unsafe unsafeCast env
     opts
-    constsRef := (← IO.mkRef {}) } }
+    realizeMapRef := (← IO.mkRef {}) } }
+
+def areRealizationsEnabledForConst (env : Environment) (c : Name) : Bool :=
+  (env.base.get env |>.const2ModIdx.contains c) || env.localRealizationCtxMap.contains c
 
 /-- Returns debug output about the asynchronous state of the environment. -/
 def dbgFormatAsyncState (env : Environment) : BaseIO String :=
   return s!"\
     asyncCtx.declPrefix: {repr <| env.asyncCtx?.map (·.declPrefix)}\
-  \nasyncConsts: {repr <| env.asyncConsts.revList.reverse.map (·.constInfo.name)}\
-  \nrealizedLocalConsts: {repr (← env.realizedLocalConsts.toList.mapM fun (n, ctx) => do
-    let consts := (← ctx.constsRef.get).toList
-    return (n, consts.map (·.1)))}
-  \nrealizedImportedConsts?: {repr <| (← env.realizedImportedConsts?.mapM fun ctx => do
-    return (← ctx.constsRef.get).toList.map fun (n, m?) =>
-      (n, m?.get.1.private.map (fun c : AsyncConst => c.constInfo.name.toString) |> toString))}
+  \nasyncConsts: {repr <| env.asyncConsts.revList.reverse.map (·.constInfo.name)}
   \nbase.private.constants.map₂: {repr <| env.base.private.constants.map₂.toList.map (·.1)}"
 
 /-- Returns debug output about the synchronous state of the environment. -/
@@ -1158,7 +1147,7 @@ def setMainModule (env : Environment) (m : Name) : Environment := Id.run do
   let env := env.modifyCheckedAsync ({ · with
     header.mainModule := m
   })
-  { env with realizedImportedConsts? := env.realizedImportedConsts?.map ({ · with
+  { env with importRealizationCtx? := env.importRealizationCtx?.map ({ · with
       -- safety: `RealizationContext` is private
       env := unsafe unsafeCast env
     }) }
@@ -1515,7 +1504,7 @@ def mkEmptyEnvironment (trustLevel : UInt32 := 0) : IO Environment := do
       extensions      := exts
       irBaseExts      := exts
     }
-    realizedImportedConsts? := none
+    importRealizationCtx? := none
   }
 
 structure PersistentEnvExtensionState (α : Type) (σ : Type) where
@@ -2189,7 +2178,7 @@ def finalizeImport (s : ImportState) (imports : Array Import) (opts : Options) (
   let mut env : Environment := {
     base.private := privateBase
     base.public  := publicBase
-    realizedImportedConsts? := none
+    importRealizationCtx? := none
     serverBaseExts := (← setImportedEntries privateBase.extensions serverData)
   }
   if leakEnv then
@@ -2215,11 +2204,11 @@ def finalizeImport (s : ImportState) (imports : Array Import) (opts : Options) (
         Safety: There are no concurrent accesses to `env` at this point, assuming
         extensions' `addImportFn`s did not spawn any unbound tasks. -/
       env ← unsafe Runtime.markPersistent env
-  return { env with realizedImportedConsts? := some {
+  return { env with importRealizationCtx? := some {
     -- safety: `RealizationContext` is private
     env := unsafe unsafeCast env
     opts
-    constsRef := (← IO.mkRef {})
+    realizeMapRef := (← IO.mkRef {})
   } }
 
 /--
@@ -2432,98 +2421,123 @@ def hasUnsafe (env : Environment) (e : Expr) : Bool :=
     | _ => false;
   c?.isSome
 
+/-- Plumbing function for `Lean.Meta.realizeValue`; see documentation there. -/
+def realizeValue [BEq α] [Hashable α] [TypeName α] (env : Environment) (forConst : Name) (key : α)
+    (realize : Environment → Options → BaseIO Dynamic) : IO Dynamic := do
+  -- the following code is inherently non-deterministic in number of heartbeats, reset them at the
+  -- end
+  let heartbeats ← IO.getNumHeartbeats
+  -- find `RealizationContext` for `forConst` in `importRealizationCtx?` or `localRealizationCtxMap`
+  let ctx ← if env.base.get env |>.const2ModIdx.contains forConst then
+    env.importRealizationCtx?.getDM <|
+      throw <| .userError s!"Environment.realizeConst: `realizedImportedConsts` is empty"
+  else
+    match env.localRealizationCtxMap.find? forConst with
+    | some ctx => pure ctx
+    | none =>
+      throw <| .userError s!"trying to realize `{TypeName.typeName α}` value but \
+        `enableRealizationsForConst` must be called for '{forConst}' first"
+  let prom ← IO.Promise.new
+  -- atomically check whether we are the first branch to realize `key`
+  let existingConsts? ← ctx.realizeMapRef.modifyGet fun m =>
+    -- Safety: `typeName α` should uniquely identify `PHashMap α (Task Dynamic)`; there are no other
+    -- accesses to `private realizeMapRef` outside this function.
+    let m' := match m.find? (TypeName.typeName α) with
+      | some m' => unsafe unsafeCast (β := PHashMap α (Task Dynamic)) m'
+      | none    => {}
+    match m'[key] with
+    | some prom' => (some prom', m)
+    | none =>
+      let m' := m'.insert key prom.result!
+      let m := m.insert (TypeName.typeName α) (unsafe unsafeCast (β := NonScalar) m')
+      (none, m)
+  let res ← if let some t := existingConsts? then
+    pure t.get
+  else
+    -- safety: `RealizationContext` is private
+    let realizeEnv : Environment := unsafe unsafeCast ctx.env
+    let realizeEnv := { realizeEnv with
+      -- allow realizations to recursively realize other constants for `forConst`. Do note that
+      -- this allows for recursive realization of `α` itself, which will deadlock.
+      localRealizationCtxMap := realizeEnv.localRealizationCtxMap.insert forConst ctx
+      importRealizationCtx? := env.importRealizationCtx?
+    }
+    let res ← realize realizeEnv ctx.opts
+    prom.resolve res
+    pure res
+  IO.setNumHeartbeats heartbeats
+  return res
+
+private structure RealizeConstKey where
+  constName : Name
+deriving BEq, Hashable, TypeName
+
+/-- Realization results, to be replayed onto other branches. -/
+private structure RealizeConstResult where
+  newConsts : VisibilityMap (List AsyncConst)
+  replayKernel : Kernel.Environment → Except Kernel.Exception Kernel.Environment
+  dyn : Dynamic
+deriving Nonempty, TypeName
+
 /-- Plumbing function for `Lean.Meta.realizeConst`; see documentation there. -/
 def realizeConst (env : Environment) (forConst : Name) (constName : Name)
     (realize : Environment → Options → BaseIO (Environment × Dynamic)) :
     IO (Environment × Task (Option Kernel.Exception) × Dynamic) := do
-  -- the following code is inherently non-deterministic in number of heartbeats, reset them at the
-  -- end
-  let heartbeats ← IO.getNumHeartbeats
-  if env.asyncCtx?.any (·.realizingStack.contains constName) then
-    throw <| IO.userError s!"Environment.realizeConst: cyclic realization of '{constName}'"
-  let mut env := env
-  -- find `RealizationContext` for `forConst` in `realizedImportedConsts?` or `realizedLocalConsts`
-  let ctx ← if env.base.get env |>.const2ModIdx.contains forConst then
-    env.realizedImportedConsts?.getDM <|
-      throw <| .userError s!"Environment.realizeConst: `realizedImportedConsts` is empty"
-  else
-    match env.realizedLocalConsts.find? forConst with
-    | some ctx => pure ctx
-    | none =>
-      throw <| .userError s!"trying to realize {constName} but `enableRealizationsForConst` must be called for '{forConst}' first"
-  let prom ← IO.Promise.new
-  -- ensure `prom` is not left unresolved from stray exceptions
-  BaseIO.toIO do
-    -- atomically check whether we are the first branch to realize `constName`
-    let existingConsts? ← ctx.constsRef.modifyGet fun m => match m.find? constName with
-      | some prom' => (some prom', m)
-      | none       => (none, m.insert constName prom.result!)
-    let res ← if let some existingConsts := existingConsts? then
-      pure existingConsts.get
-    else
-      -- safety: `RealizationContext` is private
-      let realizeEnv : Environment := unsafe unsafeCast ctx.env
-      let realizeEnv := { realizeEnv with
-        -- allow realizations to recursively realize other constants for `forConst`. Do note that
-        -- this allows for recursive realization of `constName` itself, which will deadlock.
-        realizedLocalConsts := realizeEnv.realizedLocalConsts.insert forConst ctx
-        realizedImportedConsts? := env.realizedImportedConsts?
-      }
-      -- ensure that environment extension modifications know they are in an async context
-      let realizeEnv := realizeEnv.enterAsyncRealizing constName
-      -- skip kernel in `realize`, we'll re-typecheck anyway
-      let realizeOpts := debug.skipKernelTC.set ctx.opts true
-      let (realizeEnv', dyn) ← realize realizeEnv realizeOpts
-      -- We could check that `c` was indeed added here but in practice `realize` has already
-      -- reported an error so we don't.
+  let res ← env.realizeValue forConst { constName : RealizeConstKey } fun realizeEnv realizeOpts => do
+    -- ensure that environment extension modifications know they are in an async context
+    let realizeEnv := realizeEnv.enterAsyncRealizing constName
+    -- skip kernel in `realize`, we'll re-typecheck anyway
+    let realizeOpts := debug.skipKernelTC.set realizeOpts true
+    let (realizeEnv', dyn) ← realize realizeEnv realizeOpts
+    -- We could check that `c` was indeed added here but in practice `realize` has already
+    -- reported an error so we don't.
 
-      -- find new constants incl. nested realizations, add current extension state, and compute
-      -- closure
-      let numNewPrivateConsts := realizeEnv'.asyncConstsMap.private.size - realizeEnv.asyncConstsMap.private.size
-      let newPrivateConsts := realizeEnv'.asyncConstsMap.private.revList.take numNewPrivateConsts |>.reverse
-      let newPrivateConsts := newPrivateConsts.map fun c =>
-        let c := { c with isRealized := true }
-        if c.exts?.isNone then
-          { c with exts? := some <| .pure realizeEnv'.base.private.extensions }
-        else c
-      let numNewPublicConsts := realizeEnv'.asyncConstsMap.public.size - realizeEnv.asyncConstsMap.public.size
-      let newPublicConsts := realizeEnv'.asyncConstsMap.public.revList.take numNewPublicConsts |>.reverse
-      let newPublicConsts := newPublicConsts.map fun c =>
-        let c := { c with isRealized := true }
-        if c.exts?.isNone then
-          { c with exts? := some <| .pure realizeEnv'.base.private.extensions }
-        else c
-      let exts ← EnvExtension.envExtensionsRef.get
-      let replayKernel := replayConsts.replayKernel (skipExisting := true) realizeEnv realizeEnv' exts newPrivateConsts
-      let res := { newConsts.private := newPrivateConsts, newConsts.public := newPublicConsts, replayKernel, dyn }
-      prom.resolve res
-      pure res
-    let exPromise ← IO.Promise.new
-    let env := { env with
-      asyncConstsMap := {
-        «private» := res.newConsts.private.foldl (init := env.asyncConstsMap.private) fun consts c =>
-          if consts.find? c.constInfo.name |>.isSome then
-            consts
-          else
-            consts.add c
-        «public»  := res.newConsts.public.foldl (init := env.asyncConstsMap.public) fun consts c =>
-          if consts.find? c.constInfo.name |>.isSome then
-            consts
-          else
-            consts.add c
-      }
-      checked := (← BaseIO.mapTask (t := env.checked) fun kenv => do
-        match res.replayKernel kenv with
-        | .ok kenv => return kenv
-        | .error e =>
-          exPromise.resolve e
-          return kenv)
-      allRealizations := env.allRealizations.map (sync := true) fun allRealizations =>
-        res.newConsts.private.foldl (init := allRealizations) fun allRealizations c =>
-          allRealizations.insert c.constInfo.name c
+    -- find new constants incl. nested realizations, add current extension state, and compute
+    -- closure
+    let numNewPrivateConsts := realizeEnv'.asyncConstsMap.private.size - realizeEnv.asyncConstsMap.private.size
+    let newPrivateConsts := realizeEnv'.asyncConstsMap.private.revList.take numNewPrivateConsts |>.reverse
+    let newPrivateConsts := newPrivateConsts.map fun c =>
+      let c := { c with isRealized := true }
+      if c.exts?.isNone then
+        { c with exts? := some <| .pure realizeEnv'.base.private.extensions }
+      else c
+    let numNewPublicConsts := realizeEnv'.asyncConstsMap.public.size - realizeEnv.asyncConstsMap.public.size
+    let newPublicConsts := realizeEnv'.asyncConstsMap.public.revList.take numNewPublicConsts |>.reverse
+    let newPublicConsts := newPublicConsts.map fun c =>
+      let c := { c with isRealized := true }
+      if c.exts?.isNone then
+        { c with exts? := some <| .pure realizeEnv'.base.private.extensions }
+      else c
+    let exts ← EnvExtension.envExtensionsRef.get
+    let replayKernel := replayConsts.replayKernel (skipExisting := true) realizeEnv realizeEnv' exts newPrivateConsts
+    let res : RealizeConstResult := { newConsts.private := newPrivateConsts, newConsts.public := newPublicConsts, replayKernel, dyn }
+    pure (.mk res)
+  let some res := res.get? RealizeConstResult | unreachable!
+  let exPromise ← IO.Promise.new
+  let env := { env with
+    asyncConstsMap := {
+      «private» := res.newConsts.private.foldl (init := env.asyncConstsMap.private) fun consts c =>
+        if consts.find? c.constInfo.name |>.isSome then
+          consts
+        else
+          consts.add c
+      «public»  := res.newConsts.public.foldl (init := env.asyncConstsMap.public) fun consts c =>
+        if consts.find? c.constInfo.name |>.isSome then
+          consts
+        else
+          consts.add c
     }
-    IO.setNumHeartbeats heartbeats
-    return (env, exPromise.result?, res.dyn)
+    checked := (← BaseIO.mapTask (t := env.checked) fun kenv => do
+      match res.replayKernel kenv with
+      | .ok kenv => return kenv
+      | .error e =>
+        exPromise.resolve e
+        return kenv)
+    allRealizations := env.allRealizations.map (sync := true) fun allRealizations =>
+      res.newConsts.private.foldl (init := allRealizations) fun allRealizations c =>
+        allRealizations.insert c.constInfo.name c
+  }
+  return (env, exPromise.result?, res.dyn)
 
 end Environment
 

src/Lean/Level.lean

@@ -288,7 +288,7 @@ def normLtAux : Level → Nat → Level → Nat → Bool
 def normLt (l₁ l₂ : Level) : Bool :=
   normLtAux l₁ 0 l₂ 0
 
-private def isAlreadyNormalizedCheap : Level → Bool
+def isAlreadyNormalizedCheap : Level → Bool
   | zero    => true
   | param _ => true
   | mvar _  => true

src/Lean/Linter/UnusedVariables.lean

@@ -232,7 +232,7 @@ builtin_initialize addBuiltinUnusedVariablesIgnoreFn (fun _ stack _ =>
     stx.isOfKind ``Lean.Parser.Command.optDeclSig ||
     stx.isOfKind ``Lean.Parser.Command.declSig) &&
   (stack[5]? |>.any fun (stx, _) => match stx[0] with
-    | `(Lean.Parser.Command.declModifiersT| $[$_:docComment]? @[$[$attrs:attr],*] $[$vis]? $[noncomputable]?) =>
+    | `(Lean.Parser.Command.declModifiersT| $[$_:docComment]? @[$[$attrs:attr],*] $[$vis]? $[protected]? $[noncomputable]?) =>
       attrs.any (fun attr => attr.raw.isOfKind ``Parser.Attr.extern || attr matches `(attr| implemented_by $_))
     | _ => false))
 

src/Lean/Meta/AbstractNestedProofs.lean

@@ -70,7 +70,7 @@ partial def visit (e : Expr) : M Expr := do
         lctx := lctx.modifyLocalDecl xFVarId fun _ => localDecl
       withLCtx lctx localInstances k
     checkCache { val := e : ExprStructEq } fun _ => do
-      if (← withoutExporting do isNonTrivialProof e) then
+      if (← isNonTrivialProof e) then
         /- Ensure proofs nested in type are also abstracted -/
         abstractProof e (← read).cache visit
       else match e with

src/Lean/Meta/Basic.lean

@@ -295,6 +295,7 @@ structure FunInfo where
     That is, the (0-indexed) position of parameters that the result type depends on.
   -/
   resultDeps : Array Nat       := #[]
+deriving TypeName
 
 /--
 Key for the function information cache.
@@ -1951,6 +1952,18 @@ def withErasedFVars [MonadLCtx n] [MonadLiftT MetaM n] (fvarIds : Array FVarId)
   let localInsts' := localInsts.filter (!fvarIds.contains ·.fvar.fvarId!)
   withLCtx lctx' localInsts' k
 
+/--
+Ensures that the user names of all local declarations after index `idx` have a macro scope.
+-/
+def withFreshUserNamesSinceIdx [MonadLCtx n] [MonadLiftT MetaM n] (idx : Nat) (k : n α) : n α := do
+  let mut lctx ← getLCtx
+  for i in [idx:lctx.numIndices] do
+    let some decl := lctx.decls[i]! | continue
+    let n := decl.userName
+    if !n.hasMacroScopes then
+      lctx := lctx.setUserName decl.fvarId (← liftMetaM <| mkFreshUserName n)
+  withLCtx' lctx k
+
 private def withMVarContextImp (mvarId : MVarId) (x : MetaM α) : MetaM α := do
   let mvarDecl ← mvarId.getDecl
   withLocalContextImp mvarDecl.lctx mvarDecl.localInstances x
@@ -2457,8 +2470,86 @@ private partial def setAllDiagRanges (snap : Language.SnapshotTree) (pos endPos
 
 open Language
 
+private structure RealizeValueResult where
+  res?   : Except Exception Dynamic
+  snap?  : Option SnapshotTree
+deriving TypeName
+
+/--
+Realizes and caches a value for a given key with all environment objects derived from calling
+`enableRealizationsForConst forConst` (fails if not called yet). If
+this is the first environment branch passing the specific `key`, `realize` is called with the
+environment and options at the time of calling `enableRealizationsForConst` if `forConst` is from
+the current module and the state just after importing  otherwise, thus helping achieve deterministic
+results despite the non-deterministic choice of which thread is tasked with realization. In other
+words, the result of `realizeValue` is *as if* `realize` had been called immediately after
+`enableRealizationsForConst forConst`, with most effects but the return value discarded (see below).
+Whether two calls of `realizeValue` with different `forConst`s but the same `key` share the result
+is undefined; in practice, the key should usually uniquely determine `forConst` by e.g. including it
+as a field.
+
+`realizeValue` cannot check what other data is captured in the `realize` closure,
+so it is best practice to extract it into a separate function and pass only arguments uniquely
+determined by `key`. Traces, diagnostics, and raw std stream
+output of `realize` are reported at all callers via `Core.logSnapshotTask` (so that the location of
+generated diagnostics is deterministic). Note that, as `realize` is run using the options at
+declaration time of `forConst`, trace options must be set prior to that (or, for imported constants,
+on the cmdline) in order to be active. If `realize` throws an exception, it is rethrown at all
+callers.
+-/
+def realizeValue [BEq α] [Hashable α] [TypeName α] [TypeName β] (forConst : Name) (key : α) (realize : MetaM β) :
+    MetaM β := do
+  let env ← getEnv
+  if !env.areRealizationsEnabledForConst forConst then
+    return (← realize)
+  let coreCtx ← readThe Core.Context
+  let coreCtx := {
+    -- these fields should be invariant throughout the file
+    fileName := coreCtx.fileName, fileMap := coreCtx.fileMap
+    -- heartbeat limits inside `realizeAndReport` should be measured from this point on
+    initHeartbeats := (← IO.getNumHeartbeats)
+  }
+  let res ← env.realizeValue forConst key (realizeAndReport coreCtx)
+  let some res := res.get? RealizeValueResult | unreachable!
+  if let some snap := res.snap? then
+    let mut snap := snap
+    -- localize diagnostics
+    if let some range := (← getRef).getRange? then
+      let fileMap ← getFileMap
+      snap ← setAllDiagRanges snap (fileMap.toPosition range.start) (fileMap.toPosition range.stop)
+    Core.logSnapshotTask <| .finished (stx? := none) snap
+  match res.res? with
+  | .ok dyn => dyn.get? β |>.getDM (unreachable!)
+  | .error e => throw e
+where
+  -- similar to `wrapAsyncAsSnapshot` but not sufficiently so to share code
+  realizeAndReport (coreCtx : Core.Context) env opts := do
+    let coreCtx := { coreCtx with options := opts }
+    let act :=
+      IO.FS.withIsolatedStreams (isolateStderr := Core.stderrAsMessages.get opts) (do
+        -- catch all exceptions
+        let _ : MonadExceptOf _ MetaM := MonadAlwaysExcept.except
+        observing do
+          realize)
+        <* addTraceAsMessages
+    let res? ← act |>.run' |>.run coreCtx { env } |>.toBaseIO
+    let res ← match res? with
+      | .ok ((output, err?), st) => pure {
+        snap? := (← Core.mkSnapshot? output coreCtx st)
+        res?  := err?.map (.mk)
+        : RealizeValueResult
+      }
+      | _ =>
+        let _ : Inhabited RealizeValueResult := ⟨{
+          snap? := (← Core.mkSnapshot? "" coreCtx { env })
+          res?  := default
+          : RealizeValueResult
+        }⟩
+        unreachable!
+    return .mk (α := RealizeValueResult) res
+
 private structure RealizeConstantResult where
-  snap       : SnapshotTree
+  snap?  : Option SnapshotTree
   error? : Option Exception
 deriving TypeName
 
@@ -2515,12 +2606,13 @@ def realizeConst (forConst : Name) (constName : Name) (realize : MetaM Unit) :
       cancelTk? := none
     }
     if let some res := dyn.get? RealizeConstantResult then
-      let mut snap := res.snap
-      -- localize diagnostics
-      if let some range := (← getRef).getRange? then
-        let fileMap ← getFileMap
-        snap ← setAllDiagRanges snap (fileMap.toPosition range.start) (fileMap.toPosition range.stop)
-      Core.logSnapshotTask <| .finished (stx? := none) snap
+      if let some snap := res.snap? then
+        let mut snap := snap
+        -- localize diagnostics
+        if let some range := (← getRef).getRange? then
+          let fileMap ← getFileMap
+          snap ← setAllDiagRanges snap (fileMap.toPosition range.start) (fileMap.toPosition range.stop)
+        Core.logSnapshotTask <| .finished (stx? := none) snap
       if let some e := res.error? then
         throw e
     setEnv env
@@ -2543,7 +2635,7 @@ where
     let res? ← act |>.run' |>.run coreCtx { env } |>.toBaseIO
     match res? with
     | .ok ((output, err?), st) => pure (st.env, .mk {
-      snap := (← Core.mkSnapshot output coreCtx st)
+      snap?  := (← Core.mkSnapshot? output coreCtx st)
       error? := match err? with
         | .ok ()   => none
         | .error e => some e
@@ -2551,7 +2643,7 @@ where
     })
     | _ =>
       let _ : Inhabited (Environment × Dynamic) := ⟨env, .mk {
-        snap := (← Core.mkSnapshot "" coreCtx { env })
+        snap?  := (← Core.mkSnapshot? "" coreCtx { env })
         error? := none
         : RealizeConstantResult
       }⟩

src/Lean/Meta/CollectMVars.lean

@@ -50,39 +50,50 @@ def getMVarsAtDecl (d : Declaration) : MetaM (Array MVarId) := do
   let (_, s) ← (collectMVarsAtDecl d).run {}
   pure s.result
 
+end Lean.Meta
+
+open Lean Meta
+
+mutual
+
+/-- Auxiliary definition for `getMVarDependencies`. -/
+private partial def addMVars (e : Expr) (includeDelayed := false) : StateRefT (Std.HashSet MVarId) MetaM Unit := do
+  let mvars ← getMVars e
+  let mut s ← get
+  set ({} : Std.HashSet MVarId) -- Ensure that `s` is not shared.
+  for mvarId in mvars do
+    if ← pure includeDelayed <||> notM (mvarId.isDelayedAssigned) then
+      s := s.insert mvarId
+  set s
+  mvars.forM go
+
+/-- Auxiliary definition for `getMVarDependencies`. -/
+private partial def go (mvarId : MVarId) (includeDelayed := false) : StateRefT (Std.HashSet MVarId) MetaM Unit :=
+  withIncRecDepth do
+    let mdecl ← mvarId.getDecl
+    addMVars mdecl.type includeDelayed
+    for ldecl in mdecl.lctx do
+      addMVars ldecl.type includeDelayed
+      if let (some val) := ldecl.value? then
+        addMVars val includeDelayed
+    if let (some ass) ← getDelayedMVarAssignment? mvarId then
+      let pendingMVarId := ass.mvarIdPending
+      if ← notM pendingMVarId.isAssignedOrDelayedAssigned then
+        modify (·.insert pendingMVarId)
+      go pendingMVarId includeDelayed
+
+end
+
 /--
 Collect the metavariables which `mvarId` depends on. These are the metavariables
 which appear in the type and local context of `mvarId`, as well as the
 metavariables which *those* metavariables depend on, etc.
 -/
-partial def _root_.Lean.MVarId.getMVarDependencies (mvarId : MVarId) (includeDelayed := false) :
+def Lean.MVarId.getMVarDependencies (mvarId : MVarId) (includeDelayed := false) :
     MetaM (Std.HashSet MVarId) :=
-  (·.snd) <$> (go mvarId).run {}
-where
-  /-- Auxiliary definition for `getMVarDependencies`. -/
-  addMVars (e : Expr) : StateRefT (Std.HashSet MVarId) MetaM Unit := do
-    let mvars ← getMVars e
-    let mut s ← get
-    set ({} : Std.HashSet MVarId) -- Ensure that `s` is not shared.
-    for mvarId in mvars do
-      if ← pure includeDelayed <||> notM (mvarId.isDelayedAssigned) then
-        s := s.insert mvarId
-    set s
-    mvars.forM go
+  (·.snd) <$> (go mvarId includeDelayed).run {}
 
-  /-- Auxiliary definition for `getMVarDependencies`. -/
-  go (mvarId : MVarId) : StateRefT (Std.HashSet MVarId) MetaM Unit :=
-    withIncRecDepth do
-      let mdecl ← mvarId.getDecl
-      addMVars mdecl.type
-      for ldecl in mdecl.lctx do
-        addMVars ldecl.type
-        if let (some val) := ldecl.value? then
-          addMVars val
-      if let (some ass) ← getDelayedMVarAssignment? mvarId then
-        let pendingMVarId := ass.mvarIdPending
-        if ← notM pendingMVarId.isAssignedOrDelayedAssigned then
-          modify (·.insert pendingMVarId)
-        go pendingMVarId
-
-end Lean.Meta
+/-- Collect the metavariables appearing in the expression `e`,
+including metavariables in the type or local context of any such metavariables, etc. -/
+def Lean.Expr.getMVarDependencies (e : Expr) (includeDelayed := false) : MetaM (Std.HashSet MVarId) := do
+  (·.snd) <$> (addMVars e includeDelayed).run {}

src/Lean/Meta/CongrTheorems.lean

@@ -295,9 +295,7 @@ private partial def mkCast (fvarId : FVarId) (type : Expr) (deps : Array Nat) (e
       mvarId := mvarId'
   let fvarId := getFVarId s fvarId
   mvarId.assign (mkFVar fvarId)
-  let r ← instantiateMVars mvar
-  trace[Meta.debug] "{r} : {← inferType r}"
-  return r
+  instantiateMVars mvar
 
 /--
 Creates a congruence theorem that is useful for the simplifier and `congr` tactic.

src/Lean/Meta/Tactic/Grind/Arith/Simproc.lean

@@ -101,6 +101,22 @@ builtin_dsimproc_decl normNatDivInst ((_ / _ : Nat)) := normInst 3 Nat.mkInstHDi
 builtin_dsimproc_decl normNatModInst ((_ % _ : Nat)) := normInst 3 Nat.mkInstMod
 builtin_dsimproc_decl normNatPowInst ((_ ^ _ : Nat)) := normInst 3 Nat.mkInstHPow
 
+/--
+Returns `true`, if `@OfNat.ofNat α n inst` is the standard way we represent `Nat` numerals in Lean.
+-/
+private def isNormNatNum (α n inst : Expr) : Bool := Id.run do
+  unless α.isConstOf ``Nat do return false
+  let .lit (.natVal _) := n | return false
+  unless inst.isAppOfArity ``instOfNatNat 1 do return false
+  return inst.appArg! == n
+
+builtin_dsimproc_decl normNatOfNatInst ((OfNat.ofNat _: Nat)) := fun e => do
+  let_expr OfNat.ofNat α n inst := e | return .continue
+  if isNormNatNum α n inst then
+    return .done e
+  let some n ← getNatValue? e | return .continue
+  return .done (mkNatLit n)
+
 builtin_dsimproc_decl normIntNegInst ((- _ : Int)) := normInst 1 Int.mkInstNeg
 builtin_dsimproc_decl normIntAddInst ((_ + _ : Int)) := normInst 3 Int.mkInstHAdd
 builtin_dsimproc_decl normIntMulInst ((_ * _ : Int)) := normInst 3 Int.mkInstHMul
@@ -109,6 +125,22 @@ builtin_dsimproc_decl normIntDivInst ((_ / _ : Int)) := normInst 3 Int.mkInstHDi
 builtin_dsimproc_decl normIntModInst ((_ % _ : Int)) := normInst 3 Int.mkInstMod
 builtin_dsimproc_decl normIntPowInst ((_ ^ _ : Int)) := normInst 3 Int.mkInstHPow
 
+/--
+Returns `true`, if `@OfNat.ofNat α n inst` is the standard way we represent `Int` numerals in Lean.
+-/
+private def isNormIntNum (α n inst : Expr) : Bool := Id.run do
+  unless α.isConstOf ``Int do return false
+  let .lit (.natVal _) := n | return false
+  unless inst.isAppOfArity ``instOfNat 1 do return false
+  return inst.appArg! == n
+
+builtin_dsimproc_decl normIntOfNatInst ((OfNat.ofNat _: Int)) := fun e => do
+  let_expr OfNat.ofNat α n inst := e | return .continue
+  if isNormIntNum α n inst then
+    return .done e
+  let some n ← getIntValue? e | return .continue
+  return .done (mkIntLit n)
+
 /-!
 Add additional arithmetic simprocs
 -/
@@ -122,6 +154,7 @@ def addSimproc (s : Simprocs) : CoreM Simprocs := do
   let s ← s.add ``normNatDivInst (post := false)
   let s ← s.add ``normNatModInst (post := false)
   let s ← s.add ``normNatPowInst (post := false)
+  let s ← s.add ``normNatOfNatInst (post := false)
   let s ← s.add ``normIntNegInst (post := false)
   let s ← s.add ``normIntAddInst (post := false)
   let s ← s.add ``normIntMulInst (post := false)
@@ -129,6 +162,7 @@ def addSimproc (s : Simprocs) : CoreM Simprocs := do
   let s ← s.add ``normIntDivInst (post := false)
   let s ← s.add ``normIntModInst (post := false)
   let s ← s.add ``normIntPowInst (post := false)
+  let s ← s.add ``normIntOfNatInst (post := false)
   return s
 
 end Lean.Meta.Grind.Arith

src/Lean/Meta/Tactic/Grind/Canon.lean

@@ -202,7 +202,6 @@ partial def canon (e : Expr) : GoalM Expr := do profileitM Exception "grind cano
 where
   visit (e : Expr) : StateRefT (Std.HashMap ExprPtr Expr) GoalM Expr := do
     unless e.isApp || e.isForall do return e
-    if (← inShareCommon e) then return e
     -- Check whether it is cached
     if let some r := (← get).get? { expr := e } then
       return r

src/Lean/Meta/Tactic/Grind/EMatch.lean

@@ -131,6 +131,33 @@ protected def _root_.Lean.Meta.Grind.GenPatternInfo.assign? (genInfo : GenPatter
   let c ← assignDelayedEqProof? c genInfo.hIdx
   return c
 
+private def matchGroundPattern (pArg eArg : Expr) : GoalM Bool := do
+  /-
+  1) Remark:
+  We need to use `withReducibleAndInstances` because ground patterns are often instances.
+  Here is an example
+  ```
+  instance : Max Nat where
+    max := Nat.max -- Redefined the instance
+
+  example (a : Nat) : max a a = a := by
+    grind
+  ```
+  Possible future improvements:
+  - When `diagnostics` is true, try with `withDefault` and report issue if it succeeds.
+  - (minor) Only use `withReducibleAndInstances` if the argument is an implicit instance.
+    Potential issue: some user write `{_ : Class α}` when the instance can be inferred from
+    explicit arguments.
+  2) Remark:
+  If `pArg` contains universe metavariables, we use `withoutModifyingMCtx` to ensure the metavariables
+  are not assigned. These universe metavariables are created at `internalizePattern` for universe polymorphic
+  ground patterns. They are not common, but they occur in practice.
+  -/
+  if pArg.hasLevelMVar then
+    withoutModifyingMCtx <| withReducibleAndInstances <| isDefEq pArg eArg
+  else
+    isEqv pArg eArg <||> withReducibleAndInstances (isDefEq pArg eArg)
+
 /-- Matches a pattern argument. See `matchArgs?`. -/
 private def matchArg? (c : Choice) (pArg : Expr) (eArg : Expr) : OptionT GoalM Choice := do
   if isPatternDontCare pArg then
@@ -138,23 +165,7 @@ private def matchArg? (c : Choice) (pArg : Expr) (eArg : Expr) : OptionT GoalM C
   else if pArg.isBVar then
     assign? c pArg.bvarIdx! eArg
   else if let some pArg := groundPattern? pArg then
-    /-
-    We need to use `withReducibleAndInstances` because ground patterns are often instances.
-    Here is an example
-    ```
-    instance : Max Nat where
-      max := Nat.max -- Redefined the instance
-
-    example (a : Nat) : max a a = a := by
-      grind
-    ```
-    Possible future improvements:
-    - When `diagnostics` is true, try with `withDefault` and report issue if it succeeds.
-    - (minor) Only use `withReducibleAndInstances` if the argument is an implicit instance.
-      Potential issue: some user write `{_ : Class α}` when the instance can be inferred from
-      explicit arguments.
-    -/
-    guard (← isEqv pArg eArg <||> withReducibleAndInstances (isDefEq pArg eArg))
+    guard (← matchGroundPattern pArg eArg)
     return c
   else if let some (pArg, k) := isOffsetPattern? pArg then
     assert! Option.isNone <| isOffsetPattern? pArg
@@ -165,7 +176,7 @@ private def matchArg? (c : Choice) (pArg : Expr) (eArg : Expr) : OptionT GoalM C
       let c ← assign? c pArg.bvarIdx! eArg
       genInfo.assign? c eArg
     else if let some pArg := groundPattern? pArg then
-      guard (← isEqv pArg eArg <||> withReducibleAndInstances (isDefEq pArg eArg))
+      guard (← matchGroundPattern pArg eArg)
       genInfo.assign? c eArg
     else if let some (pArg, k) := isOffsetPattern? pArg then
       return { c with cnstrs := .offset (some genInfo) pArg k eArg :: c.cnstrs }

src/Lean/Meta/Tactic/Grind/EMatchTheorem.lean

@@ -964,6 +964,9 @@ def addEMatchEqTheorem (declName : Name) : MetaM Unit := do
 def getEMatchTheorems : CoreM EMatchTheorems :=
   return ematchTheoremsExt.getState (← getEnv)
 
+def EMatchTheorems.getOrigins (s : EMatchTheorems) : List Origin :=
+  s.origins.toList
+
 /-- Returns the types of `xs` that are propositions. -/
 private def getPropTypes (xs : Array Expr) : MetaM (Array Expr) :=
   xs.filterMapM fun x => do

src/Lean/Meta/Tactic/Grind/Internalize.lean

@@ -12,6 +12,7 @@ public import Lean.Meta.LitValues
 public import Lean.Meta.Match.MatcherInfo
 public import Lean.Meta.Match.MatchEqsExt
 public import Lean.Meta.Match.MatchEqs
+public import Lean.Util.CollectLevelParams
 public import Lean.Meta.Tactic.Grind.Types
 public import Lean.Meta.Tactic.Grind.Util
 public import Lean.Meta.Tactic.Grind.Canon
@@ -151,7 +152,7 @@ private def mkENode' (e : Expr) (generation : Nat) : GoalM Unit :=
   mkENodeCore e (ctor := false) (interpreted := false) (generation := generation)
 
 /-- Internalizes the nested ground terms in the given pattern. -/
-private partial def internalizePattern (pattern : Expr) (generation : Nat) : GoalM Expr := do
+private partial def internalizePattern (pattern : Expr) (generation : Nat) (origin : Origin) : GoalM Expr := do
   -- Recall that it is important to ensure patterns are maximally shared since
   -- we assume that in functions such as `getAppsOf` in `EMatch.lean`
   go (← shareCommon pattern)
@@ -161,7 +162,21 @@ where
       return pattern
     else if let some e := groundPattern? pattern then
       let e ← preprocessLight e
-      internalize e generation none
+      let e ← if e.hasLevelParam && origin matches .decl _ then
+        /-
+        If `e` has universe parameters and it is **not** local. That is,
+        it contains the universe parameters of some global theorem.
+        Then, we convert `e`'s universe parameters into universe meta-variables.
+        Remark: it is pointless to internalize the result because it contains these helper meta-variables.
+        Remark: universe polymorphic ground patterns are not common, but they do occur in the
+        core library.
+        -/
+        let ps := collectLevelParams {} e |>.params
+        let us ← ps.mapM fun _ => mkFreshLevelMVar
+        pure <| e.instantiateLevelParamsArray ps us
+      else
+        internalize e generation none
+        pure e
       return mkGroundPattern e
     else pattern.withApp fun f args => do
       return mkAppN f (← args.mapM go)
@@ -203,7 +218,7 @@ def activateTheorem (thm : EMatchTheorem) (generation : Nat) : GoalM Unit := do
   -- Recall that we use the proof as part of the key for a set of instances found so far.
   -- We don't want to use structural equality when comparing keys.
   let proof ← shareCommon thm.proof
-  let thm := { thm with proof, patterns := (← thm.patterns.mapM (internalizePattern · generation)) }
+  let thm := { thm with proof, patterns := (← thm.patterns.mapM (internalizePattern · generation thm.origin)) }
   trace_goal[grind.ematch] "activated `{thm.origin.key}`, {thm.patterns.map ppPattern}"
   modify fun s => { s with ematch.newThms := s.ematch.newThms.push thm }
 
@@ -364,7 +379,7 @@ private partial def internalizeImpl (e : Expr) (generation : Nat) (parent? : Opt
     propagateEtaStruct e generation
 where
   go : GoalM Unit := do
-    trace_goal[grind.internalize] "{e}"
+    trace_goal[grind.internalize] "[{generation}] {e}"
     match e with
     | .bvar .. => unreachable!
     | .sort .. => return ()

src/Lean/Meta/Tactic/Grind/MarkNestedSubsingletons.lean

@@ -44,7 +44,6 @@ partial def markNestedSubsingletons (e : Expr) : GrindM Expr := do profileitM Ex
   visit e |>.run' {}
 where
   visit (e : Expr) : M Expr := do
-    if (← inShareCommon e) then return e
     if isMarkedSubsingletonApp e then
       return e -- `e` is already marked
     -- check whether result is cached

src/Lean/Meta/Tactic/Grind/Types.lean

@@ -334,16 +334,6 @@ def shareCommon (e : Expr) : GrindM Expr := do
   modify fun s => { s with scState }
   return e
 
-/--
-Returns `true` if `e` has already been hash-consed.
-Recall that we use `shareCommon` as the last step of the preprocessing
-function `preprocess`.
-Later, we create terms using new terms that have already been preprocessed,
-and we skip preprocessing steps by checking whether `inShareCommon` returns `true`
--/
-def inShareCommon (e : Expr) : GrindM Bool := do
-  return (← get).scState.map.contains { expr := e }
-
 /-- Returns `true` if `e` is the internalized `True` expression.  -/
 def isTrueExpr (e : Expr) : GrindM Bool :=
   return isSameExpr e (← getTrueExpr)

src/Lean/Meta/Tactic/Grind/Util.lean

@@ -83,7 +83,7 @@ Unfolds all `reducible` declarations occurring in `e`.
 -/
 def unfoldReducible (e : Expr) : MetaM Expr := do
   if !(← isUnfoldReducibleTarget e) then return e
-  Core.transform e (pre := unfoldReducibleStep)
+  Meta.transform e (pre := unfoldReducibleStep)
 
 /--
 Unfolds all `reducible` declarations occurring in the goal's target.
@@ -182,10 +182,18 @@ def foldProjs (e : Expr) : MetaM Expr := do
       return .done e
   Meta.transform e (post := post)
 
+/-- Quick filter for checking whether we can skip `normalizeLevels`. -/
+private def levelsAlreadyNormalized (e : Expr) : Bool :=
+  Option.isNone <| e.find? fun
+    | .const _ us => us.any (! ·.isAlreadyNormalizedCheap)
+    | .sort u => !u.isAlreadyNormalizedCheap
+    | _ => false
+
 /--
 Normalizes universe levels in constants and sorts.
 -/
 def normalizeLevels (e : Expr) : CoreM Expr := do
+  if levelsAlreadyNormalized e then return e
   let pre (e : Expr) := do
     match e with
     | .sort u => return .done <| e.updateSort! u.normalize

src/Lean/Parser/Command.lean

@@ -62,11 +62,11 @@ def namedPrio := leading_parser
 def optNamedPrio := optional namedPrio
 
 def «private»        := leading_parser "private "
-def «protected»      := leading_parser "protected "
 def «public»         := leading_parser "public "
 def visibility       :=
   withAntiquot (mkAntiquot "visibility" decl_name% (isPseudoKind := true)) <|
-    «private» <|> «protected» <|> «public»
+    «private» <|> «public»
+def «protected»      := leading_parser "protected "
 def «meta»           := leading_parser "meta "
 def «noncomputable»  := leading_parser "noncomputable "
 def «unsafe»         := leading_parser "unsafe "
@@ -76,7 +76,8 @@ def «nonrec»         := leading_parser "nonrec "
 /-- `declModifiers` is the collection of modifiers on a declaration:
 * a doc comment `/-- ... -/`
 * a list of attributes `@[attr1, attr2]`
-* a visibility specifier, `private`, `protected`, or `public`
+* a visibility specifier, `private` or `public`
+* `protected`
 * `noncomputable`
 * `unsafe`
 * `partial` or `nonrec`
@@ -90,6 +91,7 @@ such as inductive constructors, structure projections, and `let rec` / `where` d
   optional docComment >>
   optional (Term.«attributes» >> if inline then skip else ppDedent ppLine) >>
   optional visibility >>
+  optional «protected» >>
   optional («meta» <|> «noncomputable») >>
   optional «unsafe» >>
   optional («partial» <|> «nonrec»)
@@ -159,7 +161,7 @@ def whereStructInst  := leading_parser
 def «abbrev»         := leading_parser
   "abbrev " >> declId >> ppIndent optDeclSig >> declVal
 def optDefDeriving   :=
-  optional (ppDedent ppLine >> atomic ("deriving " >> notSymbol "instance") >> sepBy1 ident ", ")
+  optional (ppDedent ppLine >> atomic ("deriving " >> notSymbol "instance") >> sepBy1 termParser ", ")
 def definition     := leading_parser
   "def " >> recover declId skipUntilWsOrDelim >> ppIndent optDeclSig >> declVal >> optDefDeriving
 def «theorem»        := leading_parser
@@ -179,7 +181,7 @@ def «example»        := leading_parser
 def ctor             := leading_parser
   atomic (optional docComment >> "\n| ") >>
   ppGroup (declModifiers true >> rawIdent >> optDeclSig)
-def derivingClasses  := sepBy1 ident ", "
+def derivingClasses  := sepBy1 (withForbidden "for" termParser) ", "
 def optDeriving      := leading_parser
   optional (ppLine >> atomic ("deriving " >> notSymbol "instance") >> derivingClasses)
 def computedField    := leading_parser
@@ -251,7 +253,7 @@ def «structure»          := leading_parser
   («abbrev» <|> definition <|> «theorem» <|> «opaque» <|> «instance» <|> «axiom» <|> «example» <|>
    «inductive» <|> classInductive <|> «structure»)
 @[builtin_command_parser] def «deriving»     := leading_parser
-  "deriving " >> "instance " >> derivingClasses >> " for " >> sepBy1 (recover ident skip) ", "
+  "deriving " >> "instance " >> derivingClasses >> " for " >> sepBy1 (recover termParser skip) ", "
 def sectionHeader := leading_parser
   optional ("@[" >> nonReservedSymbol "expose" >> "] ") >>
   optional ("public ") >>

src/Lean/PrettyPrinter/Delaborator/Builtins.lean

@@ -62,13 +62,17 @@ def delabMVarAux (m : MVarId) : DelabM Term := do
   let mkMVar (n : Name) : DelabM Term := `(?$(mkIdent n))
   withTypeAscription (cond := ← getPPOption getPPMVarsWithType) do
     if ← getPPOption getPPMVars then
-      match (← m.getDecl).userName with
-      | .anonymous =>
-        if ← getPPOption getPPMVarsAnonymous then
-          mkMVar <| m.name.replacePrefix `_uniq `m
-        else
-          mkMVarPlaceholder
-      | n => mkMVar n
+      if let some decl ← m.findDecl? then
+        match decl.userName with
+        | .anonymous =>
+          if ← getPPOption getPPMVarsAnonymous then
+            mkMVar <| Name.num `m (decl.index + 1)
+          else
+            mkMVarPlaceholder
+        | n => mkMVar n
+      else
+        -- Undefined mvar, use internal name
+        mkMVar <| m.name.replacePrefix `_uniq `_mvar
     else
       mkMVarPlaceholder
 
@@ -1270,6 +1274,24 @@ def delabPProdMk : Delab := delabPProdMkCore ``PProd.mk
 @[builtin_delab app.MProd.mk]
 def delabMProdMk : Delab := delabPProdMkCore ``MProd.mk
 
+@[builtin_delab app.Std.Range.mk]
+def delabRange : Delab := do
+  -- Std.Range.mk : Nat → Nat → (step : Nat) → 0 < step → Std.Range
+  let_expr Std.Range.mk start _stop step _prf := (← getExpr) | failure
+  let start_zero := Lean.Expr.nat? start == some 0
+  let step_one := Lean.Expr.nat? step == some 1
+  withAppFn do -- skip the proof
+  let step ← withAppArg delab
+  withAppFn do
+  let stop ← withAppArg delab
+  withAppFn do
+  let start ← withAppArg delab
+  match start_zero, step_one with
+  | false, false => `([$start : $stop : $step])
+  | false, true => `([$start : $stop])
+  | true, false => `([: $stop : $step])
+  | true, true => `([: $stop])
+
 partial def delabDoElems : DelabM (List Syntax) := do
   let e ← getExpr
   if e.isAppOfArity ``Bind.bind 6 then

src/Std/Data/Internal/List/Associative.lean

@@ -15,6 +15,8 @@ public import Init.Data.List.MinMax
 public import Init.Data.List.Monadic
 public import all Std.Data.Internal.List.Defs
 public import Std.Classes.Ord.Basic
+import Init.Data.Subtype.Order
+import Init.Data.Order.Lemmas
 
 public section
 
@@ -5545,22 +5547,31 @@ private theorem le_min_iff [Ord α] [TransOrd α] {a b c : (a : α) × β a} :
   · simp only [Bool.not_eq_true, Ordering.isLE_eq_false, OrientedCmp.gt_iff_lt, iff_and_self] at *
     exact fun h => Ordering.isLE_of_eq_lt <| TransCmp.lt_of_isLE_of_lt h ‹_›
 
-theorem minEntry?_eq_some_iff [Ord α] [TransOrd α] [BEq α] [LawfulBEqOrd α] (a : (a : α) × β a) {l : List ((a : α) × β a)} (hd : DistinctKeys l) :
+private theorem antisymm_subtype [Ord α] [TransOrd α] [BEq α] [LawfulBEqOrd α]
+    {l : List ((a : α) × β a)} (hd : DistinctKeys l) :
+    Antisymm (α := Subtype (· ∈ l)) (· ≤ ·) where
+  antisymm a b hab hba := by
+    exact Subtype.ext
+      <| hd.eq_of_mem_of_beq a.property b.property
+      <| compare_eq_iff_beq.mp
+      <| OrientedCmp.isLE_antisymm hab hba
+
+theorem minEntry?_eq_some_iff [Ord α] [TransOrd α] [BEq α] [LawfulBEqOrd α] (a : (a : α) × β a)
+    {l : List ((a : α) × β a)} (hd : DistinctKeys l) :
     minEntry? l = some a ↔ a ∈ l ∧ ∀ b : α, containsKey b l → (compare a.fst b).isLE := by
-  rw [minEntry?, List.min?_eq_some_iff _ _ _ _]
-  · simp only [and_congr_right_iff]
-    intro hm
-    apply Iff.intro
-    · intro h k hk
-      obtain ⟨e, hel, hek⟩ := containsKey_eq_true_iff_exists_mem.mp hk
-      exact TransCmp.isLE_trans (h _ hel) <| Ordering.isLE_of_eq_eq <| compare_eq_iff_beq.mpr hek
-    · intro h e he
-      exact h _ <| containsKey_of_mem he
-  · exact fun _ => ReflCmp.isLE_rfl
-  · exact fun _ _ => min_eq_or
-  · exact fun a b c => le_min_iff
-  · intro e e' he he' hee' he'e
-    exact hd.eq_of_mem_of_beq he he' <| compare_eq_iff_beq.mp <| OrientedCmp.isLE_antisymm hee' he'e
+  haveI : LawfulOrderMin ((a : α) × β a) := .of_le (fun _ _ _ => le_min_iff) (fun _ _ => min_eq_or)
+  haveI : Refl (α := (a : α) × β a) (· ≤ ·) := ⟨fun _ => ReflCmp.isLE_rfl⟩
+  haveI : Antisymm (α := Subtype (· ∈ l)) (· ≤ ·) := antisymm_subtype hd
+  haveI : IsLinearOrder (Subtype (· ∈ l)) := IsLinearOrder.of_refl_of_antisymm_of_lawfulOrderMin
+  rw [minEntry?, List.min?_eq_some_iff_subtype]
+  simp only [and_congr_right_iff]
+  intro hm
+  apply Iff.intro
+  · intro h k hk
+    obtain ⟨e, hel, hek⟩ := containsKey_eq_true_iff_exists_mem.mp hk
+    exact TransCmp.isLE_trans (h _ hel) <| Ordering.isLE_of_eq_eq <| compare_eq_iff_beq.mpr hek
+  · intro h e he
+    exact h _ <| containsKey_of_mem he
 
 theorem minKey?_eq_some_iff_getKey?_eq_self_and_forall [Ord α] [TransOrd α] [BEq α] [LawfulBEqOrd α]
     {k} {l : List ((a : α) × β a)} (hd : DistinctKeys l) :

src/Std/Data/Iterators/Lemmas/Equivalence/HetT.lean

@@ -7,7 +7,7 @@ module
 
 prelude
 public import Init.Control.Lawful.Basic
-public import Init.Data.Subtype
+public import Init.Data.Subtype.Basic
 public import Init.PropLemmas
 public import Init.Classical
 public import Init.Data.Iterators.Internal.LawfulMonadLiftFunction

src/Std/Do/PostCond.lean

@@ -72,69 +72,69 @@ abbrev Assertion (ps : PostShape.{u}) : Type u :=
 /--
   Encodes one continuation barrel for each `PostShape.except` in the given predicate shape.
   ```
-  example : FailConds (.pure) = Unit := rfl
-  example : FailConds (.except ε .pure) = ((ε → ULift Prop) × Unit) := rfl
-  example : FailConds (.arg σ (.except ε .pure)) = ((ε → ULift Prop) × Unit) := rfl
-  example : FailConds (.except ε (.arg σ .pure)) = ((ε → σ → ULift Prop) × Unit) := rfl
+  example : ExceptConds (.pure) = Unit := rfl
+  example : ExceptConds (.except ε .pure) = ((ε → ULift Prop) × Unit) := rfl
+  example : ExceptConds (.arg σ (.except ε .pure)) = ((ε → ULift Prop) × Unit) := rfl
+  example : ExceptConds (.except ε (.arg σ .pure)) = ((ε → σ → ULift Prop) × Unit) := rfl
   ```
 -/
-def FailConds : PostShape.{u} → Type u
+def ExceptConds : PostShape.{u} → Type u
   | .pure => PUnit
-  | .arg _ ps => FailConds ps
-  | .except ε ps => (ε → Assertion ps) × FailConds ps
+  | .arg _ ps => ExceptConds ps
+  | .except ε ps => (ε → Assertion ps) × ExceptConds ps
 
 @[simp]
-def FailConds.const {ps : PostShape.{u}} (p : Prop) : FailConds ps := match ps with
+def ExceptConds.const {ps : PostShape.{u}} (p : Prop) : ExceptConds ps := match ps with
   | .pure => ⟨⟩
-  | .arg _ ps => @FailConds.const ps p
-  | .except _ ps => (fun _ε => spred(⌜p⌝), @FailConds.const ps p)
+  | .arg _ ps => @ExceptConds.const ps p
+  | .except _ ps => (fun _ε => spred(⌜p⌝), @ExceptConds.const ps p)
 
-def FailConds.true : FailConds ps := FailConds.const True
+def ExceptConds.true : ExceptConds ps := ExceptConds.const True
 
-def FailConds.false : FailConds ps := FailConds.const False
+def ExceptConds.false : ExceptConds ps := ExceptConds.const False
 
-instance : Inhabited (FailConds ps) where
-  default := FailConds.true
+instance : Inhabited (ExceptConds ps) where
+  default := ExceptConds.true
 
-def FailConds.entails {ps : PostShape.{u}} (x y : FailConds ps) : Prop :=
+def ExceptConds.entails {ps : PostShape.{u}} (x y : ExceptConds ps) : Prop :=
   match ps with
   | .pure => True
   | .arg _ ps => @entails ps x y
   | .except _ ps => (∀ e, x.1 e ⊢ₛ y.1 e) ∧ @entails ps x.2 y.2
 
-scoped infix:25 " ⊢ₑ " => FailConds.entails
+scoped infix:25 " ⊢ₑ " => ExceptConds.entails
 
 @[refl, simp]
-theorem FailConds.entails.refl {ps : PostShape} (x : FailConds ps) : x ⊢ₑ x := by
+theorem ExceptConds.entails.refl {ps : PostShape} (x : ExceptConds ps) : x ⊢ₑ x := by
   induction ps <;> simp [entails, *]
 
-theorem FailConds.entails.rfl {ps : PostShape} {x : FailConds ps} : x ⊢ₑ x := refl x
+theorem ExceptConds.entails.rfl {ps : PostShape} {x : ExceptConds ps} : x ⊢ₑ x := refl x
 
-theorem FailConds.entails.trans {ps : PostShape} {x y z : FailConds ps} : (x ⊢ₑ y) → (y ⊢ₑ z) → x ⊢ₑ z := by
+theorem ExceptConds.entails.trans {ps : PostShape} {x y z : ExceptConds ps} : (x ⊢ₑ y) → (y ⊢ₑ z) → x ⊢ₑ z := by
   induction ps
   case pure => intro _ _; trivial
   case arg σ s ih => exact ih
   case except ε s ih => intro h₁ h₂; exact ⟨fun e => (h₁.1 e).trans (h₂.1 e), ih h₁.2 h₂.2⟩
 
 @[simp]
-theorem FailConds.entails_false {x : FailConds ps} : FailConds.false ⊢ₑ x := by
+theorem ExceptConds.entails_false {x : ExceptConds ps} : ExceptConds.false ⊢ₑ x := by
   induction ps <;> simp_all [false, const, entails, SPred.false_elim]
 
 @[simp]
-theorem FailConds.entails_true {x : FailConds ps} : x ⊢ₑ FailConds.true := by
+theorem ExceptConds.entails_true {x : ExceptConds ps} : x ⊢ₑ ExceptConds.true := by
   induction ps <;> simp_all [true, const, entails]
 
 @[simp]
-def FailConds.and {ps : PostShape.{u}} (x : FailConds ps) (y : FailConds ps) : FailConds ps :=
+def ExceptConds.and {ps : PostShape.{u}} (x : ExceptConds ps) (y : ExceptConds ps) : ExceptConds ps :=
   match ps with
   | .pure => ⟨⟩
-  | .arg _ ps => @FailConds.and ps x y
-  | .except _ _ => (fun e => SPred.and (x.1 e) (y.1 e), FailConds.and x.2 y.2)
+  | .arg _ ps => @ExceptConds.and ps x y
+  | .except _ _ => (fun e => SPred.and (x.1 e) (y.1 e), ExceptConds.and x.2 y.2)
 
-infixr:35 " ∧ₑ " => FailConds.and
+infixr:35 " ∧ₑ " => ExceptConds.and
 
 @[simp]
-theorem FailConds.and_true {x : FailConds ps} : x ∧ₑ FailConds.true ⊢ₑ x := by
+theorem ExceptConds.and_true {x : ExceptConds ps} : x ∧ₑ ExceptConds.true ⊢ₑ x := by
   induction ps
   case pure => trivial
   case arg ih => exact ih
@@ -143,7 +143,7 @@ theorem FailConds.and_true {x : FailConds ps} : x ∧ₑ FailConds.true ⊢ₑ x
     constructor <;> simp only [SPred.and_true.mp, implies_true, ih]
 
 @[simp]
-theorem FailConds.true_and {x : FailConds ps} : FailConds.true ∧ₑ x ⊢ₑ x := by
+theorem ExceptConds.true_and {x : ExceptConds ps} : ExceptConds.true ∧ₑ x ⊢ₑ x := by
   induction ps
   case pure => trivial
   case arg ih => exact ih
@@ -152,7 +152,7 @@ theorem FailConds.true_and {x : FailConds ps} : FailConds.true ∧ₑ x ⊢ₑ x
     constructor <;> simp only [SPred.true_and.mp, implies_true, ih]
 
 @[simp]
-theorem FailConds.and_false {x : FailConds ps} : x ∧ₑ FailConds.false ⊢ₑ FailConds.false := by
+theorem ExceptConds.and_false {x : ExceptConds ps} : x ∧ₑ ExceptConds.false ⊢ₑ ExceptConds.false := by
   induction ps
   case pure => trivial
   case arg ih => exact ih
@@ -161,7 +161,7 @@ theorem FailConds.and_false {x : FailConds ps} : x ∧ₑ FailConds.false ⊢ₑ
     constructor <;> simp only [SPred.and_false.mp, implies_true, ih]
 
 @[simp]
-theorem FailConds.false_and {x : FailConds ps} : FailConds.false ∧ₑ x ⊢ₑ FailConds.false := by
+theorem ExceptConds.false_and {x : ExceptConds ps} : ExceptConds.false ∧ₑ x ⊢ₑ ExceptConds.false := by
   induction ps
   case pure => trivial
   case arg ih => exact ih
@@ -169,7 +169,7 @@ theorem FailConds.false_and {x : FailConds ps} : FailConds.false ∧ₑ x ⊢ₑ
     simp_all only [and, false, const]
     constructor <;> simp only [SPred.false_and.mp, implies_true, ih]
 
-theorem FailConds.and_eq_left {ps : PostShape} {p q : FailConds ps} (h : p ⊢ₑ q) :
+theorem ExceptConds.and_eq_left {ps : PostShape} {p q : ExceptConds ps} (h : p ⊢ₑ q) :
     p = (p ∧ₑ q) := by
   induction ps
   case pure => trivial
@@ -188,10 +188,10 @@ example : PostCond α (.arg ρ .pure) = ((α → ρ → Prop) × Unit) := rfl
 example : PostCond α (.except ε .pure) = ((α → Prop) × (ε → Prop) × Unit) := rfl
 example : PostCond α (.arg σ (.except ε .pure)) = ((α → σ → Prop) × (ε → Prop) × Unit) := rfl
 example : PostCond α (.except ε (.arg σ .pure)) = ((α → σ → Prop) × (ε → σ → Prop) × Unit) := rfl
-  ```
+```
 -/
 abbrev PostCond (α : Type u) (ps : PostShape.{u}) : Type u :=
-  (α → Assertion ps) × FailConds ps
+  (α → Assertion ps) × ExceptConds ps
 
 @[inherit_doc PostCond]
 scoped macro:max "post⟨" handlers:term,+,? "⟩" : term =>
@@ -204,12 +204,12 @@ A postcondition expressing total correctness.
 That is, it expresses that the asserted computation finishes without throwing an exception
 *and* the result satisfies the given predicate `p`.
 -/
-abbrev PostCond.total (p : α → Assertion ps) : PostCond α ps :=
-  (p, FailConds.false)
+abbrev PostCond.noThrow (p : α → Assertion ps) : PostCond α ps :=
+  (p, ExceptConds.false)
 
-@[inherit_doc PostCond.total]
+@[inherit_doc PostCond.noThrow]
 scoped macro:max ppAllowUngrouped "⇓" xs:term:max+ " => " e:term : term =>
-  `(PostCond.total (by exact fun $xs* => spred($e)))
+  `(PostCond.noThrow (by exact fun $xs* => spred($e)))
 
 /--
 A postcondition expressing partial correctness.
@@ -217,35 +217,39 @@ That is, it expresses that *if* the asserted computation finishes without throwi
 *then* the result satisfies the given predicate `p`.
 Nothing is asserted when the computation throws an exception.
 -/
-abbrev PostCond.partial (p : α → Assertion ps) : PostCond α ps :=
-  (p, FailConds.true)
+abbrev PostCond.mayThrow (p : α → Assertion ps) : PostCond α ps :=
+  (p, ExceptConds.true)
+
+@[inherit_doc PostCond.mayThrow]
+scoped macro:max ppAllowUngrouped "⇓?" xs:term:max+ " => " e:term : term =>
+  `(PostCond.mayThrow (by exact fun $xs* => spred($e)))
 
 instance : Inhabited (PostCond α ps) where
-  default := PostCond.total fun _ => default
+  default := PostCond.noThrow fun _ => default
 
 @[simp]
 def PostCond.entails (p q : PostCond α ps) : Prop :=
-  (∀ a, SPred.entails (p.1 a) (q.1 a)) ∧ FailConds.entails p.2 q.2
+  (∀ a, SPred.entails (p.1 a) (q.1 a)) ∧ ExceptConds.entails p.2 q.2
 
 scoped infix:25 " ⊢ₚ " => PostCond.entails
 
 @[refl, simp]
-theorem PostCond.entails.refl (Q : PostCond α ps) : Q ⊢ₚ Q := ⟨fun a => SPred.entails.refl (Q.1 a), FailConds.entails.refl Q.2⟩
+theorem PostCond.entails.refl (Q : PostCond α ps) : Q ⊢ₚ Q := ⟨fun a => SPred.entails.refl (Q.1 a), ExceptConds.entails.refl Q.2⟩
 theorem PostCond.entails.rfl {Q : PostCond α ps} : Q ⊢ₚ Q := refl Q
 
 theorem PostCond.entails.trans {P Q R : PostCond α ps} (h₁ : P ⊢ₚ Q) (h₂ : Q ⊢ₚ R) : P ⊢ₚ R :=
   ⟨fun a => (h₁.1 a).trans (h₂.1 a), h₁.2.trans h₂.2⟩
 
 @[simp]
-theorem PostCond.entails_total (p : α → Assertion ps) (q : PostCond α ps) : PostCond.total p ⊢ₚ q ↔ ∀ a, p a ⊢ₛ q.1 a := by
-  simp only [entails, FailConds.entails_false, and_true]
+theorem PostCond.entails_noThrow (p : α → Assertion ps) (q : PostCond α ps) : PostCond.noThrow p ⊢ₚ q ↔ ∀ a, p a ⊢ₛ q.1 a := by
+  simp only [entails, ExceptConds.entails_false, and_true]
 
 @[simp]
-theorem PostCond.entails_partial (p : PostCond α ps) (q : α → Assertion ps) : p ⊢ₚ PostCond.partial q ↔ ∀ a, p.1 a ⊢ₛ q a := by
-  simp only [entails, FailConds.entails_true, and_true]
+theorem PostCond.entails_mayThrow (p : PostCond α ps) (q : α → Assertion ps) : p ⊢ₚ PostCond.mayThrow q ↔ ∀ a, p.1 a ⊢ₛ q a := by
+  simp only [entails, ExceptConds.entails_true, and_true]
 
 abbrev PostCond.and (p : PostCond α ps) (q : PostCond α ps) : PostCond α ps :=
-  (fun a => SPred.and (p.1 a) (q.1 a), FailConds.and p.2 q.2)
+  (fun a => SPred.and (p.1 a) (q.1 a), ExceptConds.and p.2 q.2)
 
 scoped infixr:35 " ∧ₚ " => PostCond.and
 
@@ -253,4 +257,4 @@ theorem PostCond.and_eq_left {p q : PostCond α ps} (h : p ⊢ₚ q) :
     p = (p ∧ₚ q) := by
   ext
   · exact (SPred.and_eq_left.mp (h.1 _)).to_eq
-  · exact FailConds.and_eq_left h.2
+  · exact ExceptConds.and_eq_left h.2

src/Std/Do/PredTrans.lean

@@ -116,6 +116,10 @@ theorem bind_apply (x : PredTrans ps α) (f : α → PredTrans ps β) (Q : PostC
 theorem seq_apply (f : PredTrans ps (α → β)) (x : PredTrans ps α) (Q : PostCond β ps) :
   (f <*> x).apply Q = f.apply (fun g => x.apply (fun a => Q.1 (g a), Q.2), Q.2) := by rfl
 
+@[simp]
+theorem const_apply (p : Assertion ps) (Q : PostCond α ps) :
+  (PredTrans.const p : PredTrans ps α).apply Q = p := by rfl
+
 theorem bind_mono {x y : PredTrans ps α} {f : α → PredTrans ps β}
   (h : x ≤ y) : x >>= f ≤ y >>= f := by intro Q; exact (h (_, Q.2))
 

src/Std/Do/SPred/DerivedLaws.lean

@@ -166,9 +166,14 @@ theorem and_right_comm : (P ∧ Q) ∧ R ⊣⊢ₛ (P ∧ R) ∧ Q := and_assoc.
 theorem entails_pure_intro (P Q : Prop) (h : P → Q) : entails ⌜P⌝ (σs := σs) ⌜Q⌝ := pure_elim' fun hp => pure_intro (h hp)
 
 -- NB: We cannot currently make the following lemma @[grind =]; we are blocked on #9623.
--- However, the stronger SPred.entails_cons is already @[grind =].
-@[simp] theorem entails_pure_elim_cons {σ : Type u} [Inhabited σ] (P Q : Prop) : entails ⌜P⌝ (σs := σ::σs) ⌜Q⌝ ↔ entails ⌜P⌝ (σs := σs) ⌜Q⌝ := by simp [entails]
-@[simp, grind =] theorem entails_true_intro (P Q : SPred σs) : (⊢ₛ P → Q) = (P ⊢ₛ Q) := propext <| Iff.intro (fun h => (and_intro true_intro .rfl).trans (imp_elim h)) (fun h => imp_intro (and_elim_r.trans h))
+theorem entails_pure_elim_cons {σ : Type u} [Inhabited σ] (P Q : Prop) : entails ⌜P⌝ (σs := σ::σs) ⌜Q⌝ ↔ entails ⌜P⌝ (σs := σs) ⌜Q⌝ := by simp [entails]
+@[simp] theorem entails_true_intro (P Q : SPred σs) : (⊢ₛ P → Q) = (P ⊢ₛ Q) := propext <| Iff.intro (fun h => (and_intro true_intro .rfl).trans (imp_elim h)) (fun h => imp_intro (and_elim_r.trans h))
+-- The following lemmas work around a DefEq incompleteness that would be fixed by #9015.
+@[simp] theorem entails_1 {P Q : SPred [σ]} : SPred.entails P Q = (∀ s, (P s).down → (Q s).down) := rfl
+@[simp] theorem entails_2 {P Q : SPred [σ₁, σ₂]} : SPred.entails P Q = (∀ s₁ s₂, (P s₁ s₂).down → (Q s₁ s₂).down) := rfl
+@[simp] theorem entails_3 {P Q : SPred [σ₁, σ₂, σ₃]} : SPred.entails P Q = (∀ s₁ s₂ s₃, (P s₁ s₂ s₃).down → (Q s₁ s₂ s₃).down) := rfl
+@[simp] theorem entails_4 {P Q : SPred [σ₁, σ₂, σ₃, σ₄]} : SPred.entails P Q = (∀ s₁ s₂ s₃ s₄, (P s₁ s₂ s₃ s₄).down → (Q s₁ s₂ s₃ s₄).down) := rfl
+@[simp] theorem entails_5 {P Q : SPred [σ₁, σ₂, σ₃, σ₄, σ₅]} : SPred.entails P Q = (∀ s₁ s₂ s₃ s₄ s₅, (P s₁ s₂ s₃ s₄ s₅).down → (Q s₁ s₂ s₃ s₄ s₅).down) := rfl
 
 /-! # Tactic support -/
 
@@ -191,6 +196,7 @@ instance (σs) : IsPure (σs:=σs) spred(⌜φ⌝ ∨ ⌜ψ⌝) (φ ∨ ψ) wher
 instance (σs) (P : α → Prop) : IsPure (σs:=σs) spred(∃ x, ⌜P x⌝) (∃ x, P x) where to_pure := pure_exists
 instance (σs) (P : α → Prop) : IsPure (σs:=σs) spred(∀ x, ⌜P x⌝) (∀ x, P x) where to_pure := pure_forall
 instance (σs) (P : SPred (σ::σs)) [inst : IsPure P φ] : IsPure (σs:=σs) spred(P s) φ where to_pure := (iff_of_eq bientails_cons).mp inst.to_pure s
+instance (σs) (P : SPred σs) [inst : IsPure P φ] : IsPure (σs:=σ::σs) (fun _ => P) φ where to_pure := (iff_of_eq bientails_cons).mpr (fun _ => inst.to_pure)
 instance (φ : Prop) : IsPure (σs:=[]) ⌜φ⌝ φ where to_pure := Iff.rfl
 instance (P : SPred []) : IsPure (σs:=[]) P P.down where to_pure := Iff.rfl
 
@@ -262,6 +268,7 @@ class HasFrame (P : SPred σs) (P' : outParam (SPred σs)) (φ : outParam Prop)
   reassoc : P ⊣⊢ₛ P' ∧ ⌜φ⌝
 instance (σs) (P P' Q QP : SPred σs) [HasFrame P Q φ] [SimpAnd Q P' QP]: HasFrame (σs:=σs) spred(P ∧ P') QP φ where reassoc := ((and_congr_l HasFrame.reassoc).trans and_right_comm).trans (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 := ((and_congr_r HasFrame.reassoc).trans and_assoc.symm).trans (and_congr_l SimpAnd.simp_and)
+instance (σs) (P P' : Prop) (Q : SPred σs) [HasFrame spred(⌜P⌝ ∧ ⌜P'⌝) Q φ] : HasFrame (σs:=σs) ⌜P ∧ P'⌝ Q φ where reassoc := and_pure.symm.trans HasFrame.reassoc
 instance (σs) (P P' : SVal.StateTuple σs → Prop) (Q : SPred σs) [HasFrame spred(SVal.curry (fun t => ⟨P t⟩) ∧ SVal.curry (fun t => ⟨P' t⟩)) Q φ] : HasFrame (σs:=σs) (SVal.curry fun t => ⟨P t ∧ P' t⟩) Q φ where reassoc := and_curry.symm.trans HasFrame.reassoc
 instance (σs) (P : SPred σs) : HasFrame (σs:=σs) spred(⌜φ⌝ ∧ P) P φ where reassoc := and_comm
 instance (σs) (P : SPred σs) : HasFrame (σs:=σs) spred(P ∧ ⌜φ⌝) P φ where reassoc := .rfl

src/Std/Do/SPred/Laws.lean

@@ -76,16 +76,34 @@ theorem bientails.to_eq {P Q : SPred σs} (h : P ⊣⊢ₛ Q) : P = Q := by
 
 /-! # Pure -/
 
+@[simp, grind =] theorem down_pure {φ : Prop} : (⌜φ⌝ : SPred []).down = φ := rfl
+@[simp, grind =] theorem apply_pure {φ : Prop} : (⌜φ⌝ : SPred (σ::σs)) s = ⌜φ⌝ := rfl
+
 theorem pure_intro {φ : Prop} {P : SPred σs} : φ → P ⊢ₛ ⌜φ⌝ := by
-  induction σs <;> simp_all [entails, SVal.curry]
+  induction σs <;> simp_all [entails]
 
 theorem pure_elim' {φ : Prop} {P : SPred σs} : (φ → ⌜True⌝ ⊢ₛ P) → ⌜φ⌝ ⊢ₛ P := by
-  induction σs <;> simp_all [entails, SVal.curry]
+  induction σs <;> simp_all [entails]
 
 -- Ideally, we'd like to prove the following theorem:
 -- theorem pure_elim' {φ : Prop} : SPred.entails (σs:=σs) ⌜True⌝ ⌜φ⌝ → φ
 -- Unfortunately, this is only true if all `σs` are Inhabited.
 
+theorem and_pure {P Q : Prop} : ⌜P⌝ ∧ ⌜Q⌝ ⊣⊢ₛ (⌜P ∧ Q⌝ : SPred σs) := by
+  induction σs
+  case nil => rfl
+  case cons σ σs ih => intro s; simp only [and_cons]; exact ih
+
+theorem or_pure {P Q : Prop} : ⌜P⌝ ∨ ⌜Q⌝ ⊣⊢ₛ (⌜P ∨ Q⌝ : SPred σs) := by
+  induction σs
+  case nil => rfl
+  case cons σ σs ih => intro s; simp only [or_cons]; exact ih
+
+theorem imp_pure {P Q : Prop} : (⌜P⌝ → ⌜Q⌝) ⊣⊢ₛ (⌜P → Q⌝ : SPred σs) := by
+  induction σs
+  case nil => rfl
+  case cons σ σs ih => intro s; simp only [imp_cons]; exact ih
+
 /-! # Conjunction -/
 
 theorem and_intro {P Q R : SPred σs} (h1 : P ⊢ₛ Q) (h2 : P ⊢ₛ R) : P ⊢ₛ Q ∧ R := by

src/Std/Do/SPred/Notation.lean

@@ -50,14 +50,8 @@ partial def SPred.Notation.unpack [Monad m] [MonadRef m] [MonadQuotation m] : Te
 
 /-! # Idiom notation -/
 
-/-- Embedding of pure Lean values into `SVal`. -/
+/-- Embedding of pure Lean values into `SVal`. An alias for `SPred.pure`. -/
 scoped syntax "⌜" term "⌝" : term
-/-- ‹t› in `SVal` idiom notation. Accesses the state of type `t`. -/
-scoped syntax "‹" term "›ₛ" : term
-/--
-  Use getter `t : SVal σs σ` in `SVal` idiom notation; sugar for `SVal.uncurry t (by assumption)`.
--/
-scoped syntax:max "#" term:max : term
 
 /-! # Sugar for `SPred` -/
 
@@ -69,9 +63,7 @@ scoped syntax:25 "⊢ₛ " term:25 : term
 scoped syntax:25 term:25 " ⊣⊢ₛ " term:25 : term
 
 macro_rules
-  | `(⌜$t⌝) => ``(SVal.curry (fun tuple => ULift.up $t))
-  | `(#$t) => `(SVal.uncurry $t (by assumption))
-  | `(‹$t›ₛ) => `(#(SVal.getThe $t))
+  | `(⌜$t⌝) => ``(SPred.pure $t)
   | `($P ⊢ₛ $Q) => ``(SPred.entails spred($P) spred($Q))
   | `(spred($P ∧ $Q)) => ``(SPred.and spred($P) spred($Q))
   | `(spred($P ∨ $Q)) => ``(SPred.or spred($P) spred($Q))
@@ -94,20 +86,10 @@ macro_rules
 
 namespace SPred.Notation
 
-@[app_unexpander SVal.curry]
-meta def unexpandCurry : Unexpander
+@[app_unexpander SPred.pure]
+meta def unexpandPure : Unexpander
   | `($_ $t $ts*) => do
-    match t with
-    | `(fun $_ => { down := $e }) => if ts.isEmpty then ``(⌜$e⌝) else ``(⌜$e⌝ $ts*)
-    | _ => throw ()
-  | _ => throw ()
-
-@[app_unexpander SVal.uncurry]
-meta def unexpandUncurry : Unexpander
-  | `($_ $f $ts*) => do
-    match f with
-    | `(SVal.getThe $t) => if ts.isEmpty then ``(‹$t›ₛ) else ``(‹$t›ₛ $ts*)
-    | `($t) => if ts.isEmpty then ``(#$t) else ``(#$t $ts*)
+    if ts.isEmpty then ``(⌜$t⌝) else ``(⌜$t⌝ $ts*)
   | _ => throw ()
 
 @[app_unexpander SPred.entails]

src/Std/Do/SPred/SPred.lean

@@ -33,9 +33,6 @@ namespace SPred
 universe u
 variable {σs : List (Type u)}
 
-/-- A pure proposition `P : Prop` embedded into `SPred`. For internal use in this module only; prefer to use idiom bracket notation `⌜P⌝. -/
-abbrev pure (P : Prop) : SPred σs := SVal.curry (fun _ => ⟨P⟩)
-
 @[ext]
 theorem ext_nil {P Q : SPred []} (h : P.down ↔ Q.down) : P = Q := by
   cases P; cases Q; simp_all
@@ -43,12 +40,24 @@ theorem ext_nil {P Q : SPred []} (h : P.down ↔ Q.down) : P = Q := by
 @[ext]
 theorem ext_cons {P Q : SPred (σ::σs)} : (∀ s, P s = Q s) → P = Q := funext
 
+/--
+A pure proposition `P : Prop` embedded into `SPred`.
+Prefer to use idiom bracket notation `⌜P⌝.
+-/
+def pure {σs : List (Type u)} (P : Prop) : SPred σs := match σs with
+  | [] => ULift.up P
+  | _ :: _ => fun _ => pure P
+theorem pure_nil : pure (σs:=[]) P = ULift.up P := rfl
+theorem pure_cons : pure (σs:=σ::σs) P = fun _ => pure P := rfl
+
 /-- Entailment in `SPred`. -/
 def entails {σs : List (Type u)} (P Q : SPred σs) : Prop := match σs with
   | [] => P.down → Q.down
   | σ :: _ => ∀ (s : σ), entails (P s) (Q s)
 @[simp, grind =] theorem entails_nil {P Q : SPred []} : entails P Q = (P.down → Q.down) := rfl
-@[grind =] theorem entails_cons {P Q : SPred (σ::σs)} : entails P Q = (∀ s, entails (P s) (Q s)) := rfl
+-- We would like to make `entails_cons` @[simp], but that has no effect until we merge #9015.
+-- Until then, we have `entails_<n>` for n ∈ [1:5] in DerivedLaws.lean.
+theorem entails_cons {P Q : SPred (σ::σs)} : entails P Q = (∀ s, entails (P s) (Q s)) := rfl
 theorem entails_cons_intro {P Q : SPred (σ::σs)} : (∀ s, entails (P s) (Q s)) → entails P Q := by simp only [entails_cons, imp_self]
 
 -- Reducibility of entails must be semi-reducible so that entails_refl is useful for rfl
@@ -58,7 +67,7 @@ def bientails {σs : List (Type u)} (P Q : SPred σs) : Prop := match σs with
   | [] => P.down ↔ Q.down
   | σ :: _ => ∀ (s : σ), bientails (P s) (Q s)
 @[simp, grind =] theorem bientails_nil {P Q : SPred []} : bientails P Q = (P.down ↔ Q.down) := rfl
-@[grind =] theorem bientails_cons {P Q : SPred (σ::σs)} : bientails P Q = (∀ s, bientails (P s) (Q s)) := rfl
+theorem bientails_cons {P Q : SPred (σ::σs)} : bientails P Q = (∀ s, bientails (P s) (Q s)) := rfl
 theorem bientails_cons_intro {P Q : SPred (σ::σs)} : (∀ s, bientails (P s) (Q s)) → bientails P Q := by simp only [bientails_cons, imp_self]
 
 /-- Conjunction in `SPred`. -/
@@ -117,4 +126,4 @@ def conjunction {σs : List (Type u)} (env : List (SPred σs)) : SPred σs := ma
 @[simp, grind =] theorem conjunction_nil : conjunction ([] : List (SPred σs)) = pure True := rfl
 @[simp, grind =] theorem conjunction_cons {P : SPred σs} {env : List (SPred σs)} : conjunction (P::env) = P.and (conjunction env) := rfl
 @[simp, grind =] theorem conjunction_apply {env : List (SPred (σ::σs))} : conjunction env s = conjunction (env.map (· s)) := by
-  induction env <;> simp [conjunction, *]
+  induction env <;> simp [conjunction, pure_cons, *]

src/Std/Do/SPred/SVal.lean

@@ -24,9 +24,10 @@ namespace Std.Do
 abbrev SVal (σs : List (Type u)) (α : Type u) : Type u := match σs with
   | [] => α
   | σ :: σs => σ → SVal σs α
+
 /- Note about the reducibility of SVal:
 We need SVal to be reducible, otherwise type inference fails for `Triple`.
-(Begs for investigation. #8074.)
+This is tracked in #8074. There is a fix in #9015, but it regresses Mathlib.
 -/
 
 namespace SVal
@@ -59,22 +60,19 @@ def uncurry {σs : List (Type u)} (f : SVal σs α) : StateTuple σs → α := m
 @[simp, grind =] theorem uncurry_curry {σs : List (Type u)} {f : StateTuple σs → α} : uncurry (σs:=σs) (curry f) = f := by induction σs <;> (simp[uncurry, curry, *]; rfl)
 @[simp, grind =] theorem curry_uncurry {σs : List (Type u)} {f : SVal σs α} : curry (σs:=σs) (uncurry f) = f := by induction σs <;> simp[uncurry, curry, *]
 
-/-- Embed a pure value into an `SVal`. -/
-abbrev pure {σs : List (Type u)} (a : α) : SVal σs α := curry (fun _ => a)
-
 instance [Inhabited α] : Inhabited (SVal σs α) where
-  default := pure default
+  default := curry fun _ => default
 
 class GetTy (σ : Type u) (σs : List (Type u)) where
   get : SVal σs σ
 
 instance : GetTy σ (σ :: σs) where
-  get := fun s => pure s
+  get := fun s => curry (fun _ => s)
 
 instance [GetTy σ₁ σs] : GetTy σ₁ (σ₂ :: σs) where
   get := fun _ => GetTy.get
 
 /-- Get the top-most state of type `σ` from an `SVal`. -/
 def getThe {σs : List (Type u)} (σ : Type u) [GetTy σ σs] : SVal σs σ := GetTy.get
-@[simp, grind =] theorem getThe_here {σs : List (Type u)} (σ : Type u) (s : σ) : getThe (σs := σ::σs) σ s = pure s := rfl
+@[simp, grind =] theorem getThe_here {σs : List (Type u)} (σ : Type u) (s : σ) : getThe (σs := σ::σs) σ s = curry (fun _ => s) := rfl
 @[simp, grind =] theorem getThe_there {σs : List (Type u)} [GetTy σ σs] (σ' : Type u) (s : σ') : getThe (σs := σ'::σs) σ s = getThe (σs := σs) σ := rfl

src/Std/Do/Triple/Basic.lean

@@ -60,14 +60,10 @@ theorem bind [Monad m] [WPMonad m ps] {α β : Type u} {P : Assertion ps} {Q :
   apply SPred.entails.trans hx
   simp only [WP.bind]
   apply (wp x).mono _ _
-  simp only [PostCond.entails, Assertion, FailConds.entails.refl, and_true]
+  simp only [PostCond.entails, Assertion, ExceptConds.entails.refl, and_true]
   exact hf
 
 theorem and [WP m ps] (x : m α) (h₁ : Triple x P₁ Q₁) (h₂ : Triple x P₂ Q₂) : Triple x spred(P₁ ∧ P₂) (Q₁ ∧ₚ Q₂) :=
   (SPred.and_mono h₁ h₂).trans ((wp x).conjunctive Q₁ Q₂).mpr
 
-theorem rewrite_program [WP m ps] {prog₁ prog₂ : m α}
-  (heq : prog₁ = prog₂) (hprf : Triple prog₂ P Q) :
-  Triple prog₁ P Q := heq ▸ hprf
-
 end Triple

src/Std/Do/Triple/SpecLemmas.lean

@@ -8,6 +8,7 @@ module
 prelude
 public import Std.Do.Triple.Basic
 public import Std.Do.WP
+import Init.Data.Range.Polymorphic
 
 @[expose] public section
 
@@ -303,22 +304,68 @@ theorem Spec.tryCatch_ExceptT_lift [WP m ps] [Monad m] [MonadExceptOf ε m] (Q :
 
 /-! # `ForIn` -/
 
+/--
+The type of loop invariants used by the specifications of `for ... in ...` loops.
+A loop invariant is a `PostCond` that takes as parameters
+
+* A `List.Zipper xs` representing the iteration state of the loop. It is parameterized by the list
+  of elements `xs` that the `for` loop iterates over.
+* A state tuple of type `β`, which will be a nesting of `MProd`s representing the elaboration of
+  `let mut` variables and early return.
+
+The loop specification lemmas will use this in the following way:
+Before entering the loop, the zipper's prefix is empty and the suffix is `xs`.
+After leaving the loop, the zipper's suffix is empty and the prefix is `xs`.
+During the induction step, the invariant holds for a suffix with head element `x`.
+After running the loop body, the invariant then holds after shifting `x` to the prefix.
+-/
+abbrev Invariant {α : Type u} (xs : List α) (β : Type u) (ps : PostShape) :=
+  PostCond (List.Zipper xs × β) ps
+
+/--
+Helper definition for specifying loop invariants for loops with early return.
+
+`for ... in ...` loops with early return of type `γ` elaborate to a call like this:
+```lean
+forIn (β := MProd (Option γ) ...) (b := ⟨none, ...⟩) collection loopBody
+```
+Note that the first component of the `MProd` state tuple is the optional early return value.
+It is `none` as long as there was no early return and `some r` if the loop returned early with `r`.
+
+This function allows to specify different invariants for the loop body depending on whether the loop
+terminated early or not. When there was an early return, the loop has effectively finished, which is
+encoded by the additional `⌜xs.suff = []⌝` assertion in the invariant. This assertion is vital for
+successfully proving the induction step, as it contradicts with the assumption that
+`xs.suff = x::rest` of the inductive hypothesis at the start of the loop body, meaning that users
+won't need to prove anything about the bogus case where the loop has returned early yet takes
+another iteration of the loop body.
+-/
+abbrev Invariant.withEarlyReturn
+  (onContinue : List.Zipper xs → β → Assertion ps)
+  (onReturn : γ → β → Assertion ps)
+  (onExcept : ExceptConds ps := ExceptConds.false) :
+    Invariant xs (MProd (Option γ) β) ps :=
+  ⟨fun ⟨xs, x, b⟩ => spred(
+        (⌜x = none⌝ ∧ onContinue xs b)
+      ∨ (∃ r, ⌜x = some r⌝ ∧ ⌜xs.suff = []⌝ ∧ onReturn r b)),
+   onExcept⟩
+
 @[spec]
 theorem Spec.forIn'_list {α β : Type u}
     [Monad m] [WPMonad m ps]
     {xs : List α} {init : β} {f : (a : α) → a ∈ xs → β → m (ForInStep β)}
-    (inv : PostCond (β × List.Zipper xs) ps)
+    (inv : Invariant xs β ps)
     (step : ∀ b rpref x (hx : x ∈ xs) suff (h : xs = rpref.reverse ++ x :: suff),
-        ⦃inv.1 (b, ⟨rpref, x::suff, by simp [h]⟩)}
+        ⦃inv.1 (⟨rpref, x::suff, by simp [h]⟩, b)}
         f x hx b
         ⦃(fun r => match r with
-                   | .yield b' => inv.1 (b', ⟨x::rpref, suff, by simp [h]⟩)
-                   | .done b' => inv.1 (b', ⟨xs.reverse, [], by simp⟩), inv.2)}) :
-    ⦃inv.1 (init, ⟨[], xs, by simp⟩)} forIn' xs init f ⦃(fun b => inv.1 (b, ⟨xs.reverse, [], by simp⟩), inv.2)} := by
+                   | .yield b' => inv.1 (⟨x::rpref, suff, by simp [h]⟩, b')
+                   | .done b' => inv.1 (⟨xs.reverse, [], by simp⟩, b'), inv.2)}) :
+    ⦃inv.1 (⟨[], xs, by simp⟩, init)} forIn' xs init f ⦃(fun b => inv.1 (⟨xs.reverse, [], by simp⟩, b), inv.2)} := by
   suffices h : ∀ rpref suff (h : xs = rpref.reverse ++ suff),
-      ⦃inv.1 (init, ⟨rpref, suff, by simp [h]⟩)}
+      ⦃inv.1 (⟨rpref, suff, by simp [h]⟩, init)}
       forIn' (m:=m) suff init (fun a ha => f a (by simp[h,ha]))
-      ⦃(fun b => inv.1 (b, ⟨xs.reverse, [], by simp [h]⟩), inv.2)}
+      ⦃(fun b => inv.1 (⟨xs.reverse, [], by simp [h]⟩, b), inv.2)}
     from h [] xs rfl
   intro rpref suff h
   induction suff generalizing rpref init
@@ -347,20 +394,20 @@ theorem Spec.forIn'_list_const_inv {α β : Type u}
         f x hx b
         ⦃(fun r => match r with | .yield b' => inv.1 b' | .done b' => inv.1 b', inv.2)}) :
     ⦃inv.1 init} forIn' xs init f ⦃inv} :=
-  Spec.forIn'_list (fun p => inv.1 p.1, inv.2) (fun b _ x hx _ _ => step x hx b)
+  Spec.forIn'_list (fun p => inv.1 p.2, inv.2) (fun b _ x hx _ _ => step x hx b)
 
 @[spec]
 theorem Spec.forIn_list {α β : Type u}
     [Monad m] [WPMonad m ps]
     {xs : List α} {init : β} {f : α → β → m (ForInStep β)}
-    (inv : PostCond (β × List.Zipper xs) ps)
+    (inv : Invariant xs β ps)
     (step : ∀ b rpref x suff (h : xs = rpref.reverse ++ x :: suff),
-        ⦃inv.1 (b, ⟨rpref, x::suff, by simp [h]⟩)}
+        ⦃inv.1 (⟨rpref, x::suff, by simp [h]⟩, b)}
         f x b
         ⦃(fun r => match r with
-                   | .yield b' => inv.1 (b', ⟨x::rpref, suff, by simp [h]⟩)
-                   | .done b' => inv.1 (b', ⟨xs.reverse, [], by simp⟩), inv.2)}) :
-    ⦃inv.1 (init, ⟨[], xs, by simp⟩)} forIn xs init f ⦃(fun b => inv.1 (b, ⟨xs.reverse, [], by simp⟩), inv.2)} := by
+                   | .yield b' => inv.1 (⟨x::rpref, suff, by simp [h]⟩, b')
+                   | .done b' => inv.1 (⟨xs.reverse, [], by simp⟩, b'), inv.2)}) :
+    ⦃inv.1 (⟨[], xs, by simp⟩, init)} forIn xs init f ⦃(fun b => inv.1 (⟨xs.reverse, [], by simp⟩, b), inv.2)} := by
   simp only [← forIn'_eq_forIn]
   exact Spec.forIn'_list inv (fun b rpref x _ suff h => step b rpref x suff h)
 
@@ -374,18 +421,18 @@ theorem Spec.forIn_list_const_inv {α β : Type u}
         f hd b
         ⦃(fun r => match r with | .yield b' => inv.1 b' | .done b' => inv.1 b', inv.2)}) :
     ⦃inv.1 init} forIn xs init f ⦃inv} :=
-  Spec.forIn_list (fun p => inv.1 p.1, inv.2) (fun b _ hd _ _ => step hd b)
+  Spec.forIn_list (fun p => inv.1 p.2, inv.2) (fun b _ hd _ _ => step hd b)
 
 @[spec]
 theorem Spec.foldlM_list {α β : Type u}
     [Monad m] [WPMonad m ps]
     {xs : List α} {init : β} {f : β → α → m β}
-    (inv : PostCond (β × List.Zipper xs) ps)
+    (inv : Invariant xs β ps)
     (step : ∀ b rpref x suff (h : xs = rpref.reverse ++ x :: suff),
-        ⦃inv.1 (b, ⟨rpref, x::suff, by simp [h]⟩)}
+        ⦃inv.1 (⟨rpref, x::suff, by simp [h]⟩, b)}
         f b x
-        ⦃(fun b' => inv.1 (b', ⟨x::rpref, suff, by simp [h]⟩), inv.2)}) :
-    ⦃inv.1 (init, ⟨[], xs, by simp⟩)} List.foldlM f init xs ⦃(fun b => inv.1 (b, ⟨xs.reverse, [], by simp⟩), inv.2)} := by
+        ⦃(fun b' => inv.1 (⟨x::rpref, suff, by simp [h]⟩, b'), inv.2)}) :
+    ⦃inv.1 (⟨[], xs, by simp⟩, init)} List.foldlM f init xs ⦃(fun b => inv.1 (⟨xs.reverse, [], by simp⟩, b), inv.2)} := by
   have : xs.foldlM f init = forIn xs init (fun a b => .yield <$> f b a) := by
     simp only [List.forIn_yield_eq_foldlM, id_map']
   rw[this]
@@ -403,20 +450,20 @@ theorem Spec.foldlM_list_const_inv {α β : Type u}
         f b hd
         ⦃(fun b' => inv.1 b', inv.2)}) :
   ⦃inv.1 init} List.foldlM f init xs ⦃inv} :=
-    Spec.foldlM_list (fun p => inv.1 p.1, inv.2) (fun b _ hd _ _ => step hd b)
+    Spec.foldlM_list (fun p => inv.1 p.2, inv.2) (fun b _ hd _ _ => step hd b)
 
 @[spec]
 theorem Spec.forIn'_range {β : Type} {m : Type → Type v} {ps : PostShape}
     [Monad m] [WPMonad m ps]
     {xs : Std.Range} {init : β} {f : (a : Nat) → a ∈ xs → β → m (ForInStep β)}
-    (inv : PostCond (β × List.Zipper xs.toList) ps)
+    (inv : Invariant xs.toList β ps)
     (step : ∀ b rpref x (hx : x ∈ xs) suff (h : xs.toList = rpref.reverse ++ x :: suff),
-        ⦃inv.1 (b, ⟨rpref, x::suff, by simp [h]⟩)}
+        ⦃inv.1 (⟨rpref, x::suff, by simp [h]⟩, b)}
         f x hx b
         ⦃(fun r => match r with
-                   | .yield b' => inv.1 (b', ⟨x::rpref, suff, by simp [h]⟩)
-                   | .done b' => inv.1 (b', ⟨xs.toList.reverse, [], by simp⟩), inv.2)}) :
-    ⦃inv.1 (init, ⟨[], xs.toList, by simp⟩)} forIn' xs init f ⦃(fun b => inv.1 (b, ⟨xs.toList.reverse, [], by simp⟩), inv.2)} := by
+                   | .yield b' => inv.1 (⟨x::rpref, suff, by simp [h]⟩, b')
+                   | .done b' => inv.1 (⟨xs.toList.reverse, [], by simp⟩, b'), inv.2)}) :
+    ⦃inv.1 (⟨[], xs.toList, by simp⟩, init)} forIn' xs init f ⦃(fun b => inv.1 (⟨xs.toList.reverse, [], by simp⟩, b), inv.2)} := by
   simp only [Std.Range.forIn'_eq_forIn'_range', Std.Range.size, Std.Range.size.eq_1]
   apply Spec.forIn'_list inv (fun b rpref x hx suff h => step b rpref x (Std.Range.mem_of_mem_range' hx) suff h)
 
@@ -424,29 +471,69 @@ theorem Spec.forIn'_range {β : Type} {m : Type → Type v} {ps : PostShape}
 theorem Spec.forIn_range {β : Type} {m : Type → Type v} {ps : PostShape}
     [Monad m] [WPMonad m ps]
     {xs : Std.Range} {init : β} {f : Nat → β → m (ForInStep β)}
-    (inv : PostCond (β × List.Zipper xs.toList) ps)
+    (inv : Invariant xs.toList β ps)
     (step : ∀ b rpref x suff (h : xs.toList = rpref.reverse ++ x :: suff),
-        ⦃inv.1 (b, ⟨rpref, x::suff, by simp [h]⟩)}
+        ⦃inv.1 (⟨rpref, x::suff, by simp [h]⟩, b)}
         f x b
         ⦃(fun r => match r with
-                   | .yield b' => inv.1 (b', ⟨x::rpref, suff, by simp [h]⟩)
-                   | .done b' => inv.1 (b', ⟨xs.toList.reverse, [], by simp⟩), inv.2)}) :
-    ⦃inv.1 (init, ⟨[], xs.toList, by simp⟩)} forIn xs init f ⦃(fun b => inv.1 (b, ⟨xs.toList.reverse, [], by simp⟩), inv.2)} := by
+                   | .yield b' => inv.1 (⟨x::rpref, suff, by simp [h]⟩, b')
+                   | .done b' => inv.1 (⟨xs.toList.reverse, [], by simp⟩, b'), inv.2)}) :
+    ⦃inv.1 (⟨[], xs.toList, by simp⟩, init)} forIn xs init f ⦃(fun b => inv.1 (⟨xs.toList.reverse, [], by simp⟩, b), inv.2)} := by
   simp only [Std.Range.forIn_eq_forIn_range', Std.Range.size]
   apply Spec.forIn_list inv step
 
+open Std.PRange in
+@[spec]
+theorem Spec.forIn'_prange {α β : Type u}
+    [Monad m] [WPMonad m ps]
+    [UpwardEnumerable α]
+    [SupportsUpperBound su α] [SupportsLowerBound sl α] [HasFiniteRanges su α]
+    [BoundedUpwardEnumerable sl α] [LawfulUpwardEnumerable α]
+    [LawfulUpwardEnumerableLowerBound sl α] [LawfulUpwardEnumerableUpperBound su α]
+    {xs : PRange ⟨sl, su⟩ α} {init : β} {f : (a : α) → a ∈ xs → β → m (ForInStep β)}
+    (inv : Invariant xs.toList β ps)
+    (step : ∀ b rpref x (hx : x ∈ xs) suff (h : xs.toList = rpref.reverse ++ x :: suff),
+        ⦃inv.1 (⟨rpref, x::suff, by simp [h]⟩, b)}
+        f x hx b
+        ⦃(fun r => match r with
+                   | .yield b' => inv.1 (⟨x::rpref, suff, by simp [h]⟩, b')
+                   | .done b' => inv.1 (⟨xs.toList.reverse, [], by simp⟩, b'), inv.2)}) :
+    ⦃inv.1 (⟨[], xs.toList, by simp⟩, init)} forIn' xs init f ⦃(fun b => inv.1 (⟨xs.toList.reverse, [], by simp⟩, b), inv.2)} := by
+  simp only [forIn'_eq_forIn'_toList]
+  apply Spec.forIn'_list inv (fun b rpref x hx suff h => step b rpref x (mem_toList_iff_mem.mp hx) suff h)
+
+open Std.PRange in
+@[spec]
+theorem Spec.forIn_prange {α β : Type u}
+    [Monad m] [WPMonad m ps]
+    [UpwardEnumerable α]
+    [SupportsUpperBound su α] [SupportsLowerBound sl α] [HasFiniteRanges su α]
+    [BoundedUpwardEnumerable sl α] [LawfulUpwardEnumerable α]
+    [LawfulUpwardEnumerableLowerBound sl α] [LawfulUpwardEnumerableUpperBound su α]
+    {xs : PRange ⟨sl, su⟩ α} {init : β} {f : α → β → m (ForInStep β)}
+    (inv : Invariant xs.toList β ps)
+    (step : ∀ b rpref x suff (h : xs.toList = rpref.reverse ++ x :: suff),
+        ⦃inv.1 (⟨rpref, x::suff, by simp [h]⟩, b)}
+        f x b
+        ⦃(fun r => match r with
+                   | .yield b' => inv.1 (⟨x::rpref, suff, by simp [h]⟩, b')
+                   | .done b' => inv.1 (⟨xs.toList.reverse, [], by simp⟩, b'), inv.2)}) :
+    ⦃inv.1 (⟨[], xs.toList, by simp⟩, init)} forIn xs init f ⦃(fun b => inv.1 (⟨xs.toList.reverse, [], by simp⟩, b), inv.2)} := by
+  simp only [forIn]
+  apply Spec.forIn'_prange inv (fun b rpref x _hx suff h => step b rpref x suff h)
+
 @[spec]
 theorem Spec.forIn'_array {α β : Type u}
     [Monad m] [WPMonad m ps]
     {xs : Array α} {init : β} {f : (a : α) → a ∈ xs → β → m (ForInStep β)}
-    (inv : PostCond (β × List.Zipper xs.toList) ps)
+    (inv : Invariant xs.toList β ps)
     (step : ∀ b rpref x (hx : x ∈ xs) suff (h : xs.toList = rpref.reverse ++ x :: suff),
-        ⦃inv.1 (b, ⟨rpref, x::suff, by simp [h]⟩)}
+        ⦃inv.1 (⟨rpref, x::suff, by simp [h]⟩, b)}
         f x hx b
         ⦃(fun r => match r with
-                   | .yield b' => inv.1 (b', ⟨x::rpref, suff, by simp [h]⟩)
-                   | .done b' => inv.1 (b', ⟨xs.toList.reverse, [], by simp⟩), inv.2)}) :
-    ⦃inv.1 (init, ⟨[], xs.toList, by simp⟩)} forIn' xs init f ⦃(fun b => inv.1 (b, ⟨xs.toList.reverse, [], by simp⟩), inv.2)} := by
+                   | .yield b' => inv.1 (⟨x::rpref, suff, by simp [h]⟩, b')
+                   | .done b' => inv.1 (⟨xs.toList.reverse, [], by simp⟩, b'), inv.2)}) :
+    ⦃inv.1 (⟨[], xs.toList, by simp⟩, init)} forIn' xs init f ⦃(fun b => inv.1 (⟨xs.toList.reverse, [], by simp⟩, b), inv.2)} := by
   cases xs
   simp
   apply Spec.forIn'_list inv (fun b rpref x hx suff h => step b rpref x (by simp[hx]) suff h)
@@ -455,14 +542,14 @@ theorem Spec.forIn'_array {α β : Type u}
 theorem Spec.forIn_array {α β : Type u}
     [Monad m] [WPMonad m ps]
     {xs : Array α} {init : β} {f : α → β → m (ForInStep β)}
-    (inv : PostCond (β × List.Zipper xs.toList) ps)
+    (inv : Invariant xs.toList β ps)
     (step : ∀ b rpref x suff (h : xs.toList = rpref.reverse ++ x :: suff),
-        ⦃inv.1 (b, ⟨rpref, x::suff, by simp [h]⟩)}
+        ⦃inv.1 (⟨rpref, x::suff, by simp [h]⟩, b)}
         f x b
         ⦃(fun r => match r with
-                   | .yield b' => inv.1 (b', ⟨x::rpref, suff, by simp [h]⟩)
-                   | .done b' => inv.1 (b', ⟨xs.toList.reverse, [], by simp⟩), inv.2)}) :
-    ⦃inv.1 (init, ⟨[], xs.toList, by simp⟩)} forIn xs init f ⦃(fun b => inv.1 (b, ⟨xs.toList.reverse, [], by simp⟩), inv.2)} := by
+                   | .yield b' => inv.1 (⟨x::rpref, suff, by simp [h]⟩, b')
+                   | .done b' => inv.1 (⟨xs.toList.reverse, [], by simp⟩, b'), inv.2)}) :
+    ⦃inv.1 (⟨[], xs.toList, by simp⟩, init)} forIn xs init f ⦃(fun b => inv.1 (⟨xs.toList.reverse, [], by simp⟩, b), inv.2)} := by
   cases xs
   simp
   apply Spec.forIn_list inv step
@@ -471,12 +558,12 @@ theorem Spec.forIn_array {α β : Type u}
 theorem Spec.foldlM_array {α β : Type u}
     [Monad m] [WPMonad m ps]
     {xs : Array α} {init : β} {f : β → α → m β}
-    (inv : PostCond (β × List.Zipper xs.toList) ps)
+    (inv : Invariant xs.toList β ps)
     (step : ∀ b rpref x suff (h : xs.toList = rpref.reverse ++ x :: suff),
-        ⦃inv.1 (b, ⟨rpref, x::suff, by simp [h]⟩)}
+        ⦃inv.1 (⟨rpref, x::suff, by simp [h]⟩, b)}
         f b x
-        ⦃(fun b' => inv.1 (b', ⟨x::rpref, suff, by simp [h]⟩), inv.2)}) :
-    ⦃inv.1 (init, ⟨[], xs.toList, by simp⟩)} Array.foldlM f init xs ⦃(fun b => inv.1 (b, ⟨xs.toList.reverse, [], by simp⟩), inv.2)} := by
+        ⦃(fun b' => inv.1 (⟨x::rpref, suff, by simp [h]⟩, b'), inv.2)}) :
+    ⦃inv.1 (⟨[], xs.toList, by simp⟩, init)} Array.foldlM f init xs ⦃(fun b => inv.1 (⟨xs.toList.reverse, [], by simp⟩, b), inv.2)} := by
   cases xs
   simp
   apply Spec.foldlM_list inv step

src/Std/Do/WP/Basic.lean

@@ -98,13 +98,13 @@ instance Except.instWP : WP (Except ε) (.except ε .pure) :=
   inferInstanceAs (WP (ExceptT ε Id) (.except ε .pure))
 
 theorem Id.by_wp {α : Type u} {x : α} {prog : Id α} (h : Id.run prog = x) (P : α → Prop) :
-  (⊢ₛ wp⟦prog⟧ (PostCond.total (fun a => ⟨P a⟩))) → P x := h ▸ (· True.intro)
+  (⊢ₛ wp⟦prog⟧ (PostCond.noThrow (fun a => ⟨P a⟩))) → P x := h ▸ (· True.intro)
 
 theorem StateM.by_wp {α} {x : α × σ} {prog : StateM σ α} (h : StateT.run prog s = x) (P : α × σ → Prop) :
-  (⊢ₛ wp⟦prog⟧ (PostCond.total (fun a s' => ⟨P (a, s')⟩)) s) → P x := h ▸ (· True.intro)
+  (⊢ₛ wp⟦prog⟧ (PostCond.noThrow (fun a s' => ⟨P (a, s')⟩)) s) → P x := h ▸ (· True.intro)
 
 theorem ReaderM.by_wp {α} {x : α} {prog : ReaderM ρ α} (h : ReaderT.run prog r = x) (P : α → Prop) :
-  (⊢ₛ wp⟦prog⟧ (PostCond.total (fun a _ => ⟨P a⟩)) r) → P x := h ▸ (· True.intro)
+  (⊢ₛ wp⟦prog⟧ (PostCond.noThrow (fun a _ => ⟨P a⟩)) r) → P x := h ▸ (· True.intro)
 
 theorem Except.by_wp {α} {x : Except ε α} (P : Except ε α → Prop) :
   (⊢ₛ wp⟦x⟧ post⟨fun a => ⟨P (.ok a)⟩, fun e => ⟨P (.error e)⟩⟩) → P x := by

src/Std/Sat/CNF/RelabelFin.lean

@@ -7,6 +7,7 @@ module
 
 prelude
 public import Init.Data.List.Nat.Basic
+public import Init.Data.Nat.Order
 public import Std.Sat.CNF.Relabel
 
 @[expose] public section
@@ -24,7 +25,7 @@ def Clause.maxLiteral (c : Clause Nat) : Option Nat := (c.map (·.1)) |>.max?
 theorem Clause.of_maxLiteral_eq_some (c : Clause Nat) (h : c.maxLiteral = some maxLit) :
     ∀ lit, Mem lit c → lit ≤ maxLit := by
   intro lit hlit
-  simp only [maxLiteral, List.max?_eq_some_iff', List.mem_map, forall_exists_index, and_imp,
+  simp only [maxLiteral, List.max?_eq_some_iff, List.mem_map, forall_exists_index, and_imp,
     forall_apply_eq_imp_iff₂] at h
   simp only [Mem] at hlit
   rcases h with ⟨_, hbar⟩
@@ -57,7 +58,7 @@ def maxLiteral (f : CNF Nat) : Option Nat :=
 theorem of_maxLiteral_eq_some' (f : CNF Nat) (h : f.maxLiteral = some maxLit) :
     ∀ clause, clause ∈ f → clause.maxLiteral = some localMax → localMax ≤ maxLit := by
   intro clause hclause1 hclause2
-  simp [maxLiteral, List.max?_eq_some_iff'] at h
+  simp [maxLiteral, List.max?_eq_some_iff] at h
   rcases h with ⟨_, hclause3⟩
   apply hclause3 localMax clause hclause1 hclause2
 

src/Std/Tactic/Do/Syntax.lean

@@ -126,7 +126,14 @@ syntax (name := mstop) "mstop" : tactic
 @[inherit_doc Lean.Parser.Tactic.mleaveMacro]
 macro (name := mleave) "mleave" : tactic =>
   `(tactic| (try simp only [
-              $(mkIdent ``Std.Do.SPred.entails_cons):term,
+              $(mkIdent ``Std.Do.SPred.down_pure):term,
+              $(mkIdent ``Std.Do.SPred.apply_pure):term,
+              -- $(mkIdent ``Std.Do.SPred.entails_cons):term, -- Ineffective until #9015 lands
+              $(mkIdent ``Std.Do.SPred.entails_1):term,
+              $(mkIdent ``Std.Do.SPred.entails_2):term,
+              $(mkIdent ``Std.Do.SPred.entails_3):term,
+              $(mkIdent ``Std.Do.SPred.entails_4):term,
+              $(mkIdent ``Std.Do.SPred.entails_5):term,
               $(mkIdent ``Std.Do.SPred.entails_nil):term,
               $(mkIdent ``Std.Do.SPred.and_cons):term,
               $(mkIdent ``Std.Do.SPred.and_nil):term,
@@ -148,11 +155,12 @@ macro (name := mleave) "mleave" : tactic =>
               $(mkIdent ``Std.Do.SVal.uncurry_nil):term,
               $(mkIdent ``Std.Do.SVal.getThe_here):term,
               $(mkIdent ``Std.Do.SVal.getThe_there):term,
-              $(mkIdent ``Std.Do.FailConds.entails.refl):term,
-              $(mkIdent ``Std.Do.FailConds.entails_true):term,
-              $(mkIdent ``Std.Do.FailConds.entails_false):term,
+              $(mkIdent ``Std.Do.ExceptConds.entails.refl):term,
+              $(mkIdent ``Std.Do.ExceptConds.entails_true):term,
+              $(mkIdent ``Std.Do.ExceptConds.entails_false):term,
               $(mkIdent ``ULift.down_ite):term,
               $(mkIdent ``ULift.down_dite):term,
+              $(mkIdent ``Std.List.Zipper.pref):term,
               $(mkIdent ``and_imp):term,
               $(mkIdent ``and_true):term,
               $(mkIdent ``dite_eq_ite):term,
@@ -283,7 +291,7 @@ Like `mspec`, but does not attempt slight simplification and closing of trivial
 ```
 mspec_no_simp $spec
 all_goals
-  ((try simp only [SPred.true_intro_simp, SVal.curry_cons, SVal.uncurry_nil, SVal.uncurry_cons, SVal.getThe_here, SVal.getThe_there]);
+  ((try simp only [SPred.true_intro_simp, SPred.apply_pure]);
    (try mpure_intro; trivial))
 ```
 -/
@@ -310,11 +318,7 @@ macro (name := mspec) "mspec" spec:(ppSpace colGt term)? : tactic =>
   `(tactic| (mspec_no_simp $[$spec]?
              all_goals ((try simp only [
                           $(mkIdent ``Std.Do.SPred.true_intro_simp):term,
-                          $(mkIdent ``Std.Do.SVal.curry_cons):term,
-                          $(mkIdent ``Std.Do.SVal.uncurry_nil):term,
-                          $(mkIdent ``Std.Do.SVal.uncurry_cons):term,
-                          $(mkIdent ``Std.Do.SVal.getThe_here):term,
-                          $(mkIdent ``Std.Do.SVal.getThe_there):term])
+                          $(mkIdent ``Std.Do.SPred.apply_pure):term])
                         (try mpure_intro; trivial))))
 
 @[inherit_doc Lean.Parser.Tactic.mvcgenMacro]

src/Std/Time/Format.lean

@@ -129,10 +129,10 @@ in SQL databases to represent dates.
 def sqlDate : GenericFormat .any := datespec("uuuu-MM-dd")
 
 /--
-The LongDateFormat, which follows the pattern `EEEE, MMMM D, uuuu HH:mm:ss` for
+The LongDateFormat, which follows the pattern `EEEE, MMMM d, uuuu HH:mm:ss` for
 representing a full date and time with the day of the week and month name.
 -/
-def longDateFormat : GenericFormat (.only .GMT) := datespec("EEEE, MMMM D, uuuu HH:mm:ss")
+def longDateFormat : GenericFormat (.only .GMT) := datespec("EEEE, MMMM d, uuuu HH:mm:ss")
 
 /--
 The AscTime format, which follows the pattern `EEE MMM d HH:mm:ss uuuu`. This format

src/lake/Lake/Config/ConfigDecl.lean

@@ -126,6 +126,7 @@ abbrev InputFileDecl := KConfigDecl InputFile.configKind
 /-- A inpurt directory declaration from a configuration written in Lean. -/
 abbrev InputDirDecl := KConfigDecl InputDir.configKind
 
-deriving instance TypeName for
-  LeanLibDecl, LeanExeDecl,
-  InputFileDecl, InputDirDecl
+instance : TypeName LeanLibDecl := unsafe (.mk _ ``LeanLibDecl)
+instance : TypeName LeanExeDecl := unsafe (.mk _ ``LeanExeDecl)
+instance : TypeName InputFileDecl := unsafe (.mk _ ``InputFileDecl)
+instance : TypeName InputDirDecl := unsafe (.mk _ ``InputDirDecl)

src/lake/Lake/Config/FacetConfig.lean

@@ -87,8 +87,9 @@ abbrev LibraryFacetConfig := KFacetConfig LeanLib.facetKind
 /-- A library facet declaration from a configuration file. -/
 abbrev LibraryFacetDecl := NamedConfigDecl LibraryFacetConfig
 
-deriving instance TypeName for
-  ModuleFacetDecl, PackageFacetDecl, LibraryFacetDecl
+instance : TypeName ModuleFacetDecl := unsafe (.mk _ ``ModuleFacetDecl)
+instance : TypeName PackageFacetDecl := unsafe (.mk _ ``PackageFacetDecl)
+instance : TypeName LibraryFacetDecl := unsafe (.mk _ ``LibraryFacetDecl)
 
 /-- A library facet's declarative configuration. -/
 abbrev LeanLibFacetConfig := LibraryFacetConfig

src/lake/Lake/Config/Script.lean

@@ -22,7 +22,7 @@ also equipped with information about the Lake configuration.
 -/
 abbrev ScriptFn := (args : List String) → ScriptM ExitCode
 
-deriving instance TypeName for ScriptFn
+instance : TypeName ScriptFn := unsafe (.mk _ ``ScriptFn)
 
 /--
 A package `Script` is a `ScriptFn` definition that is

src/lake/Lake/Load/Toml.lean

@@ -347,6 +347,12 @@ instance : DecodeToml Dependency := ⟨fun v => do Dependency.decodeToml (← v.
 
 /-! ## Package & Target Configuration Decoders -/
 
+section
+-- We automatically disable the following option for `macro`s but the subsequent `def` both contains
+-- a quotation and is called only by `macro`s, so we disable the option for it manually. Note that
+-- we can't use `in` as it is parsed as a single command and so the option would not influence the
+-- parser.
+set_option internal.parseQuotWithCurrentStage false
 private def genDecodeToml
   (cmds : Array Command)
   (tyName : Name) [info : ConfigInfo tyName]  (takesName : Bool)
@@ -366,6 +372,7 @@ private def genDecodeToml
   let instId ← mkIdentFromRef <| `_root_ ++ tyName.str "instDecodeToml"
   let cmds ← cmds.push <$> `(instance $instId:ident : DecodeToml $ty := ⟨decodeTableValue $decId⟩)
   return cmds
+end
 
 local macro "gen_toml_decoders%" : command => do
   let cmds := #[]