.

This PR introduces a script that automates checking whether major
downstream repositories have been updated for a new toolchain release.

Sample output:
```
% ./release_checklist.py v4.16.0-rc1

Repository: Batteries
  ✅ On compatible toolchain (>= v4.16.0-rc1)
  ✅ Tag v4.16.0-rc1 exists

Repository: lean4checker
  ✅ On compatible toolchain (>= v4.16.0-rc1)
  ✅ Tag v4.16.0-rc1 exists

Repository: doc-gen4
  ✅ On compatible toolchain (>= v4.16.0-rc1)
  ✅ Tag v4.16.0-rc1 exists

Repository: Verso
  ❌ Not on target toolchain (needs ≥ v4.16.0-rc1, but main is on leanprover/lean4:v4.15.0)

Repository: ProofWidgets4
  ✅ On compatible toolchain (>= v4.16.0-rc1)

Repository: Aesop
  ✅ On compatible toolchain (>= v4.16.0-rc1)
  ✅ Tag v4.16.0-rc1 exists

Repository: import-graph
  ✅ On compatible toolchain (>= v4.16.0-rc1)
  ✅ Tag v4.16.0-rc1 exists

Repository: plausible
  ✅ On compatible toolchain (>= v4.16.0-rc1)
  ✅ Tag v4.16.0-rc1 exists

Repository: Mathlib
  ✅ On compatible toolchain (>= v4.16.0-rc1)
  ✅ Tag v4.16.0-rc1 exists

Repository: REPL
  ❌ Not on target toolchain (needs ≥ v4.16.0-rc1, but master is on leanprover/lean4:v4.14.0)
```

doc/dev/release_checklist.md

@@ -76,6 +76,10 @@ We'll use `v4.6.0` as the intended release version as a running example.
       - Toolchain bump PR including updated Lake manifest
       - Create and push the tag
       - There is no `stable` branch; skip this step
+    - [plausible](https://github.com/leanprover-community/plausible)
+      - Toolchain bump PR including updated Lake manifest
+      - Create and push the tag
+      - There is no `stable` branch; skip this step
     - [Mathlib](https://github.com/leanprover-community/mathlib4)
       - Dependencies: `Aesop`, `ProofWidgets4`, `lean4checker`, `Batteries`, `doc-gen4`, `import-graph`
       - Toolchain bump PR notes:
@@ -93,6 +97,7 @@ We'll use `v4.6.0` as the intended release version as a running example.
       - Toolchain bump PR including updated Lake manifest
       - Create and push the tag
       - Merge the tag into `stable`
+- Run `scripts/release_checklist.py v4.6.0` to check that everything is in order.
 - The `v4.6.0` section of `RELEASES.md` is out of sync between
   `releases/v4.6.0` and `master`. This should be reconciled:
   - Replace the `v4.6.0` section on `master` with the `v4.6.0` section on `releases/v4.6.0`

releases_drafts/list_lex.md

@@ -1,16 +0,0 @@
-We replace the inductive predicate `List.lt` with an upstreamed version of `List.Lex` from Mathlib.
-(Previously `Lex.lt` was defined in terms of `<`; now it is generalized to take an arbitrary relation.)
-This subtely changes the notion of ordering on `List α`.
-
-`List.lt` was a weaker relation: in particular if `l₁ < l₂`, then
-`a :: l₁ < b :: l₂` may hold according to `List.lt` even if `a` and `b` are merely incomparable
-(either neither `a < b` nor `b < a`), whereas according to `List.Lex` this would require `a = b`.
-
-When `<` is total, in the sense that `¬ · < ·` is antisymmetric, then the two relations coincide.
-
-Mathlib was already overriding the order instances for `List α`,
-so this change should not be noticed by anyone already using Mathlib.
-
-We simultaneously add the boolean valued `List.lex` function, parameterised by a `BEq` typeclass
-and an arbitrary `lt` function. This will support the flexibility previously provided for `List.lt`,
-via a `==` function which is weaker than strict equality.

script/prepare-llvm-mingw.sh

@@ -43,7 +43,7 @@ echo -n " -DCMAKE_C_COMPILER=$PWD/stage1/bin/clang.exe -DCMAKE_C_COMPILER_WORKS=
 echo -n " -DSTAGE0_CMAKE_C_COMPILER=clang -DSTAGE0_CMAKE_CXX_COMPILER=clang++"
 echo -n " -DLEAN_EXTRA_CXX_FLAGS='--sysroot $PWD/llvm -idirafter /clang64/include/'"
 echo -n " -DLEANC_INTERNAL_FLAGS='--sysroot ROOT -nostdinc -isystem ROOT/include/clang' -DLEANC_CC=ROOT/bin/clang.exe"
-echo -n " -DLEANC_INTERNAL_LINKER_FLAGS='-L ROOT/lib -static-libgcc -Wl,-Bstatic -lgmp $(pkg-config --static --libs libuv) -lunwind -Wl,-Bdynamic -fuse-ld=lld'"
+echo -n " -DLEANC_INTERNAL_LINKER_FLAGS='-L ROOT/lib -Wl,-Bstatic -lgmp $(pkg-config --static --libs libuv) -lunwind -Wl,-Bdynamic -fuse-ld=lld'"
 # when not using the above flags, link GMP dynamically/as usual. Always link ICU dynamically.
 echo -n " -DLEAN_EXTRA_LINKER_FLAGS='-lgmp $(pkg-config --libs libuv) -lucrtbase'"
 # do not set `LEAN_CC` for tests

script/release_checklist.py

@@ -0,0 +1,132 @@
+#!/usr/bin/env python3
+
+import argparse
+import yaml
+import requests
+import base64
+import subprocess
+import sys
+import os
+
+def parse_repos_config(file_path):
+    with open(file_path, "r") as f:
+        return yaml.safe_load(f)["repositories"]
+
+def get_github_token():
+    try:
+        import subprocess
+        result = subprocess.run(['gh', 'auth', 'token'], capture_output=True, text=True)
+        if result.returncode == 0:
+            return result.stdout.strip()
+    except FileNotFoundError:
+        print("Warning: 'gh' CLI not found. Some API calls may be rate-limited.")
+    return None
+
+def get_branch_content(repo_url, branch, file_path, github_token):
+    api_url = repo_url.replace("https://github.com/", "https://api.github.com/repos/") + f"/contents/{file_path}?ref={branch}"
+    headers = {'Authorization': f'token {github_token}'} if github_token else {}
+    response = requests.get(api_url, headers=headers)
+    if response.status_code == 200:
+        content = response.json().get("content", "")
+        content = content.replace("\n", "")
+        try:
+            return base64.b64decode(content).decode('utf-8').strip()
+        except Exception:
+            return None
+    return None
+
+def tag_exists(repo_url, tag_name, github_token):
+    api_url = repo_url.replace("https://github.com/", "https://api.github.com/repos/") + f"/git/refs/tags/{tag_name}"
+    headers = {'Authorization': f'token {github_token}'} if github_token else {}
+    response = requests.get(api_url, headers=headers)
+    return response.status_code == 200
+
+def is_merged_into_stable(repo_url, tag_name, stable_branch, github_token):
+    # First get the commit SHA for the tag
+    api_base = repo_url.replace("https://github.com/", "https://api.github.com/repos/")
+    headers = {'Authorization': f'token {github_token}'} if github_token else {}
+
+    # Get tag's commit SHA
+    tag_response = requests.get(f"{api_base}/git/refs/tags/{tag_name}", headers=headers)
+    if tag_response.status_code != 200:
+        return False
+    tag_sha = tag_response.json()['object']['sha']
+
+    # Get commits on stable branch containing this SHA
+    commits_response = requests.get(
+        f"{api_base}/commits?sha={stable_branch}&per_page=100",
+        headers=headers
+    )
+    if commits_response.status_code != 200:
+        return False
+
+    # Check if any commit in stable's history matches our tag's SHA
+    stable_commits = [commit['sha'] for commit in commits_response.json()]
+    return tag_sha in stable_commits
+
+def parse_version(version_str):
+    # Remove 'v' prefix and split into components
+    # Handle Lean toolchain format (leanprover/lean4:v4.x.y)
+    if ':' in version_str:
+        version_str = version_str.split(':')[1]
+    version = version_str.lstrip('v')
+    # Handle release candidates by removing -rc part for comparison
+    version = version.split('-')[0]
+    return tuple(map(int, version.split('.')))
+
+def is_version_gte(version1, version2):
+    """Check if version1 >= version2"""
+    return parse_version(version1) >= parse_version(version2)
+
+def is_release_candidate(version):
+    return "-rc" in version
+
+def main():
+    github_token = get_github_token()
+
+    if len(sys.argv) != 2:
+        print("Usage: python3 release_checklist.py <toolchain>")
+        sys.exit(1)
+
+    toolchain = sys.argv[1]
+
+    with open(os.path.join(os.path.dirname(__file__), "release_repos.yml")) as f:
+        repos = yaml.safe_load(f)["repositories"]
+
+    for repo in repos:
+        name = repo["name"]
+        url = repo["url"]
+        branch = repo["branch"]
+        check_stable = repo["stable-branch"]
+        check_tag = repo.get("toolchain-tag", True)
+
+        print(f"\nRepository: {name}")
+
+        # Check if branch is on at least the target toolchain
+        lean_toolchain_content = get_branch_content(url, branch, "lean-toolchain", github_token)
+        if lean_toolchain_content is None:
+            print(f"  ❌ No lean-toolchain file found in {branch} branch")
+            continue
+
+        on_target_toolchain = is_version_gte(lean_toolchain_content.strip(), toolchain)
+        if not on_target_toolchain:
+            print(f"  ❌ Not on target toolchain (needs ≥ {toolchain}, but {branch} is on {lean_toolchain_content.strip()})")
+            continue
+        print(f"  ✅ On compatible toolchain (>= {toolchain})")
+
+        # Only check for tag if toolchain-tag is true
+        if check_tag:
+            if not tag_exists(url, toolchain, github_token):
+                print(f"  ❌ Tag {toolchain} does not exist")
+                continue
+            print(f"  ✅ Tag {toolchain} exists")
+
+        # Only check merging into stable if stable-branch is true and not a release candidate
+        if check_stable and not is_release_candidate(toolchain):
+            if not is_merged_into_stable(url, toolchain, "stable", github_token):
+                print(f"  ❌ Tag {toolchain} is not merged into stable")
+                continue
+            print(f"  ✅ Tag {toolchain} is merged into stable")
+
+if __name__ == "__main__":
+    main()

script/release_repos.yml

@@ -0,0 +1,79 @@
+repositories:
+  - name: Batteries
+    url: https://github.com/leanprover-community/batteries
+    toolchain-tag: true
+    stable-branch: true
+    branch: main
+    dependencies: []
+
+  - name: lean4checker
+    url: https://github.com/leanprover/lean4checker
+    toolchain-tag: true
+    stable-branch: true
+    branch: master
+    dependencies: []
+
+  - name: doc-gen4
+    url: https://github.com/leanprover/doc-gen4
+    toolchain-tag: true
+    stable-branch: false
+    branch: main
+    dependencies: []
+
+  - name: Verso
+    url: https://github.com/leanprover/verso
+    toolchain-tag: true
+    stable-branch: false
+    branch: main
+    dependencies: []
+
+  - name: ProofWidgets4
+    url: https://github.com/leanprover-community/ProofWidgets4
+    toolchain-tag: false
+    stable-branch: false
+    branch: main
+    dependencies:
+      - Batteries
+
+  - name: Aesop
+    url: https://github.com/leanprover-community/aesop
+    toolchain-tag: true
+    stable-branch: true
+    branch: master
+    dependencies:
+      - Batteries
+
+  - name: import-graph
+    url: https://github.com/leanprover-community/import-graph
+    toolchain-tag: true
+    stable-branch: false
+    branch: main
+    dependencies: []
+
+  - name: plausible
+    url: https://github.com/leanprover-community/plausible
+    toolchain-tag: true
+    stable-branch: false
+    branch: main
+    dependencies: []
+
+  - name: Mathlib
+    url: https://github.com/leanprover-community/mathlib4
+    toolchain-tag: true
+    stable-branch: true
+    branch: master
+    dependencies:
+      - Aesop
+      - ProofWidgets4
+      - lean4checker
+      - Batteries
+      - doc-gen4
+      - import-graph
+
+  - name: REPL
+    url: https://github.com/leanprover-community/repl
+    toolchain-tag: true
+    stable-branch: true
+    branch: master
+    dependencies:
+      - Mathlib

src/Init.lean

@@ -37,3 +37,4 @@ import Init.MacroTrace
 import Init.Grind
 import Init.While
 import Init.Syntax
+import Init.Internal

src/Init/Data/Array/Lemmas.lean

@@ -36,6 +36,8 @@ namespace Array
 @[simp] theorem mem_toList_iff (a : α) (l : Array α) : a ∈ l.toList ↔ a ∈ l := by
   cases l <;> simp
 
+@[simp] theorem length_toList {l : Array α} : l.toList.length = l.size := rfl
+
 /-! ### empty -/
 
 @[simp] theorem empty_eq {xs : Array α} : #[] = xs ↔ xs = #[] := by
@@ -954,13 +956,18 @@ theorem size_eq_of_beq [BEq α] {xs ys : Array α} (h : xs == ys) : xs.size = ys
     rw [Bool.eq_iff_iff]
     simp +contextual
 
+private theorem beq_of_beq_singleton [BEq α] {a b : α} : #[a] == #[b] → a == b := by
+  intro h
+  have : isEqv #[a] #[b] BEq.beq = true := h
+  simp [isEqv, isEqvAux] at this
+  assumption
+
 @[simp] theorem reflBEq_iff [BEq α] : ReflBEq (Array α) ↔ ReflBEq α := by
   constructor
   · intro h
     constructor
     intro a
-    suffices (#[a] == #[a]) = true by
-      simpa only [instBEq, isEqv, isEqvAux, Bool.and_true]
+    apply beq_of_beq_singleton
     simp
   · intro h
     constructor
@@ -973,11 +980,9 @@ theorem size_eq_of_beq [BEq α] {xs ys : Array α} (h : xs == ys) : xs.size = ys
     · intro a b h
       apply singleton_inj.1
       apply eq_of_beq
-      simp only [instBEq, isEqv, isEqvAux]
-      simpa
+      simpa [instBEq, isEqv, isEqvAux]
     · intro a
-      suffices (#[a] == #[a]) = true by
-        simpa only [instBEq, isEqv, isEqvAux, Bool.and_true]
+      apply beq_of_beq_singleton
       simp
   · intro h
     constructor
@@ -998,52 +1003,7 @@ theorem size_eq_of_beq [BEq α] {xs ys : Array α} (h : xs == ys) : xs.size = ys
 
 /-! Content below this point has not yet been aligned with `List`. -/
 
-theorem singleton_eq_toArray_singleton (a : α) : #[a] = [a].toArray := rfl
-
-@[simp] theorem singleton_def (v : α) : singleton v = #[v] := rfl
-
--- This is a duplicate of `List.toArray_toList`.
--- It's confusing to guess which namespace this theorem should live in,
--- so we provide both.
-@[simp] theorem toArray_toList (a : Array α) : a.toList.toArray = a := rfl
-
-@[simp] theorem length_toList {l : Array α} : l.toList.length = l.size := rfl
-
-@[simp] theorem mkEmpty_eq (α n) : @mkEmpty α n = #[] := rfl
-
-@[deprecated size_toArray (since := "2024-12-11")]
-theorem size_mk (as : List α) : (Array.mk as).size = as.length := by simp [size]
-
-theorem foldrM_push [Monad m] (f : α → β → m β) (init : β) (arr : Array α) (a : α) :
-    (arr.push a).foldrM f init = f a init >>= arr.foldrM f := by
-  simp only [foldrM_eq_reverse_foldlM_toList, push_toList, List.reverse_append, List.reverse_cons,
-    List.reverse_nil, List.nil_append, List.singleton_append, List.foldlM_cons, List.foldlM_reverse]
-
-/--
-Variant of `foldrM_push` with `h : start = arr.size + 1`
-rather than `(arr.push a).size` as the argument.
--/
-@[simp] theorem foldrM_push' [Monad m] (f : α → β → m β) (init : β) (arr : Array α) (a : α)
-    {start} (h : start = arr.size + 1) :
-    (arr.push a).foldrM f init start = f a init >>= arr.foldrM f := by
-  simp [← foldrM_push, h]
-
-theorem foldr_push (f : α → β → β) (init : β) (arr : Array α) (a : α) :
-    (arr.push a).foldr f init = arr.foldr f (f a init) := foldrM_push ..
-
-/--
-Variant of `foldr_push` with the `h : start = arr.size + 1`
-rather than `(arr.push a).size` as the argument.
--/
-@[simp] theorem foldr_push' (f : α → β → β) (init : β) (arr : Array α) (a : α) {start}
-    (h : start = arr.size + 1) : (arr.push a).foldr f init start = arr.foldr f (f a init) :=
-  foldrM_push' _ _ _ _ h
-
-/-- A more efficient version of `arr.toList.reverse`. -/
-@[inline] def toListRev (arr : Array α) : List α := arr.foldl (fun l t => t :: l) []
-
-@[simp] theorem toListRev_eq (arr : Array α) : arr.toListRev = arr.toList.reverse := by
-  rw [toListRev, ← foldl_toList, ← List.foldr_reverse, List.foldr_cons_nil]
+/-! ### map -/
 
 theorem mapM_eq_foldlM [Monad m] [LawfulMonad m] (f : α → m β) (arr : Array α) :
     arr.mapM f = arr.foldlM (fun bs a => bs.push <$> f a) #[] := by
@@ -1067,6 +1027,11 @@ where
     induction l generalizing arr <;> simp [*]
   simp [H]
 
+@[simp] theorem _root_.List.map_toArray (f : α → β) (l : List α) :
+    l.toArray.map f = (l.map f).toArray := by
+  apply ext'
+  simp
+
 @[simp] theorem size_map (f : α → β) (arr : Array α) : (arr.map f).size = arr.size := by
   simp only [← length_toList]
   simp
@@ -1076,6 +1041,128 @@ where
 
 @[simp] theorem map_empty (f : α → β) : map f #[] = #[] := mapM_empty f
 
+@[simp] theorem getElem_map (f : α → β) (a : Array α) (i : Nat) (hi : i < (a.map f).size) :
+    (a.map f)[i] = f (a[i]'(by simpa using hi)) := by
+  cases a
+  simp
+
+@[simp] theorem getElem?_map (f : α → β) (as : Array α) (i : Nat) :
+    (as.map f)[i]? = as[i]?.map f := by
+  simp [getElem?_def]
+
+@[simp] theorem map_id_fun : map (id : α → α) = id := by
+  funext l
+  induction l <;> simp_all
+
+/-- `map_id_fun'` differs from `map_id_fun` by representing the identity function as a lambda, rather than `id`. -/
+@[simp] theorem map_id_fun' : map (fun (a : α) => a) = id := map_id_fun
+
+-- This is not a `@[simp]` lemma because `map_id_fun` will apply.
+theorem map_id (l : Array α) : map (id : α → α) l = l := by
+  cases l <;> simp_all
+
+/-- `map_id'` differs from `map_id` by representing the identity function as a lambda, rather than `id`. -/
+-- This is not a `@[simp]` lemma because `map_id_fun'` will apply.
+theorem map_id' (l : Array α) : map (fun (a : α) => a) l = l := map_id l
+
+/-- Variant of `map_id`, with a side condition that the function is pointwise the identity. -/
+theorem map_id'' {f : α → α} (h : ∀ x, f x = x) (l : Array α) : map f l = l := by
+  simp [show f = id from funext h]
+
+theorem map_singleton (f : α → β) (a : α) : map f #[a] = #[f a] := rfl
+
+@[simp] theorem mem_map {f : α → β} {l : Array α} : b ∈ l.map f ↔ ∃ a, a ∈ l ∧ f a = b := by
+  simp only [mem_def, toList_map, List.mem_map]
+
+theorem exists_of_mem_map (h : b ∈ map f l) : ∃ a, a ∈ l ∧ f a = b := mem_map.1 h
+
+theorem mem_map_of_mem (f : α → β) (h : a ∈ l) : f a ∈ map f l := mem_map.2 ⟨_, h, rfl⟩
+
+theorem forall_mem_map {f : α → β} {l : Array α} {P : β → Prop} :
+    (∀ (i) (_ : i ∈ l.map f), P i) ↔ ∀ (j) (_ : j ∈ l), P (f j) := by
+  simp
+
+@[simp] theorem map_inj_left {f g : α → β} : map f l = map g l ↔ ∀ a ∈ l, f a = g a := by
+  cases l <;> simp_all
+
+theorem map_congr_left (h : ∀ a ∈ l, f a = g a) : map f l = map g l :=
+  map_inj_left.2 h
+
+theorem map_inj : map f = map g ↔ f = g := by
+  constructor
+  · intro h; ext a; replace h := congrFun h #[a]; simpa using h
+  · intro h; subst h; rfl
+
+@[simp] theorem map_eq_empty_iff {f : α → β} {l : Array α} : map f l = #[] ↔ l = #[] := by
+  cases l
+  simp
+
+theorem eq_empty_of_map_eq_empty {f : α → β} {l : Array α} (h : map f l = #[]) : l = #[] :=
+  map_eq_empty_iff.mp h
+
+@[simp] theorem map_map {f : α → β} {g : β → γ} {as : Array α} :
+    (as.map f).map g = as.map (g ∘ f) := by
+  cases as; simp
+
+@[simp] theorem map_push {f : α → β} {as : Array α} {x : α} :
+    (as.push x).map f = (as.map f).push (f x) := by
+  ext
+  · simp
+  · simp only [getElem_map, getElem_push, size_map]
+    split <;> rfl
+
+theorem mapM_eq_mapM_toList [Monad m] [LawfulMonad m] (f : α → m β) (arr : Array α) :
+    arr.mapM f = List.toArray <$> (arr.toList.mapM f) := by
+  rw [mapM_eq_foldlM, ← foldlM_toList, ← List.foldrM_reverse]
+  conv => rhs; rw [← List.reverse_reverse arr.toList]
+  induction arr.toList.reverse with
+  | nil => simp
+  | cons a l ih => simp [ih]
+
+@[simp] theorem toList_mapM [Monad m] [LawfulMonad m] (f : α → m β) (arr : Array α) :
+    toList <$> arr.mapM f = arr.toList.mapM f := by
+  simp [mapM_eq_mapM_toList]
+
+theorem mapM_map_eq_foldl (as : Array α) (f : α → β) (i) :
+    mapM.map (m := Id) f as i b = as.foldl (start := i) (fun r a => r.push (f a)) b := by
+  unfold mapM.map
+  split <;> rename_i h
+  · simp only [Id.bind_eq]
+    dsimp [foldl, Id.run, foldlM]
+    rw [mapM_map_eq_foldl, dif_pos (by omega), foldlM.loop, dif_pos h]
+    -- Calling `split` here gives a bad goal.
+    have : size as - i = Nat.succ (size as - i - 1) := by omega
+    rw [this]
+    simp [foldl, foldlM, Id.run, Nat.sub_add_eq]
+  · dsimp [foldl, Id.run, foldlM]
+    rw [dif_pos (by omega), foldlM.loop, dif_neg h]
+    rfl
+termination_by as.size - i
+
+theorem map_eq_foldl (as : Array α) (f : α → β) :
+    as.map f = as.foldl (fun r a => r.push (f a)) #[] :=
+  mapM_map_eq_foldl _ _ _
+
+theorem singleton_eq_toArray_singleton (a : α) : #[a] = [a].toArray := rfl
+
+@[simp] theorem singleton_def (v : α) : singleton v = #[v] := rfl
+
+-- This is a duplicate of `List.toArray_toList`.
+-- It's confusing to guess which namespace this theorem should live in,
+-- so we provide both.
+@[simp] theorem toArray_toList (a : Array α) : a.toList.toArray = a := rfl
+
+@[simp] theorem mkEmpty_eq (α n) : @mkEmpty α n = #[] := rfl
+
+@[deprecated size_toArray (since := "2024-12-11")]
+theorem size_mk (as : List α) : (Array.mk as).size = as.length := by simp [size]
+
+/-- A more efficient version of `arr.toList.reverse`. -/
+@[inline] def toListRev (arr : Array α) : List α := arr.foldl (fun l t => t :: l) []
+
+@[simp] theorem toListRev_eq (arr : Array α) : arr.toListRev = arr.toList.reverse := by
+  rw [toListRev, ← foldl_toList, ← List.foldr_reverse, List.foldr_cons_nil]
+
 @[simp] theorem appendList_nil (arr : Array α) : arr ++ ([] : List α) = arr := Array.ext' (by simp)
 
 @[simp] theorem appendList_cons (arr : Array α) (a : α) (l : List α) :
@@ -1091,7 +1178,6 @@ theorem foldl_toList_eq_map (l : List α) (acc : Array β) (G : α → β) :
     (l.foldl (fun acc a => acc.push (G a)) acc).toList = acc.toList ++ l.map G := by
   induction l generalizing acc <;> simp [*]
 
-
 /-! # uset -/
 
 attribute [simp] uset
@@ -1267,18 +1353,16 @@ theorem get_set (a : Array α) (i : Nat) (hi : i < a.size) (j : Nat) (hj : j < a
     (h : i ≠ j) : (a.set i v)[j]'(by simp [*]) = a[j] := by
   simp only [set, ← getElem_toList, List.getElem_set_ne h]
 
-private theorem fin_cast_val (e : n = n') (i : Fin n) : e ▸ i = ⟨i.1, e ▸ i.2⟩ := by cases e; rfl
-
 theorem swap_def (a : Array α) (i j : Nat) (hi hj) :
     a.swap i j hi hj = (a.set i a[j]).set j a[i] (by simpa using hj) := by
-  simp [swap, fin_cast_val]
+  simp [swap]
 
 @[simp] theorem toList_swap (a : Array α) (i j : Nat) (hi hj) :
     (a.swap i j hi hj).toList = (a.toList.set i a[j]).set j a[i] := by simp [swap_def]
 
 theorem getElem?_swap (a : Array α) (i j : Nat) (hi hj) (k : Nat) : (a.swap i j hi hj)[k]? =
     if j = k then some a[i] else if i = k then some a[j] else a[k]? := by
-  simp [swap_def, get?_set, ← getElem_fin_eq_getElem_toList]
+  simp [swap_def, get?_set]
 
 @[simp] theorem swapAt_def (a : Array α) (i : Nat) (v : α) (hi) :
     a.swapAt i v hi = (a[i], a.set i v) := rfl
@@ -1393,6 +1477,90 @@ theorem getElem_range {n : Nat} {x : Nat} (h : x < (Array.range n).size) : (Arra
         true_and, Nat.not_lt] at h
       rw [List.getElem?_eq_none_iff.2 ‹_›, List.getElem?_eq_none_iff.2 (a.toList.length_reverse ▸ ‹_›)]
 
+end Array
+
+open Array
+
+namespace List
+
+@[simp] theorem reverse_toArray (l : List α) : l.toArray.reverse = l.reverse.toArray := by
+  apply ext'
+  simp only [toList_reverse]
+
+end List
+
+namespace Array
+
+/-! ### foldlM and foldrM -/
+
+theorem foldlM_append [Monad m] [LawfulMonad m] (f : β → α → m β) (b) (l l' : Array α) :
+    (l ++ l').foldlM f b = l.foldlM f b >>= l'.foldlM f := by
+  cases l
+  cases l'
+  rw [List.append_toArray]
+  simp
+
+/-- Variant of `foldM_append` with `h : stop = (l ++ l').size`. -/
+@[simp] theorem foldlM_append' [Monad m] [LawfulMonad m] (f : β → α → m β) (b) (l l' : Array α)
+    (h : stop = (l ++ l').size) :
+    (l ++ l').foldlM f b 0 stop = l.foldlM f b >>= l'.foldlM f := by
+  subst h
+  rw [foldlM_append]
+
+theorem foldrM_push [Monad m] (f : α → β → m β) (init : β) (arr : Array α) (a : α) :
+    (arr.push a).foldrM f init = f a init >>= arr.foldrM f := by
+  simp only [foldrM_eq_reverse_foldlM_toList, push_toList, List.reverse_append, List.reverse_cons,
+    List.reverse_nil, List.nil_append, List.singleton_append, List.foldlM_cons, List.foldlM_reverse]
+
+/--
+Variant of `foldrM_push` with `h : start = arr.size + 1`
+rather than `(arr.push a).size` as the argument.
+-/
+@[simp] theorem foldrM_push' [Monad m] (f : α → β → m β) (init : β) (arr : Array α) (a : α)
+    {start} (h : start = arr.size + 1) :
+    (arr.push a).foldrM f init start = f a init >>= arr.foldrM f := by
+  simp [← foldrM_push, h]
+
+theorem foldl_eq_foldlM (f : β → α → β) (b) (l : Array α) :
+    l.foldl f b = l.foldlM (m := Id) f b := by
+  cases l
+  simp [List.foldl_eq_foldlM]
+
+theorem foldr_eq_foldrM (f : α → β → β) (b) (l : Array α) :
+    l.foldr f b = l.foldrM (m := Id) f b := by
+  cases l
+  simp [List.foldr_eq_foldrM]
+
+@[simp] theorem id_run_foldlM (f : β → α → Id β) (b) (l : Array α) :
+    Id.run (l.foldlM f b) = l.foldl f b := (foldl_eq_foldlM f b l).symm
+
+@[simp] theorem id_run_foldrM (f : α → β → Id β) (b) (l : Array α) :
+    Id.run (l.foldrM f b) = l.foldr f b := (foldr_eq_foldrM f b l).symm
+
+/-! ### foldl and foldr -/
+
+theorem foldr_push (f : α → β → β) (init : β) (arr : Array α) (a : α) :
+    (arr.push a).foldr f init = arr.foldr f (f a init) := foldrM_push ..
+
+/--
+Variant of `foldr_push` with the `h : start = arr.size + 1`
+rather than `(arr.push a).size` as the argument.
+-/
+@[simp] theorem foldr_push' (f : α → β → β) (init : β) (arr : Array α) (a : α) {start}
+    (h : start = arr.size + 1) : (arr.push a).foldr f init start = arr.foldr f (f a init) :=
+  foldrM_push' _ _ _ _ h
+
+@[simp] theorem foldl_push_eq_append (l l' : Array α) : l.foldl push l' = l' ++ l := by
+  cases l
+  cases l'
+  simp
+
+@[simp] theorem foldr_flip_push_eq_append (l l' : Array α) :
+    l.foldr (fun x y => push y x) l' = l' ++ l.reverse := by
+  cases l
+  cases l'
+  simp
+
 /-! ### take -/
 
 @[simp] theorem size_take_loop (a : Array α) (n : Nat) : (take.loop n a).size = a.size - n := by
@@ -1505,22 +1673,6 @@ theorem foldr_congr {as bs : Array α} (h₀ : as = bs) {f g : α → β → β}
     as.foldr f a start stop = bs.foldr g b start' stop' := by
   congr
 
-theorem foldl_eq_foldlM (f : β → α → β) (b) (l : Array α) :
-    l.foldl f b = l.foldlM (m := Id) f b := by
-  cases l
-  simp [List.foldl_eq_foldlM]
-
-theorem foldr_eq_foldrM (f : α → β → β) (b) (l : Array α) :
-    l.foldr f b = l.foldrM (m := Id) f b := by
-  cases l
-  simp [List.foldr_eq_foldrM]
-
-@[simp] theorem id_run_foldlM (f : β → α → Id β) (b) (l : Array α) :
-    Id.run (l.foldlM f b) = l.foldl f b := (foldl_eq_foldlM f b l).symm
-
-@[simp] theorem id_run_foldrM (f : α → β → Id β) (b) (l : Array α) :
-    Id.run (l.foldrM f b) = l.foldr f b := (foldr_eq_foldrM f b l).symm
-
 theorem foldl_hom (f : α₁ → α₂) (g₁ : α₁ → β → α₁) (g₂ : α₂ → β → α₂) (l : Array β) (init : α₁)
     (H : ∀ x y, g₂ (f x) y = f (g₁ x y)) : l.foldl g₂ (f init) = f (l.foldl g₁ init) := by
   cases l
@@ -1535,45 +1687,13 @@ theorem foldr_hom (f : β₁ → β₂) (g₁ : α → β₁ → β₁) (g₂ :
 
 /-! ### map -/
 
-@[simp] theorem mem_map {f : α → β} {l : Array α} : b ∈ l.map f ↔ ∃ a, a ∈ l ∧ f a = b := by
-  simp only [mem_def, toList_map, List.mem_map]
-
-theorem exists_of_mem_map (h : b ∈ map f l) : ∃ a, a ∈ l ∧ f a = b := mem_map.1 h
-
-theorem mem_map_of_mem (f : α → β) (h : a ∈ l) : f a ∈ map f l := mem_map.2 ⟨_, h, rfl⟩
-
-theorem mapM_eq_mapM_toList [Monad m] [LawfulMonad m] (f : α → m β) (arr : Array α) :
-    arr.mapM f = List.toArray <$> (arr.toList.mapM f) := by
-  rw [mapM_eq_foldlM, ← foldlM_toList, ← List.foldrM_reverse]
-  conv => rhs; rw [← List.reverse_reverse arr.toList]
-  induction arr.toList.reverse with
-  | nil => simp
-  | cons a l ih => simp [ih]
-
-@[simp] theorem toList_mapM [Monad m] [LawfulMonad m] (f : α → m β) (arr : Array α) :
-    toList <$> arr.mapM f = arr.toList.mapM f := by
-  simp [mapM_eq_mapM_toList]
-
-theorem mapM_map_eq_foldl (as : Array α) (f : α → β) (i) :
-    mapM.map (m := Id) f as i b = as.foldl (start := i) (fun r a => r.push (f a)) b := by
-  unfold mapM.map
-  split <;> rename_i h
-  · simp only [Id.bind_eq]
-    dsimp [foldl, Id.run, foldlM]
-    rw [mapM_map_eq_foldl, dif_pos (by omega), foldlM.loop, dif_pos h]
-    -- Calling `split` here gives a bad goal.
-    have : size as - i = Nat.succ (size as - i - 1) := by omega
-    rw [this]
-    simp [foldl, foldlM, Id.run, Nat.sub_add_eq]
-  · dsimp [foldl, Id.run, foldlM]
-    rw [dif_pos (by omega), foldlM.loop, dif_neg h]
-    rfl
-termination_by as.size - i
-
-theorem map_eq_foldl (as : Array α) (f : α → β) :
-    as.map f = as.foldl (fun r a => r.push (f a)) #[] :=
-  mapM_map_eq_foldl _ _ _
+@[simp] theorem map_pop {f : α → β} {as : Array α} :
+    as.pop.map f = (as.map f).pop := by
+  ext
+  · simp
+  · simp only [getElem_map, getElem_pop, size_map]
 
+@[deprecated "Use `toList_map` or `List.map_toArray` to characterize `Array.map`." (since := "2025-01-06")]
 theorem map_induction (as : Array α) (f : α → β) (motive : Nat → Prop) (h0 : motive 0)
     (p : Fin as.size → β → Prop) (hs : ∀ i, motive i.1 → p i (f as[i]) ∧ motive (i+1)) :
     motive as.size ∧
@@ -1601,36 +1721,13 @@ theorem map_induction (as : Array α) (f : α → β) (motive : Nat → Prop) (h
         simp only [show j = i by omega]
         exact (hs _ m).1
 
+set_option linter.deprecated false in
+@[deprecated "Use `toList_map` or `List.map_toArray` to characterize `Array.map`." (since := "2025-01-06")]
 theorem map_spec (as : Array α) (f : α → β) (p : Fin as.size → β → Prop)
     (hs : ∀ i, p i (f as[i])) :
     ∃ eq : (as.map f).size = as.size, ∀ i h, p ⟨i, h⟩ ((as.map f)[i]) := by
   simpa using map_induction as f (fun _ => True) trivial p (by simp_all)
 
-@[simp] theorem getElem_map (f : α → β) (as : Array α) (i : Nat) (h) :
-    (as.map f)[i] = f (as[i]'(size_map .. ▸ h)) := by
-  have := map_spec as f (fun i b => b = f (as[i]))
-  simp only [implies_true, true_implies] at this
-  obtain ⟨eq, w⟩ := this
-  apply w
-  simp_all
-
-@[simp] theorem getElem?_map (f : α → β) (as : Array α) (i : Nat) :
-    (as.map f)[i]? = as[i]?.map f := by
-  simp [getElem?_def]
-
-@[simp] theorem map_push {f : α → β} {as : Array α} {x : α} :
-    (as.push x).map f = (as.map f).push (f x) := by
-  ext
-  · simp
-  · simp only [getElem_map, getElem_push, size_map]
-    split <;> rfl
-
-@[simp] theorem map_pop {f : α → β} {as : Array α} :
-    as.pop.map f = (as.map f).pop := by
-  ext
-  · simp
-  · simp only [getElem_map, getElem_pop, size_map]
-
 /-! ### modify -/
 
 @[simp] theorem size_modify (a : Array α) (i : Nat) (f : α → α) : (a.modify i f).size = a.size := by
@@ -2117,10 +2214,6 @@ theorem toListRev_toArray (l : List α) : l.toArray.toListRev = l.reverse := by
     rw [size_toArray, mapM'_cons, foldlM_toArray]
     simp [ih]
 
-@[simp] theorem map_toArray (f : α → β) (l : List α) : l.toArray.map f = (l.map f).toArray := by
-  apply ext'
-  simp
-
 theorem uset_toArray (l : List α) (i : USize) (a : α) (h : i.toNat < l.toArray.size) :
     l.toArray.uset i a h = (l.set i.toNat a).toArray := by simp
 
@@ -2129,10 +2222,6 @@ theorem uset_toArray (l : List α) (i : USize) (a : α) (h : i.toNat < l.toArray
   apply ext'
   simp
 
-@[simp] theorem reverse_toArray (l : List α) : l.toArray.reverse = l.reverse.toArray := by
-  apply ext'
-  simp
-
 @[simp] theorem modify_toArray (f : α → α) (l : List α) :
     l.toArray.modify i f = (l.modify f i).toArray := by
   apply ext'
@@ -2226,29 +2315,6 @@ namespace Array
 
 /-! ### map -/
 
-@[simp] theorem map_map {f : α → β} {g : β → γ} {as : Array α} :
-    (as.map f).map g = as.map (g ∘ f) := by
-  cases as; simp
-
-@[simp] theorem map_id_fun : map (id : α → α) = id := by
-  funext l
-  induction l <;> simp_all
-
-/-- `map_id_fun'` differs from `map_id_fun` by representing the identity function as a lambda, rather than `id`. -/
-@[simp] theorem map_id_fun' : map (fun (a : α) => a) = id := map_id_fun
-
--- This is not a `@[simp]` lemma because `map_id_fun` will apply.
-theorem map_id (as : Array α) : map (id : α → α) as = as := by
-  cases as <;> simp_all
-
-/-- `map_id'` differs from `map_id` by representing the identity function as a lambda, rather than `id`. -/
--- This is not a `@[simp]` lemma because `map_id_fun'` will apply.
-theorem map_id' (as : Array α) : map (fun (a : α) => a) as = as := map_id as
-
-/-- Variant of `map_id`, with a side condition that the function is pointwise the identity. -/
-theorem map_id'' {f : α → α} (h : ∀ x, f x = x) (as : Array α) : map f as = as := by
-  simp [show f = id from funext h]
-
 theorem array_array_induction (P : Array (Array α) → Prop) (h : ∀ (xss : List (List α)), P (xss.map List.toArray).toArray)
     (ass : Array (Array α)) : P ass := by
   specialize h (ass.toList.map toList)

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

@@ -17,8 +17,8 @@ namespace Array
 @[simp] theorem lt_toList [LT α] (l₁ l₂ : Array α) : l₁.toList < l₂.toList ↔ l₁ < l₂ := Iff.rfl
 @[simp] theorem le_toList [LT α] (l₁ l₂ : Array α) : l₁.toList ≤ l₂.toList ↔ l₁ ≤ l₂ := Iff.rfl
 
-theorem not_lt_iff_ge [LT α] (l₁ l₂ : List α) : ¬ l₁ < l₂ ↔ l₂ ≤ l₁ := Iff.rfl
-theorem not_le_iff_gt [DecidableEq α] [LT α] [DecidableLT α] (l₁ l₂ : List α) :
+protected theorem not_lt_iff_ge [LT α] (l₁ l₂ : List α) : ¬ l₁ < l₂ ↔ l₂ ≤ l₁ := Iff.rfl
+protected theorem not_le_iff_gt [DecidableEq α] [LT α] [DecidableLT α] (l₁ l₂ : List α) :
     ¬ l₁ ≤ l₂ ↔ l₂ < l₁ :=
   Decidable.not_not
 
@@ -135,7 +135,7 @@ protected theorem le_of_lt [DecidableEq α] [LT α] [DecidableLT α]
     {l₁ l₂ : Array α} (h : l₁ < l₂) : l₁ ≤ l₂ :=
   List.le_of_lt h
 
-theorem le_iff_lt_or_eq [DecidableEq α] [LT α] [DecidableLT α]
+protected theorem le_iff_lt_or_eq [DecidableEq α] [LT α] [DecidableLT α]
     [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)]
     [Std.Total (¬ · < · : α → α → Prop)]
@@ -211,7 +211,7 @@ theorem lex_eq_false_iff_exists [BEq α] [PartialEquivBEq α] (lt : α → α
   cases l₂
   simp_all [List.lex_eq_false_iff_exists]
 
-theorem lt_iff_exists [DecidableEq α] [LT α] [DecidableLT α] {l₁ l₂ : Array α} :
+protected theorem lt_iff_exists [DecidableEq α] [LT α] [DecidableLT α] {l₁ l₂ : Array α} :
     l₁ < l₂ ↔
       (l₁ = l₂.take l₁.size ∧ l₁.size < l₂.size) ∨
         (∃ (i : Nat) (h₁ : i < l₁.size) (h₂ : i < l₂.size),
@@ -221,7 +221,7 @@ theorem lt_iff_exists [DecidableEq α] [LT α] [DecidableLT α] {l₁ l₂ : Arr
   cases l₂
   simp [List.lt_iff_exists]
 
-theorem le_iff_exists [DecidableEq α] [LT α] [DecidableLT α]
+protected theorem le_iff_exists [DecidableEq α] [LT α] [DecidableLT α]
     [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Asymm (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)] {l₁ l₂ : Array α} :
@@ -258,14 +258,14 @@ theorem le_append_left [LT α] [Std.Irrefl (· < · : α → α → Prop)]
   cases l₂
   simpa using List.le_append_left
 
-theorem map_lt [LT α] [LT β]
+protected theorem map_lt [LT α] [LT β]
     {l₁ l₂ : Array α} {f : α → β} (w : ∀ x y, x < y → f x < f y) (h : l₁ < l₂) :
     map f l₁ < map f l₂ := by
   cases l₁
   cases l₂
   simpa using List.map_lt w h
 
-theorem map_le [DecidableEq α] [LT α] [DecidableLT α] [DecidableEq β] [LT β] [DecidableLT β]
+protected theorem map_le [DecidableEq α] [LT α] [DecidableLT α] [DecidableEq β] [LT β] [DecidableLT β]
     [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Asymm (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)]

src/Init/Data/Int/DivModLemmas.lean

@@ -1098,6 +1098,32 @@ theorem bmod_def (x : Int) (m : Nat) : bmod x m =
     (x % m) - m :=
   rfl
 
+theorem bdiv_add_bmod (x : Int) (m : Nat) : m * bdiv x m + bmod x m = x := by
+  unfold bdiv bmod
+  split
+  · simp_all only [Nat.cast_ofNat_Int, Int.mul_zero, emod_zero, Int.zero_add, Int.sub_zero,
+      ite_self]
+  · dsimp only
+    split
+    · exact ediv_add_emod x m
+    · rw [Int.mul_add, Int.mul_one, Int.add_assoc, Int.add_comm m, Int.sub_add_cancel]
+      exact ediv_add_emod x m
+
+theorem bmod_add_bdiv (x : Int) (m : Nat) : bmod x m + m * bdiv x m = x := by
+  rw [Int.add_comm]; exact bdiv_add_bmod x m
+
+theorem bdiv_add_bmod' (x : Int) (m : Nat) : bdiv x m * m + bmod x m = x := by
+  rw [Int.mul_comm]; exact bdiv_add_bmod x m
+
+theorem bmod_add_bdiv' (x : Int) (m : Nat) : bmod x m + bdiv x m * m = x := by
+  rw [Int.add_comm]; exact bdiv_add_bmod' x m
+
+theorem bmod_eq_self_sub_mul_bdiv (x : Int) (m : Nat) : bmod x m = x - m * bdiv x m := by
+  rw [← Int.add_sub_cancel (bmod x m), bmod_add_bdiv]
+
+theorem bmod_eq_self_sub_bdiv_mul (x : Int) (m : Nat) : bmod x m = x - bdiv x m * m := by
+  rw [← Int.add_sub_cancel (bmod x m), bmod_add_bdiv']
+
 theorem bmod_pos (x : Int) (m : Nat) (p : x % m < (m + 1) / 2) : bmod x m = x % m := by
   simp [bmod_def, p]
 

src/Init/Data/List/Lemmas.lean

@@ -757,207 +757,6 @@ theorem length_eq_of_beq [BEq α] {l₁ l₂ : List α} (h : l₁ == l₂) : l
     | nil => simp
     | cons b l₂ => simp [isEqv, ih]
 
-/-! ### foldlM and foldrM -/
-
-@[simp] theorem foldlM_reverse [Monad m] (l : List α) (f : β → α → m β) (b) :
-    l.reverse.foldlM f b = l.foldrM (fun x y => f y x) b := rfl
-
-@[simp] theorem foldlM_append [Monad m] [LawfulMonad m] (f : β → α → m β) (b) (l l' : List α) :
-    (l ++ l').foldlM f b = l.foldlM f b >>= l'.foldlM f := by
-  induction l generalizing b <;> simp [*]
-
-@[simp] theorem foldrM_cons [Monad m] [LawfulMonad m] (a : α) (l) (f : α → β → m β) (b) :
-    (a :: l).foldrM f b = l.foldrM f b >>= f a := by
-  simp only [foldrM]
-  induction l <;> simp_all
-
-theorem foldl_eq_foldlM (f : β → α → β) (b) (l : List α) :
-    l.foldl f b = l.foldlM (m := Id) f b := by
-  induction l generalizing b <;> simp [*, foldl]
-
-theorem foldr_eq_foldrM (f : α → β → β) (b) (l : List α) :
-    l.foldr f b = l.foldrM (m := Id) f b := by
-  induction l <;> simp [*, foldr]
-
-@[simp] theorem id_run_foldlM (f : β → α → Id β) (b) (l : List α) :
-    Id.run (l.foldlM f b) = l.foldl f b := (foldl_eq_foldlM f b l).symm
-
-@[simp] theorem id_run_foldrM (f : α → β → Id β) (b) (l : List α) :
-    Id.run (l.foldrM f b) = l.foldr f b := (foldr_eq_foldrM f b l).symm
-
-/-! ### foldl and foldr -/
-
-@[simp] theorem foldr_cons_eq_append (l : List α) : l.foldr cons l' = l ++ l' := by
-  induction l <;> simp [*]
-
-@[deprecated foldr_cons_eq_append (since := "2024-08-22")] abbrev foldr_self_append := @foldr_cons_eq_append
-
-@[simp] theorem foldl_flip_cons_eq_append (l : List α) : l.foldl (fun x y => y :: x) l' = l.reverse ++ l' := by
-  induction l generalizing l' <;> simp [*]
-
-theorem foldr_cons_nil (l : List α) : l.foldr cons [] = l := by simp
-
-@[deprecated foldr_cons_nil (since := "2024-09-04")] abbrev foldr_self := @foldr_cons_nil
-
-theorem foldl_map (f : β₁ → β₂) (g : α → β₂ → α) (l : List β₁) (init : α) :
-    (l.map f).foldl g init = l.foldl (fun x y => g x (f y)) init := by
-  induction l generalizing init <;> simp [*]
-
-theorem foldr_map (f : α₁ → α₂) (g : α₂ → β → β) (l : List α₁) (init : β) :
-    (l.map f).foldr g init = l.foldr (fun x y => g (f x) y) init := by
-  induction l generalizing init <;> simp [*]
-
-theorem foldl_filterMap (f : α → Option β) (g : γ → β → γ) (l : List α) (init : γ) :
-    (l.filterMap f).foldl g init = l.foldl (fun x y => match f y with | some b => g x b | none => x) init := by
-  induction l generalizing init with
-  | nil => rfl
-  | cons a l ih =>
-    simp only [filterMap_cons, foldl_cons]
-    cases f a <;> simp [ih]
-
-theorem foldr_filterMap (f : α → Option β) (g : β → γ → γ) (l : List α) (init : γ) :
-    (l.filterMap f).foldr g init = l.foldr (fun x y => match f x with | some b => g b y | none => y) init := by
-  induction l generalizing init with
-  | nil => rfl
-  | cons a l ih =>
-    simp only [filterMap_cons, foldr_cons]
-    cases f a <;> simp [ih]
-
-theorem foldl_map' (g : α → β) (f : α → α → α) (f' : β → β → β) (a : α) (l : List α)
-    (h : ∀ x y, f' (g x) (g y) = g (f x y)) :
-    (l.map g).foldl f' (g a) = g (l.foldl f a) := by
-  induction l generalizing a
-  · simp
-  · simp [*, h]
-
-theorem foldr_map' (g : α → β) (f : α → α → α) (f' : β → β → β) (a : α) (l : List α)
-    (h : ∀ x y, f' (g x) (g y) = g (f x y)) :
-    (l.map g).foldr f' (g a) = g (l.foldr f a) := by
-  induction l generalizing a
-  · simp
-  · simp [*, h]
-
-theorem foldl_assoc {op : α → α → α} [ha : Std.Associative op] :
-    ∀ {l : List α} {a₁ a₂}, l.foldl op (op a₁ a₂) = op a₁ (l.foldl op a₂)
-  | [], a₁, a₂ => rfl
-  | a :: l, a₁, a₂ => by
-    simp only [foldl_cons, ha.assoc]
-    rw [foldl_assoc]
-
-theorem foldr_assoc {op : α → α → α} [ha : Std.Associative op] :
-    ∀ {l : List α} {a₁ a₂}, l.foldr op (op a₁ a₂) = op (l.foldr op a₁) a₂
-  | [], a₁, a₂ => rfl
-  | a :: l, a₁, a₂ => by
-    simp only [foldr_cons, ha.assoc]
-    rw [foldr_assoc]
-
-theorem foldl_hom (f : α₁ → α₂) (g₁ : α₁ → β → α₁) (g₂ : α₂ → β → α₂) (l : List β) (init : α₁)
-    (H : ∀ x y, g₂ (f x) y = f (g₁ x y)) : l.foldl g₂ (f init) = f (l.foldl g₁ init) := by
-  induction l generalizing init <;> simp [*, H]
-
-theorem foldr_hom (f : β₁ → β₂) (g₁ : α → β₁ → β₁) (g₂ : α → β₂ → β₂) (l : List α) (init : β₁)
-    (H : ∀ x y, g₂ x (f y) = f (g₁ x y)) : l.foldr g₂ (f init) = f (l.foldr g₁ init) := by
-  induction l <;> simp [*, H]
-
-/--
-Prove a proposition about the result of `List.foldl`,
-by proving it for the initial data,
-and the implication that the operation applied to any element of the list preserves the property.
-
-The motive can take values in `Sort _`, so this may be used to construct data,
-as well as to prove propositions.
--/
-def foldlRecOn {motive : β → Sort _} : ∀ (l : List α) (op : β → α → β) (b : β) (_ : motive b)
-    (_ : ∀ (b : β) (_ : motive b) (a : α) (_ : a ∈ l), motive (op b a)), motive (List.foldl op b l)
-  | [], _, _, hb, _ => hb
-  | hd :: tl, op, b, hb, hl =>
-    foldlRecOn tl op (op b hd) (hl b hb hd (mem_cons_self hd tl))
-      fun y hy x hx => hl y hy x (mem_cons_of_mem hd hx)
-
-@[simp] theorem foldlRecOn_nil {motive : β → Sort _} (hb : motive b)
-    (hl : ∀ (b : β) (_ : motive b) (a : α) (_ : a ∈ []), motive (op b a)) :
-    foldlRecOn [] op b hb hl = hb := rfl
-
-@[simp] theorem foldlRecOn_cons {motive : β → Sort _} (hb : motive b)
-    (hl : ∀ (b : β) (_ : motive b) (a : α) (_ : a ∈ x :: l), motive (op b a)) :
-    foldlRecOn (x :: l) op b hb hl =
-      foldlRecOn l op (op b x) (hl b hb x (mem_cons_self x l))
-        (fun b c a m => hl b c a (mem_cons_of_mem x m)) :=
-  rfl
-
-/--
-Prove a proposition about the result of `List.foldr`,
-by proving it for the initial data,
-and the implication that the operation applied to any element of the list preserves the property.
-
-The motive can take values in `Sort _`, so this may be used to construct data,
-as well as to prove propositions.
--/
-def foldrRecOn {motive : β → Sort _} : ∀ (l : List α) (op : α → β → β) (b : β) (_ : motive b)
-    (_ : ∀ (b : β) (_ : motive b) (a : α) (_ : a ∈ l), motive (op a b)), motive (List.foldr op b l)
-  | nil, _, _, hb, _ => hb
-  | x :: l, op, b, hb, hl =>
-    hl (foldr op b l)
-      (foldrRecOn l op b hb fun b c a m => hl b c a (mem_cons_of_mem x m)) x (mem_cons_self x l)
-
-@[simp] theorem foldrRecOn_nil {motive : β → Sort _} (hb : motive b)
-    (hl : ∀ (b : β) (_ : motive b) (a : α) (_ : a ∈ []), motive (op a b)) :
-    foldrRecOn [] op b hb hl = hb := rfl
-
-@[simp] theorem foldrRecOn_cons {motive : β → Sort _} (hb : motive b)
-    (hl : ∀ (b : β) (_ : motive b) (a : α) (_ : a ∈ x :: l), motive (op a b)) :
-    foldrRecOn (x :: l) op b hb hl =
-      hl _ (foldrRecOn l op b hb fun b c a m => hl b c a (mem_cons_of_mem x m))
-        x (mem_cons_self x l) :=
-  rfl
-
-/--
-We can prove that two folds over the same list are related (by some arbitrary relation)
-if we know that the initial elements are related and the folding function, for each element of the list,
-preserves the relation.
--/
-theorem foldl_rel {l : List α} {f g : β → α → β} {a b : β} (r : β → β → Prop)
-    (h : r a b) (h' : ∀ (a : α), a ∈ l → ∀ (c c' : β), r c c' → r (f c a) (g c' a)) :
-    r (l.foldl (fun acc a => f acc a) a) (l.foldl (fun acc a => g acc a) b) := by
-  induction l generalizing a b with
-  | nil => simp_all
-  | cons a l ih =>
-    simp only [foldl_cons]
-    apply ih
-    · simp_all
-    · exact fun a m c c' h => h' _ (by simp_all) _ _ h
-
-/--
-We can prove that two folds over the same list are related (by some arbitrary relation)
-if we know that the initial elements are related and the folding function, for each element of the list,
-preserves the relation.
--/
-theorem foldr_rel {l : List α} {f g : α → β → β} {a b : β} (r : β → β → Prop)
-    (h : r a b) (h' : ∀ (a : α), a ∈ l → ∀ (c c' : β), r c c' → r (f a c) (g a c')) :
-    r (l.foldr (fun a acc => f a acc) a) (l.foldr (fun a acc => g a acc) b) := by
-  induction l generalizing a b with
-  | nil => simp_all
-  | cons a l ih =>
-    simp only [foldr_cons]
-    apply h'
-    · simp
-    · exact ih h fun a m c c' h => h' _ (by simp_all) _ _ h
-
-@[simp] theorem foldl_add_const (l : List α) (a b : Nat) :
-    l.foldl (fun x _ => x + a) b = b + a * l.length := by
-  induction l generalizing b with
-  | nil => simp
-  | cons y l ih =>
-    simp only [foldl_cons, ih, length_cons, Nat.mul_add, Nat.mul_one, Nat.add_assoc,
-      Nat.add_comm a]
-
-@[simp] theorem foldr_add_const (l : List α) (a b : Nat) :
-    l.foldr (fun _ x => x + a) b = b + a * l.length := by
-  induction l generalizing b with
-  | nil => simp
-  | cons y l ih =>
-    simp only [foldr_cons, ih, length_cons, Nat.mul_add, Nat.mul_one, Nat.add_assoc]
-
 /-! ### getLast -/
 
 theorem getLast_eq_getElem : ∀ (l : List α) (h : l ≠ []),
@@ -1216,27 +1015,6 @@ theorem getLast?_tail (l : List α) : (tail l).getLast? = if l.length = 1 then n
 
 /-! ### map -/
 
-@[simp] theorem map_id_fun : map (id : α → α) = id := by
-  funext l
-  induction l <;> simp_all
-
-/-- `map_id_fun'` differs from `map_id_fun` by representing the identity function as a lambda, rather than `id`. -/
-@[simp] theorem map_id_fun' : map (fun (a : α) => a) = id := map_id_fun
-
--- This is not a `@[simp]` lemma because `map_id_fun` will apply.
-theorem map_id (l : List α) : map (id : α → α) l = l := by
-  induction l <;> simp_all
-
-/-- `map_id'` differs from `map_id` by representing the identity function as a lambda, rather than `id`. -/
--- This is not a `@[simp]` lemma because `map_id_fun'` will apply.
-theorem map_id' (l : List α) : map (fun (a : α) => a) l = l := map_id l
-
-/-- Variant of `map_id`, with a side condition that the function is pointwise the identity. -/
-theorem map_id'' {f : α → α} (h : ∀ x, f x = x) (l : List α) : map f l = l := by
-  simp [show f = id from funext h]
-
-theorem map_singleton (f : α → β) (a : α) : map f [a] = [f a] := rfl
-
 @[simp] theorem length_map (as : List α) (f : α → β) : (as.map f).length = as.length := by
   induction as with
   | nil => simp [List.map]
@@ -1262,6 +1040,27 @@ theorem get_map (f : α → β) {l i} :
     get (map f l) i = f (get l ⟨i, length_map l f ▸ i.2⟩) := by
   simp
 
+@[simp] theorem map_id_fun : map (id : α → α) = id := by
+  funext l
+  induction l <;> simp_all
+
+/-- `map_id_fun'` differs from `map_id_fun` by representing the identity function as a lambda, rather than `id`. -/
+@[simp] theorem map_id_fun' : map (fun (a : α) => a) = id := map_id_fun
+
+-- This is not a `@[simp]` lemma because `map_id_fun` will apply.
+theorem map_id (l : List α) : map (id : α → α) l = l := by
+  induction l <;> simp_all
+
+/-- `map_id'` differs from `map_id` by representing the identity function as a lambda, rather than `id`. -/
+-- This is not a `@[simp]` lemma because `map_id_fun'` will apply.
+theorem map_id' (l : List α) : map (fun (a : α) => a) l = l := map_id l
+
+/-- Variant of `map_id`, with a side condition that the function is pointwise the identity. -/
+theorem map_id'' {f : α → α} (h : ∀ x, f x = x) (l : List α) : map f l = l := by
+  simp [show f = id from funext h]
+
+theorem map_singleton (f : α → β) (a : α) : map f [a] = [f a] := rfl
+
 @[simp] theorem mem_map {f : α → β} : ∀ {l : List α}, b ∈ l.map f ↔ ∃ a, a ∈ l ∧ f a = b
   | [] => by simp
   | _ :: l => by simp [mem_map (l := l), eq_comm (a := b)]
@@ -1961,16 +1760,6 @@ theorem set_append {s t : List α} :
     (s ++ t).set i x = s ++ t.set (i - s.length) x := by
   rw [set_append, if_neg (by simp_all)]
 
-@[simp] theorem foldrM_append [Monad m] [LawfulMonad m] (f : α → β → m β) (b) (l l' : List α) :
-    (l ++ l').foldrM f b = l'.foldrM f b >>= l.foldrM f := by
-  induction l <;> simp [*]
-
-@[simp] theorem foldl_append {β : Type _} (f : β → α → β) (b) (l l' : List α) :
-    (l ++ l').foldl f b = l'.foldl f (l.foldl f b) := by simp [foldl_eq_foldlM]
-
-@[simp] theorem foldr_append (f : α → β → β) (b) (l l' : List α) :
-    (l ++ l').foldr f b = l.foldr f (l'.foldr f b) := by simp [foldr_eq_foldrM]
-
 theorem filterMap_eq_append_iff {f : α → Option β} :
     filterMap f l = L₁ ++ L₂ ↔ ∃ l₁ l₂, l = l₁ ++ l₂ ∧ filterMap f l₁ = L₁ ∧ filterMap f l₂ = L₂ := by
   constructor
@@ -2119,14 +1908,6 @@ theorem head?_flatten {L : List (List α)} : (flatten L).head? = L.findSome? fun
 -- `getLast?_flatten` is proved later, after the `reverse` section.
 -- `head_flatten` and `getLast_flatten` are proved in `Init.Data.List.Find`.
 
-theorem foldl_flatten (f : β → α → β) (b : β) (L : List (List α)) :
-    (flatten L).foldl f b = L.foldl (fun b l => l.foldl f b) b := by
-  induction L generalizing b <;> simp_all
-
-theorem foldr_flatten (f : α → β → β) (b : β) (L : List (List α)) :
-    (flatten L).foldr f b = L.foldr (fun l b => l.foldr f b) b := by
-  induction L <;> simp_all
-
 @[simp] theorem map_flatten (f : α → β) (L : List (List α)) : map f (flatten L) = flatten (map (map f) L) := by
   induction L <;> simp_all
 
@@ -2699,10 +2480,114 @@ theorem flatMap_reverse {β} (l : List α) (f : α → List β) : (l.reverse.fla
 @[simp] theorem reverseAux_eq (as bs : List α) : reverseAux as bs = reverse as ++ bs :=
   reverseAux_eq_append ..
 
+@[simp] theorem reverse_replicate (n) (a : α) : reverse (replicate n a) = replicate n a :=
+  eq_replicate_iff.2
+    ⟨by rw [length_reverse, length_replicate],
+     fun _ h => eq_of_mem_replicate (mem_reverse.1 h)⟩
+
+
+/-! ### foldlM and foldrM -/
+
+@[simp] theorem foldlM_append [Monad m] [LawfulMonad m] (f : β → α → m β) (b) (l l' : List α) :
+    (l ++ l').foldlM f b = l.foldlM f b >>= l'.foldlM f := by
+  induction l generalizing b <;> simp [*]
+
+@[simp] theorem foldrM_cons [Monad m] [LawfulMonad m] (a : α) (l) (f : α → β → m β) (b) :
+    (a :: l).foldrM f b = l.foldrM f b >>= f a := by
+  simp only [foldrM]
+  induction l <;> simp_all
+
+theorem foldl_eq_foldlM (f : β → α → β) (b) (l : List α) :
+    l.foldl f b = l.foldlM (m := Id) f b := by
+  induction l generalizing b <;> simp [*, foldl]
+
+theorem foldr_eq_foldrM (f : α → β → β) (b) (l : List α) :
+    l.foldr f b = l.foldrM (m := Id) f b := by
+  induction l <;> simp [*, foldr]
+
+@[simp] theorem id_run_foldlM (f : β → α → Id β) (b) (l : List α) :
+    Id.run (l.foldlM f b) = l.foldl f b := (foldl_eq_foldlM f b l).symm
+
+@[simp] theorem id_run_foldrM (f : α → β → Id β) (b) (l : List α) :
+    Id.run (l.foldrM f b) = l.foldr f b := (foldr_eq_foldrM f b l).symm
+
+@[simp] theorem foldlM_reverse [Monad m] (l : List α) (f : β → α → m β) (b) :
+    l.reverse.foldlM f b = l.foldrM (fun x y => f y x) b := rfl
+
 @[simp] theorem foldrM_reverse [Monad m] (l : List α) (f : α → β → m β) (b) :
     l.reverse.foldrM f b = l.foldlM (fun x y => f y x) b :=
   (foldlM_reverse ..).symm.trans <| by simp
 
+/-! ### foldl and foldr -/
+
+@[simp] theorem foldr_cons_eq_append (l : List α) : l.foldr cons l' = l ++ l' := by
+  induction l <;> simp [*]
+
+@[deprecated foldr_cons_eq_append (since := "2024-08-22")] abbrev foldr_self_append := @foldr_cons_eq_append
+
+@[simp] theorem foldl_flip_cons_eq_append (l : List α) : l.foldl (fun x y => y :: x) l' = l.reverse ++ l' := by
+  induction l generalizing l' <;> simp [*]
+
+theorem foldr_cons_nil (l : List α) : l.foldr cons [] = l := by simp
+
+@[deprecated foldr_cons_nil (since := "2024-09-04")] abbrev foldr_self := @foldr_cons_nil
+
+theorem foldl_map (f : β₁ → β₂) (g : α → β₂ → α) (l : List β₁) (init : α) :
+    (l.map f).foldl g init = l.foldl (fun x y => g x (f y)) init := by
+  induction l generalizing init <;> simp [*]
+
+theorem foldr_map (f : α₁ → α₂) (g : α₂ → β → β) (l : List α₁) (init : β) :
+    (l.map f).foldr g init = l.foldr (fun x y => g (f x) y) init := by
+  induction l generalizing init <;> simp [*]
+
+theorem foldl_filterMap (f : α → Option β) (g : γ → β → γ) (l : List α) (init : γ) :
+    (l.filterMap f).foldl g init = l.foldl (fun x y => match f y with | some b => g x b | none => x) init := by
+  induction l generalizing init with
+  | nil => rfl
+  | cons a l ih =>
+    simp only [filterMap_cons, foldl_cons]
+    cases f a <;> simp [ih]
+
+theorem foldr_filterMap (f : α → Option β) (g : β → γ → γ) (l : List α) (init : γ) :
+    (l.filterMap f).foldr g init = l.foldr (fun x y => match f x with | some b => g b y | none => y) init := by
+  induction l generalizing init with
+  | nil => rfl
+  | cons a l ih =>
+    simp only [filterMap_cons, foldr_cons]
+    cases f a <;> simp [ih]
+
+theorem foldl_map' (g : α → β) (f : α → α → α) (f' : β → β → β) (a : α) (l : List α)
+    (h : ∀ x y, f' (g x) (g y) = g (f x y)) :
+    (l.map g).foldl f' (g a) = g (l.foldl f a) := by
+  induction l generalizing a
+  · simp
+  · simp [*, h]
+
+theorem foldr_map' (g : α → β) (f : α → α → α) (f' : β → β → β) (a : α) (l : List α)
+    (h : ∀ x y, f' (g x) (g y) = g (f x y)) :
+    (l.map g).foldr f' (g a) = g (l.foldr f a) := by
+  induction l generalizing a
+  · simp
+  · simp [*, h]
+
+@[simp] theorem foldrM_append [Monad m] [LawfulMonad m] (f : α → β → m β) (b) (l l' : List α) :
+    (l ++ l').foldrM f b = l'.foldrM f b >>= l.foldrM f := by
+  induction l <;> simp [*]
+
+@[simp] theorem foldl_append {β : Type _} (f : β → α → β) (b) (l l' : List α) :
+    (l ++ l').foldl f b = l'.foldl f (l.foldl f b) := by simp [foldl_eq_foldlM]
+
+@[simp] theorem foldr_append (f : α → β → β) (b) (l l' : List α) :
+    (l ++ l').foldr f b = l.foldr f (l'.foldr f b) := by simp [foldr_eq_foldrM]
+
+theorem foldl_flatten (f : β → α → β) (b : β) (L : List (List α)) :
+    (flatten L).foldl f b = L.foldl (fun b l => l.foldl f b) b := by
+  induction L generalizing b <;> simp_all
+
+theorem foldr_flatten (f : α → β → β) (b : β) (L : List (List α)) :
+    (flatten L).foldr f b = L.foldr (fun l b => l.foldr f b) b := by
+  induction L <;> simp_all
+
 @[simp] theorem foldl_reverse (l : List α) (f : β → α → β) (b) :
     l.reverse.foldl f b = l.foldr (fun x y => f y x) b := by simp [foldl_eq_foldlM, foldr_eq_foldrM]
 
@@ -2716,10 +2601,127 @@ theorem foldl_eq_foldr_reverse (l : List α) (f : β → α → β) (b) :
 theorem foldr_eq_foldl_reverse (l : List α) (f : α → β → β) (b) :
     l.foldr f b = l.reverse.foldl (fun x y => f y x) b := by simp
 
-@[simp] theorem reverse_replicate (n) (a : α) : reverse (replicate n a) = replicate n a :=
-  eq_replicate_iff.2
-    ⟨by rw [length_reverse, length_replicate],
-     fun _ h => eq_of_mem_replicate (mem_reverse.1 h)⟩
+theorem foldl_assoc {op : α → α → α} [ha : Std.Associative op] :
+    ∀ {l : List α} {a₁ a₂}, l.foldl op (op a₁ a₂) = op a₁ (l.foldl op a₂)
+  | [], a₁, a₂ => rfl
+  | a :: l, a₁, a₂ => by
+    simp only [foldl_cons, ha.assoc]
+    rw [foldl_assoc]
+
+theorem foldr_assoc {op : α → α → α} [ha : Std.Associative op] :
+    ∀ {l : List α} {a₁ a₂}, l.foldr op (op a₁ a₂) = op (l.foldr op a₁) a₂
+  | [], a₁, a₂ => rfl
+  | a :: l, a₁, a₂ => by
+    simp only [foldr_cons, ha.assoc]
+    rw [foldr_assoc]
+
+theorem foldl_hom (f : α₁ → α₂) (g₁ : α₁ → β → α₁) (g₂ : α₂ → β → α₂) (l : List β) (init : α₁)
+    (H : ∀ x y, g₂ (f x) y = f (g₁ x y)) : l.foldl g₂ (f init) = f (l.foldl g₁ init) := by
+  induction l generalizing init <;> simp [*, H]
+
+theorem foldr_hom (f : β₁ → β₂) (g₁ : α → β₁ → β₁) (g₂ : α → β₂ → β₂) (l : List α) (init : β₁)
+    (H : ∀ x y, g₂ x (f y) = f (g₁ x y)) : l.foldr g₂ (f init) = f (l.foldr g₁ init) := by
+  induction l <;> simp [*, H]
+
+/--
+Prove a proposition about the result of `List.foldl`,
+by proving it for the initial data,
+and the implication that the operation applied to any element of the list preserves the property.
+
+The motive can take values in `Sort _`, so this may be used to construct data,
+as well as to prove propositions.
+-/
+def foldlRecOn {motive : β → Sort _} : ∀ (l : List α) (op : β → α → β) (b : β) (_ : motive b)
+    (_ : ∀ (b : β) (_ : motive b) (a : α) (_ : a ∈ l), motive (op b a)), motive (List.foldl op b l)
+  | [], _, _, hb, _ => hb
+  | hd :: tl, op, b, hb, hl =>
+    foldlRecOn tl op (op b hd) (hl b hb hd (mem_cons_self hd tl))
+      fun y hy x hx => hl y hy x (mem_cons_of_mem hd hx)
+
+@[simp] theorem foldlRecOn_nil {motive : β → Sort _} (hb : motive b)
+    (hl : ∀ (b : β) (_ : motive b) (a : α) (_ : a ∈ []), motive (op b a)) :
+    foldlRecOn [] op b hb hl = hb := rfl
+
+@[simp] theorem foldlRecOn_cons {motive : β → Sort _} (hb : motive b)
+    (hl : ∀ (b : β) (_ : motive b) (a : α) (_ : a ∈ x :: l), motive (op b a)) :
+    foldlRecOn (x :: l) op b hb hl =
+      foldlRecOn l op (op b x) (hl b hb x (mem_cons_self x l))
+        (fun b c a m => hl b c a (mem_cons_of_mem x m)) :=
+  rfl
+
+/--
+Prove a proposition about the result of `List.foldr`,
+by proving it for the initial data,
+and the implication that the operation applied to any element of the list preserves the property.
+
+The motive can take values in `Sort _`, so this may be used to construct data,
+as well as to prove propositions.
+-/
+def foldrRecOn {motive : β → Sort _} : ∀ (l : List α) (op : α → β → β) (b : β) (_ : motive b)
+    (_ : ∀ (b : β) (_ : motive b) (a : α) (_ : a ∈ l), motive (op a b)), motive (List.foldr op b l)
+  | nil, _, _, hb, _ => hb
+  | x :: l, op, b, hb, hl =>
+    hl (foldr op b l)
+      (foldrRecOn l op b hb fun b c a m => hl b c a (mem_cons_of_mem x m)) x (mem_cons_self x l)
+
+@[simp] theorem foldrRecOn_nil {motive : β → Sort _} (hb : motive b)
+    (hl : ∀ (b : β) (_ : motive b) (a : α) (_ : a ∈ []), motive (op a b)) :
+    foldrRecOn [] op b hb hl = hb := rfl
+
+@[simp] theorem foldrRecOn_cons {motive : β → Sort _} (hb : motive b)
+    (hl : ∀ (b : β) (_ : motive b) (a : α) (_ : a ∈ x :: l), motive (op a b)) :
+    foldrRecOn (x :: l) op b hb hl =
+      hl _ (foldrRecOn l op b hb fun b c a m => hl b c a (mem_cons_of_mem x m))
+        x (mem_cons_self x l) :=
+  rfl
+
+/--
+We can prove that two folds over the same list are related (by some arbitrary relation)
+if we know that the initial elements are related and the folding function, for each element of the list,
+preserves the relation.
+-/
+theorem foldl_rel {l : List α} {f g : β → α → β} {a b : β} (r : β → β → Prop)
+    (h : r a b) (h' : ∀ (a : α), a ∈ l → ∀ (c c' : β), r c c' → r (f c a) (g c' a)) :
+    r (l.foldl (fun acc a => f acc a) a) (l.foldl (fun acc a => g acc a) b) := by
+  induction l generalizing a b with
+  | nil => simp_all
+  | cons a l ih =>
+    simp only [foldl_cons]
+    apply ih
+    · simp_all
+    · exact fun a m c c' h => h' _ (by simp_all) _ _ h
+
+/--
+We can prove that two folds over the same list are related (by some arbitrary relation)
+if we know that the initial elements are related and the folding function, for each element of the list,
+preserves the relation.
+-/
+theorem foldr_rel {l : List α} {f g : α → β → β} {a b : β} (r : β → β → Prop)
+    (h : r a b) (h' : ∀ (a : α), a ∈ l → ∀ (c c' : β), r c c' → r (f a c) (g a c')) :
+    r (l.foldr (fun a acc => f a acc) a) (l.foldr (fun a acc => g a acc) b) := by
+  induction l generalizing a b with
+  | nil => simp_all
+  | cons a l ih =>
+    simp only [foldr_cons]
+    apply h'
+    · simp
+    · exact ih h fun a m c c' h => h' _ (by simp_all) _ _ h
+
+@[simp] theorem foldl_add_const (l : List α) (a b : Nat) :
+    l.foldl (fun x _ => x + a) b = b + a * l.length := by
+  induction l generalizing b with
+  | nil => simp
+  | cons y l ih =>
+    simp only [foldl_cons, ih, length_cons, Nat.mul_add, Nat.mul_one, Nat.add_assoc,
+      Nat.add_comm a]
+
+@[simp] theorem foldr_add_const (l : List α) (a b : Nat) :
+    l.foldr (fun _ x => x + a) b = b + a * l.length := by
+  induction l generalizing b with
+  | nil => simp
+  | cons y l ih =>
+    simp only [foldr_cons, ih, length_cons, Nat.mul_add, Nat.mul_one, Nat.add_assoc]
+
 
 /-! #### Further results about `getLast` and `getLast?` -/
 

src/Init/Data/List/Lex.lean

@@ -14,8 +14,8 @@ namespace List
 @[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
 
-theorem not_lt_iff_ge [LT α] (l₁ l₂ : List α) : ¬ l₁ < l₂ ↔ l₂ ≤ l₁ := Iff.rfl
-theorem not_le_iff_gt [DecidableEq α] [LT α] [DecidableLT α] (l₁ l₂ : List α) :
+protected theorem not_lt_iff_ge [LT α] (l₁ l₂ : List α) : ¬ l₁ < l₂ ↔ l₂ ≤ l₁ := Iff.rfl
+protected theorem not_le_iff_gt [DecidableEq α] [LT α] [DecidableLT α] (l₁ l₂ : List α) :
     ¬ l₁ ≤ l₂ ↔ l₂ < l₁ :=
   Decidable.not_not
 
@@ -260,7 +260,7 @@ protected theorem le_of_lt [DecidableEq α] [LT α] [DecidableLT α]
   · exfalso
     exact h' h
 
-theorem le_iff_lt_or_eq [DecidableEq α] [LT α] [DecidableLT α]
+protected theorem le_iff_lt_or_eq [DecidableEq α] [LT α] [DecidableLT α]
     [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)]
     [Std.Total (¬ · < · : α → α → Prop)]
@@ -333,7 +333,7 @@ theorem lex_eq_true_iff_exists [BEq α] (lt : α → α → Bool) :
     cases l₂ with
     | nil => simp [lex]
     | cons b l₂ =>
-      simp only [lex_cons_cons, Bool.or_eq_true, Bool.and_eq_true, ih, isEqv, length_cons]
+      simp [lex_cons_cons, Bool.or_eq_true, Bool.and_eq_true, ih, isEqv, length_cons]
       constructor
       · rintro (hab | ⟨hab, ⟨h₁, h₂⟩ | ⟨i, h₁, h₂, w₁, w₂⟩⟩)
         · exact .inr ⟨0, by simp [hab]⟩
@@ -397,7 +397,7 @@ theorem lex_eq_false_iff_exists [BEq α] [PartialEquivBEq α] (lt : α → α
     cases l₂ with
     | nil => simp [lex]
     | cons b l₂ =>
-      simp only [lex_cons_cons, Bool.or_eq_false_iff, Bool.and_eq_false_imp, ih, isEqv,
+      simp [lex_cons_cons, Bool.or_eq_false_iff, Bool.and_eq_false_imp, ih, isEqv,
         Bool.and_eq_true, length_cons]
       constructor
       · rintro ⟨hab, h⟩
@@ -435,7 +435,7 @@ theorem lex_eq_false_iff_exists [BEq α] [PartialEquivBEq α] (lt : α → α
               simpa using w₁ (j + 1) (by simpa)
             · simpa using w₂
 
-theorem lt_iff_exists [DecidableEq α] [LT α] [DecidableLT α] {l₁ l₂ : List α} :
+protected theorem lt_iff_exists [DecidableEq α] [LT α] [DecidableLT α] {l₁ l₂ : List α} :
     l₁ < l₂ ↔
       (l₁ = l₂.take l₁.length ∧ l₁.length < l₂.length) ∨
         (∃ (i : Nat) (h₁ : i < l₁.length) (h₂ : i < l₂.length),
@@ -444,7 +444,7 @@ theorem lt_iff_exists [DecidableEq α] [LT α] [DecidableLT α] {l₁ l₂ : Lis
   rw [← lex_eq_true_iff_lt, lex_eq_true_iff_exists]
   simp
 
-theorem le_iff_exists [DecidableEq α] [LT α] [DecidableLT α]
+protected theorem le_iff_exists [DecidableEq α] [LT α] [DecidableLT α]
     [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Asymm (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)] {l₁ l₂ : List α} :
@@ -489,7 +489,7 @@ theorem IsPrefix.le [LT α] [Std.Irrefl (· < · : α → α → Prop)]
   rcases h with ⟨_, rfl⟩
   apply le_append_left
 
-theorem map_lt [LT α] [LT β]
+protected theorem map_lt [LT α] [LT β]
     {l₁ l₂ : List α} {f : α → β} (w : ∀ x y, x < y → f x < f y) (h : l₁ < l₂) :
     map f l₁ < map f l₂ := by
   match l₁, l₂, h with
@@ -497,11 +497,11 @@ theorem map_lt [LT α] [LT β]
   | nil, cons b l₂, h => simp
   | cons a l₁, nil, h => simp at h
   | cons a l₁, cons _ l₂, .cons h =>
-    simp [cons_lt_cons_iff, map_lt w (by simpa using h)]
+    simp [cons_lt_cons_iff, List.map_lt w (by simpa using h)]
   | cons a l₁, cons b l₂, .rel h =>
     simp [cons_lt_cons_iff, w, h]
 
-theorem map_le [DecidableEq α] [LT α] [DecidableLT α] [DecidableEq β] [LT β] [DecidableLT β]
+protected theorem map_le [DecidableEq α] [LT α] [DecidableLT α] [DecidableEq β] [LT β] [DecidableLT β]
     [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Asymm (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)]
@@ -510,7 +510,7 @@ theorem map_le [DecidableEq α] [LT α] [DecidableLT α] [DecidableEq β] [LT β
     [Std.Antisymm (¬ · < · : β → β → Prop)]
     {l₁ l₂ : List α} {f : α → β} (w : ∀ x y, x < y → f x < f y) (h : l₁ ≤ l₂) :
     map f l₁ ≤ map f l₂ := by
-  rw [le_iff_exists] at h ⊢
+  rw [List.le_iff_exists] at h ⊢
   obtain (h | ⟨i, h₁, h₂, w₁, w₂⟩) := h
   · left
     rw [h]

src/Init/Data/List/Perm.lean

@@ -510,4 +510,18 @@ theorem Perm.eraseP (f : α → Bool) {l₁ l₂ : List α}
     refine (IH₁ H).trans (IH₂ ((p₁.pairwise_iff ?_).1 H))
     exact fun h h₁ h₂ => h h₂ h₁
 
+theorem perm_insertIdx {α} (x : α) (l : List α) {n} (h : n ≤ l.length) :
+    insertIdx n x l ~ x :: l := by
+  induction l generalizing n with
+  | nil =>
+    cases n with
+    | zero => rfl
+    | succ => cases h
+  | cons _ _ ih =>
+    cases n with
+    | zero => simp [insertIdx]
+    | succ =>
+      simp only [insertIdx, modifyTailIdx]
+      refine .trans (.cons _ (ih (Nat.le_of_succ_le_succ h))) (.swap ..)
+
 end List

src/Init/Data/List/Sort/Lemmas.lean

@@ -253,6 +253,10 @@ theorem merge_perm_append : ∀ {xs ys : List α}, merge xs ys le ~ xs ++ ys
     · exact (merge_perm_append.cons y).trans
         ((Perm.swap x y _).trans (perm_middle.symm.cons x))
 
+theorem Perm.merge (s₁ s₂ : α → α → Bool) (hl : l₁ ~ l₂) (hr : r₁ ~ r₂) :
+    merge l₁ r₁ s₁ ~ merge l₂ r₂ s₂ :=
+  Perm.trans (merge_perm_append ..) <| Perm.trans (Perm.append hl hr) <| Perm.symm (merge_perm_append ..)
+
 /-! ### mergeSort -/
 
 @[simp] theorem mergeSort_nil : [].mergeSort r = [] := by rw [List.mergeSort]

src/Init/Data/List/Zip.lean

@@ -259,7 +259,7 @@ theorem zip_map (f : α → γ) (g : β → δ) :
   | [], _ => rfl
   | _, [] => by simp only [map, zip_nil_right]
   | _ :: _, _ :: _ => by
-    simp only [map, zip_cons_cons, zip_map, Prod.map]; constructor
+    simp only [map, zip_cons_cons, zip_map, Prod.map]; try constructor -- TODO: remove try constructor after update stage0
 
 theorem zip_map_left (f : α → γ) (l₁ : List α) (l₂ : List β) :
     zip (l₁.map f) l₂ = (zip l₁ l₂).map (Prod.map f id) := by rw [← zip_map, map_id]

src/Init/Data/Vector/Basic.lean

@@ -136,6 +136,18 @@ This will perform the update destructively provided that the vector has a refere
 @[inline] def set! (v : Vector α n) (i : Nat) (x : α) : Vector α n :=
   ⟨v.toArray.set! i x, by simp⟩
 
+@[inline] def foldlM [Monad m] (f : β → α → m β) (b : β) (v : Vector α n) : m β :=
+  v.toArray.foldlM f b
+
+@[inline] def foldrM [Monad m] (f : α → β → m β) (b : β) (v : Vector α n) : m β :=
+  v.toArray.foldrM f b
+
+@[inline] def foldl (f : β → α → β) (b : β) (v : Vector α n) : β :=
+  v.toArray.foldl f b
+
+@[inline] def foldr (f : α → β → β) (b : β) (v : Vector α n) : β :=
+  v.toArray.foldr f b
+
 /-- Append two vectors. -/
 @[inline] def append (v : Vector α n) (w : Vector α m) : Vector α (n + m) :=
   ⟨v.toArray ++ w.toArray, by simp⟩

src/Init/Data/Vector/Lemmas.lean

@@ -66,6 +66,18 @@ theorem toArray_mk (a : Array α) (h : a.size = n) : (Vector.mk a h).toArray = a
 @[simp] theorem back?_mk (a : Array α) (h : a.size = n) :
     (Vector.mk a h).back? = a.back? := rfl
 
+@[simp] theorem foldlM_mk [Monad m] (f : β → α → m β) (b : β) (a : Array α) (h : a.size = n) :
+    (Vector.mk a h).foldlM f b = a.foldlM f b := rfl
+
+@[simp] theorem foldrM_mk [Monad m] (f : α → β → m β) (b : β) (a : Array α) (h : a.size = n) :
+    (Vector.mk a h).foldrM f b = a.foldrM f b := rfl
+
+@[simp] theorem foldl_mk (f : β → α → β) (b : β) (a : Array α) (h : a.size = n) :
+    (Vector.mk a h).foldl f b = a.foldl f b := rfl
+
+@[simp] theorem foldr_mk (f : α → β → β) (b : β) (a : Array α) (h : a.size = n) :
+    (Vector.mk a h).foldr f b = a.foldr f b := rfl
+
 @[simp] theorem drop_mk (a : Array α) (h : a.size = n) (m) :
     (Vector.mk a h).drop m = Vector.mk (a.extract m a.size) (by simp [h]) := rfl
 
@@ -1025,6 +1037,13 @@ theorem mem_setIfInBounds (v : Vector α n) (i : Nat) (hi : i < n) (a : α) :
 
 /-! Content below this point has not yet been aligned with `List` and `Array`. -/
 
+/-! ### map -/
+
+@[simp] theorem getElem_map (f : α → β) (a : Vector α n) (i : Nat) (hi : i < n) :
+    (a.map f)[i] = f a[i] := by
+  cases a
+  simp
+
 @[simp] theorem getElem_ofFn {α n} (f : Fin n → α) (i : Nat) (h : i < n) :
     (Vector.ofFn f)[i] = f ⟨i, by simpa using h⟩ := by
   simp [ofFn]
@@ -1088,13 +1107,6 @@ theorem getElem_append_right {a : Vector α n} {b : Vector α m} {i : Nat} (h :
   cases a
   simp
 
-/-! ### map -/
-
-@[simp] theorem getElem_map (f : α → β) (a : Vector α n) (i : Nat) (hi : i < n) :
-    (a.map f)[i] = f a[i] := by
-  cases a
-  simp
-
 /-! ### zipWith -/
 
 @[simp] theorem getElem_zipWith (f : α → β → γ) (a : Vector α n) (b : Vector β n) (i : Nat)
@@ -1103,6 +1115,37 @@ theorem getElem_append_right {a : Vector α n} {b : Vector α m} {i : Nat} (h :
   cases b
   simp
 
+/-! ### foldlM and foldrM -/
+
+@[simp] theorem foldlM_append [Monad m] [LawfulMonad m] (f : β → α → m β) (b) (l : Vector α n) (l' : Vector α n') :
+    (l ++ l').foldlM f b = l.foldlM f b >>= l'.foldlM f := by
+  cases l
+  cases l'
+  simp
+
+@[simp] theorem foldrM_push [Monad m] (f : α → β → m β) (init : β) (l : Vector α n) (a : α) :
+    (l.push a).foldrM f init = f a init >>= l.foldrM f := by
+  cases l
+  simp
+
+theorem foldl_eq_foldlM (f : β → α → β) (b) (l : Vector α n) :
+    l.foldl f b = l.foldlM (m := Id) f b := by
+  cases l
+  simp [Array.foldl_eq_foldlM]
+
+theorem foldr_eq_foldrM (f : α → β → β) (b) (l : Vector α n) :
+    l.foldr f b = l.foldrM (m := Id) f b := by
+  cases l
+  simp [Array.foldr_eq_foldrM]
+
+@[simp] theorem id_run_foldlM (f : β → α → Id β) (b) (l : Vector α n) :
+    Id.run (l.foldlM f b) = l.foldl f b := (foldl_eq_foldlM f b l).symm
+
+@[simp] theorem id_run_foldrM (f : α → β → Id β) (b) (l : Vector α n) :
+    Id.run (l.foldrM f b) = l.foldr f b := (foldr_eq_foldrM f b l).symm
+
+/-! ### foldl and foldr -/
+
 /-! ### take -/
 
 @[simp] theorem take_size (a : Vector α n) : a.take n = a.cast (by simp) := by

src/Init/Data/Vector/Lex.lean

@@ -19,6 +19,11 @@ namespace Vector
 @[simp] theorem lt_toList [LT α] (l₁ l₂ : Vector α n) : l₁.toList < l₂.toList ↔ l₁ < l₂ := Iff.rfl
 @[simp] theorem le_toList [LT α] (l₁ l₂ : Vector α n) : l₁.toList ≤ l₂.toList ↔ l₁ ≤ l₂ := Iff.rfl
 
+protected theorem not_lt_iff_ge [LT α] (l₁ l₂ : Vector α n) : ¬ l₁ < l₂ ↔ l₂ ≤ l₁ := Iff.rfl
+protected theorem not_le_iff_gt [DecidableEq α] [LT α] [DecidableLT α] (l₁ l₂ : Vector α n) :
+    ¬ l₁ ≤ l₂ ↔ l₂ < l₁ :=
+  Decidable.not_not
+
 @[simp] theorem mk_lt_mk [LT α] :
     Vector.mk (α := α) (n := n) data₁ size₁ < Vector.mk data₂ size₂ ↔ data₁ < data₂ := Iff.rfl
 
@@ -133,7 +138,7 @@ protected theorem le_of_lt [DecidableEq α] [LT α] [DecidableLT α]
     {l₁ l₂ : Vector α n} (h : l₁ < l₂) : l₁ ≤ l₂ :=
   Array.le_of_lt h
 
-theorem le_iff_lt_or_eq [DecidableEq α] [LT α] [DecidableLT α]
+protected theorem le_iff_lt_or_eq [DecidableEq α] [LT α] [DecidableLT α]
     [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)]
     [Std.Total (¬ · < · : α → α → Prop)]
@@ -200,14 +205,14 @@ theorem lex_eq_false_iff_exists [BEq α] [PartialEquivBEq α] (lt : α → α
   rcases l₂ with ⟨l₂, n₂⟩
   simp_all [Array.lex_eq_false_iff_exists, n₂]
 
-theorem lt_iff_exists [DecidableEq α] [LT α] [DecidableLT α] {l₁ l₂ : Vector α n} :
+protected theorem lt_iff_exists [DecidableEq α] [LT α] [DecidableLT α] {l₁ l₂ : Vector α n} :
     l₁ < l₂ ↔
       (∃ (i : Nat) (h : i < n), (∀ j, (hj : j < i) → l₁[j] = l₂[j]) ∧ l₁[i] < l₂[i]) := by
   cases l₁
   cases l₂
   simp_all [Array.lt_iff_exists]
 
-theorem le_iff_exists [DecidableEq α] [LT α] [DecidableLT α]
+protected theorem le_iff_exists [DecidableEq α] [LT α] [DecidableLT α]
     [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Asymm (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)] {l₁ l₂ : Vector α n} :
@@ -230,12 +235,12 @@ theorem append_left_le [DecidableEq α] [LT α] [DecidableLT α]
     l₁ ++ l₂ ≤ l₁ ++ l₃ := by
   simpa using Array.append_left_le h
 
-theorem map_lt [LT α] [LT β]
+protected theorem map_lt [LT α] [LT β]
     {l₁ l₂ : Vector α n} {f : α → β} (w : ∀ x y, x < y → f x < f y) (h : l₁ < l₂) :
     map f l₁ < map f l₂ := by
   simpa using Array.map_lt w h
 
-theorem map_le [DecidableEq α] [LT α] [DecidableLT α] [DecidableEq β] [LT β] [DecidableLT β]
+protected theorem map_le [DecidableEq α] [LT α] [DecidableLT α] [DecidableEq β] [LT β] [DecidableLT β]
     [Std.Irrefl (· < · : α → α → Prop)]
     [Std.Asymm (· < · : α → α → Prop)]
     [Std.Antisymm (¬ · < · : α → α → Prop)]

src/Init/Grind.lean

@@ -8,3 +8,5 @@ import Init.Grind.Norm
 import Init.Grind.Tactics
 import Init.Grind.Lemmas
 import Init.Grind.Cases
+import Init.Grind.Propagator
+import Init.Grind.Util

src/Init/Grind/Lemmas.lean

@@ -5,10 +5,65 @@ Authors: Leonardo de Moura
 -/
 prelude
 import Init.Core
+import Init.SimpLemmas
+import Init.Classical
+import Init.ByCases
+import Init.Grind.Util
 
 namespace Lean.Grind
 
 theorem intro_with_eq (p p' q : Prop) (he : p = p') (h : p' → q) : p → q :=
   fun hp => h (he.mp hp)
 
+/-! And -/
+
+theorem and_eq_of_eq_true_left {a b : Prop} (h : a = True) : (a ∧ b) = b := by simp [h]
+theorem and_eq_of_eq_true_right {a b : Prop} (h : b = True) : (a ∧ b) = a := by simp [h]
+theorem and_eq_of_eq_false_left {a b : Prop} (h : a = False) : (a ∧ b) = False := by simp [h]
+theorem and_eq_of_eq_false_right {a b : Prop} (h : b = False) : (a ∧ b) = False := by simp [h]
+
+theorem eq_true_of_and_eq_true_left {a b : Prop} (h : (a ∧ b) = True) : a = True := by simp_all
+theorem eq_true_of_and_eq_true_right {a b : Prop} (h : (a ∧ b) = True) : b = True := by simp_all
+
+/-! Or -/
+
+theorem or_eq_of_eq_true_left {a b : Prop} (h : a = True) : (a ∨ b) = True := by simp [h]
+theorem or_eq_of_eq_true_right {a b : Prop} (h : b = True) : (a ∨ b) = True := by simp [h]
+theorem or_eq_of_eq_false_left {a b : Prop} (h : a = False) : (a ∨ b) = b := by simp [h]
+theorem or_eq_of_eq_false_right {a b : Prop} (h : b = False) : (a ∨ b) = a := by simp [h]
+
+theorem eq_false_of_or_eq_false_left {a b : Prop} (h : (a ∨ b) = False) : a = False := by simp_all
+theorem eq_false_of_or_eq_false_right {a b : Prop} (h : (a ∨ b) = False) : b = False := by simp_all
+
+/-! Not -/
+
+theorem not_eq_of_eq_true {a : Prop} (h : a = True) : (Not a) = False := by simp [h]
+theorem not_eq_of_eq_false {a : Prop} (h : a = False) : (Not a) = True := by simp [h]
+
+theorem eq_false_of_not_eq_true {a : Prop} (h : (Not a) = True) : a = False := by simp_all
+theorem eq_true_of_not_eq_false {a : Prop} (h : (Not a) = False) : a = True := by simp_all
+
+theorem false_of_not_eq_self {a : Prop} (h : (Not a) = a) : False := by
+  by_cases a <;> simp_all
+
+/-! Eq -/
+
+theorem eq_eq_of_eq_true_left {a b : Prop} (h : a = True) : (a = b) = b := by simp [h]
+theorem eq_eq_of_eq_true_right {a b : Prop} (h : b = True) : (a = b) = a := by simp [h]
+
+theorem eq_congr  {α : Sort u} {a₁ b₁ a₂ b₂ : α} (h₁ : a₁ = a₂) (h₂ : b₁ = b₂) : (a₁ = b₁) = (a₂ = b₂) := by simp [*]
+theorem eq_congr' {α : Sort u} {a₁ b₁ a₂ b₂ : α} (h₁ : a₁ = b₂) (h₂ : b₁ = a₂) : (a₁ = b₁) = (a₂ = b₂) := by rw [h₁, h₂, Eq.comm (a := a₂)]
+
+/-! Forall -/
+
+theorem forall_propagator (p : Prop) (q : p → Prop) (q' : Prop) (h₁ : p = True) (h₂ : q (of_eq_true h₁) = q') : (∀ hp : p, q hp) = q' := by
+  apply propext; apply Iff.intro
+  · intro h'; exact Eq.mp h₂ (h' (of_eq_true h₁))
+  · intro h'; intros; exact Eq.mpr h₂ h'
+
+/-! dite -/
+
+theorem dite_cond_eq_true' {α : Sort u} {c : Prop} {_ : Decidable c} {a : c → α} {b : ¬ c → α} {r : α} (h₁ : c = True) (h₂ : a (of_eq_true h₁) = r) : (dite c a b) = r := by simp [h₁, h₂]
+theorem dite_cond_eq_false' {α : Sort u} {c : Prop} {_ : Decidable c} {a : c → α} {b : ¬ c → α} {r : α} (h₁ : c = False) (h₂ : b (of_eq_false h₁) = r) : (dite c a b) = r := by simp [h₁, h₂]
+
 end Lean.Grind

src/Init/Grind/Norm.lean

@@ -5,6 +5,7 @@ Authors: Leonardo de Moura
 -/
 prelude
 import Init.SimpLemmas
+import Init.PropLemmas
 import Init.Classical
 import Init.ByCases
 
@@ -41,7 +42,7 @@ attribute [grind_norm] not_true
 attribute [grind_norm] not_false_eq_true
 
 -- Implication as a clause
-@[grind_norm] theorem imp_eq (p q : Prop) : (p → q) = (¬ p ∨ q) := by
+@[grind_norm↓] theorem imp_eq (p q : Prop) : (p → q) = (¬ p ∨ q) := by
   by_cases p <;> by_cases q <;> simp [*]
 
 -- And
@@ -58,13 +59,19 @@ attribute [grind_norm] ite_true ite_false
 @[grind_norm↓] theorem not_ite {_ : Decidable p} (q r : Prop) : (¬ite p q r) = ite p (¬q) (¬r) := by
   by_cases p <;> simp [*]
 
+@[grind_norm] theorem ite_true_false {_ : Decidable p} : (ite p True False) = p := by
+  by_cases p <;> simp
+
+@[grind_norm] theorem ite_false_true {_ : Decidable p} : (ite p False True) = ¬p := by
+  by_cases p <;> simp
+
 -- Forall
 @[grind_norm↓] theorem not_forall (p : α → Prop) : (¬∀ x, p x) = ∃ x, ¬p x := by simp
 attribute [grind_norm] forall_and
 
 -- Exists
 @[grind_norm↓] theorem not_exists (p : α → Prop) : (¬∃ x, p x) = ∀ x, ¬p x := by simp
-attribute [grind_norm] exists_const exists_or
+attribute [grind_norm] exists_const exists_or exists_prop exists_and_left exists_and_right
 
 -- Bool cond
 @[grind_norm] theorem cond_eq_ite (c : Bool) (a b : α) : cond c a b = ite c a b := by
@@ -107,4 +114,7 @@ attribute [grind_norm] Nat.le_zero_eq
 -- GT GE
 attribute [grind_norm] GT.gt GE.ge
 
+-- Succ
+attribute [grind_norm] Nat.succ_eq_add_one
+
 end Lean.Grind

src/Init/Grind/Propagator.lean

@@ -0,0 +1,27 @@
+/-
+Copyright (c) 2024 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
+-/
+prelude
+import Init.NotationExtra
+
+namespace Lean.Parser
+
+/-- A user-defined propagator for the `grind` tactic. -/
+-- TODO: not implemented yet
+syntax (docComment)? "grind_propagator " (Tactic.simpPre <|> Tactic.simpPost) ident " (" ident ")" " := " term : command
+
+/-- A builtin propagator for the `grind` tactic. -/
+syntax (docComment)? "builtin_grind_propagator " ident (Tactic.simpPre <|> Tactic.simpPost) ident " := " term : command
+
+/-- Auxiliary attribute for builtin `grind` propagators. -/
+syntax (name := grindPropagatorBuiltinAttr) "builtin_grind_propagator" (Tactic.simpPre <|> Tactic.simpPost) ident : attr
+
+macro_rules
+  | `($[$doc?:docComment]? builtin_grind_propagator $propagatorName:ident $direction $op:ident := $body) => do
+    let propagatorType := `Lean.Meta.Grind.Propagator
+    `($[$doc?:docComment]? def $propagatorName:ident : $(mkIdent propagatorType) := $body
+      attribute [builtin_grind_propagator $direction $op] $propagatorName)
+
+end Lean.Parser

src/Init/Grind/Tactics.lean

@@ -6,20 +6,53 @@ Authors: Leonardo de Moura
 prelude
 import Init.Tactics
 
+namespace Lean.Parser.Attr
+
+syntax grindEq     := "="
+syntax grindEqBoth := "_=_"
+syntax grindEqRhs  := "=_"
+syntax grindBwd    := "←"
+syntax grindFwd    := "→"
+
+syntax (name := grind) "grind" (grindEq <|> grindBwd <|> grindFwd <|> grindEqBoth <|> grindEqRhs)? : attr
+
+end Lean.Parser.Attr
+
 namespace Lean.Grind
 /--
 The configuration for `grind`.
 Passed to `grind` using, for example, the `grind (config := { eager := true })` syntax.
 -/
 structure Config where
-  /--
-  When `eager` is true (default: `false`), `grind` eagerly splits `if-then-else` and `match`
-  expressions.
-  -/
+  /-- When `eager` is true (default: `false`), `grind` eagerly splits `if-then-else` and `match` expressions during internalization. -/
   eager : Bool := false
+  /-- Maximum number of branches (i.e., case-splits) in the proof search tree. -/
+  splits : Nat := 100
+  /--
+  Maximum number of E-matching (aka heuristic theorem instantiation)
+  in a proof search tree branch.
+  -/
+  ematch : Nat := 5
+  /--
+  Maximum term generation.
+  The input goal terms have generation 0. When we instantiate a theorem using a term from generation `n`,
+  the new terms have generation `n+1`. Thus, this parameter limits the length of an instantiation chain. -/
+  gen : Nat := 5
+  /-- Maximum number of theorem instances generated using E-matching in a proof search tree branch. -/
+  instances : Nat := 1000
+  /-- If `matchEqs` is `true`, `grind` uses `match`-equations as E-matching theorems. -/
+  matchEqs : Bool := true
   deriving Inhabited, BEq
 
+end Lean.Grind
+
+namespace Lean.Parser.Tactic
+
 /-!
 `grind` tactic and related tactics.
 -/
-end Lean.Grind
+
+-- TODO: parameters
+syntax (name := grind) "grind" optConfig ("on_failure " term)? : tactic
+
+end Lean.Parser.Tactic

src/Init/Grind/Util.lean

@@ -0,0 +1,29 @@
+/-
+Copyright (c) 2024 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
+-/
+prelude
+import Init.Core
+
+namespace Lean.Grind
+
+/-- A helper gadget for annotating nested proofs in goals. -/
+def nestedProof (p : Prop) (h : p) : p := h
+
+/--
+Gadget for marking terms that should not be normalized by `grind`s simplifier.
+`grind` uses a simproc to implement this feature.
+We use it when adding instances of `match`-equations to prevent them from being simplified to true.
+-/
+def doNotSimp {α : Sort u} (a : α) : α := a
+
+/-- Gadget for representing offsets `t+k` in patterns. -/
+def offset (a b : Nat) : Nat := a + b
+
+set_option pp.proofs true
+
+theorem nestedProof_congr (p q : Prop) (h : p = q) (hp : p) (hq : q) : HEq (nestedProof p hp) (nestedProof q hq) := by
+  subst h; apply HEq.refl
+
+end Lean.Grind

src/Init/Internal.lean

@@ -0,0 +1,13 @@
+/-
+Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Joachim Breitner
+-/
+prelude
+import Init.Internal.Order
+
+/-!
+This directory is used for components of the standard library that are either considered
+implementation details or not yet ready for public consumption, and that should be available
+without explicit import (in contrast to `Std.Internal`)
+-/

src/Init/Internal/Order.lean

@@ -0,0 +1,8 @@
+/-
+Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Joachim Breitner
+-/
+prelude
+import Init.Internal.Order.Basic
+import Init.Internal.Order.Tactic

src/Init/Internal/Order/Basic.lean

@@ -0,0 +1,693 @@
+/-
+Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Joachim Breitner
+-/
+prelude
+
+import Init.ByCases
+import Init.RCases
+
+/-!
+This module contains some basic definitions and results from domain theory, intended to be used as
+the underlying construction of the `partial_fixpoint` feature. It is not meant to be used as a
+general purpose library for domain theory, but can be of interest to users who want to extend
+the `partial_fixpoint` machinery (e.g. mark more functions as monotone or register more monads).
+
+This follows the corresponding
+[Isabelle development](https://isabelle.in.tum.de/library/HOL/HOL/Partial_Function.html), as also
+described in [Alexander Krauss: Recursive Definitions of Monadic Functions](https://www21.in.tum.de/~krauss/papers/mrec.pdf).
+-/
+
+universe u v w
+
+namespace Lean.Order
+
+/--
+A partial order is a reflexive, transitive and antisymmetric relation.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+class PartialOrder (α : Sort u) where
+  /--
+  A “less-or-equal-to” or “approximates” relation.
+
+  This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+  -/
+  rel : α → α → Prop
+  rel_refl : ∀ {x}, rel x x
+  rel_trans : ∀ {x y z}, rel x y → rel y z → rel x z
+  rel_antisymm : ∀ {x y}, rel x y → rel y x → x = y
+
+@[inherit_doc] scoped infix:50 " ⊑ " => PartialOrder.rel
+
+section PartialOrder
+
+variable {α  : Sort u} [PartialOrder α]
+
+theorem PartialOrder.rel_of_eq {x y : α} (h : x = y) : x ⊑ y := by cases h; apply rel_refl
+
+/--
+A chain is a totally ordered set (representing a set as a predicate).
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+def chain (c : α → Prop) : Prop := ∀ x y , c x → c y → x ⊑ y ∨ y ⊑ x
+
+end PartialOrder
+
+section CCPO
+
+/--
+A chain-complete partial order (CCPO) is a partial order where every chain a least upper bound.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+class CCPO (α : Sort u) extends PartialOrder α where
+  /--
+  The least upper bound of a chain.
+
+  This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+  -/
+  csup : (α → Prop) → α
+  csup_spec {c : α → Prop} (hc : chain c) : csup c ⊑ x ↔ (∀ y, c y → y ⊑ x)
+
+open PartialOrder CCPO
+
+variable {α  : Sort u} [CCPO α]
+
+theorem csup_le {c : α → Prop} (hchain : chain c) : (∀ y, c y → y ⊑ x) → csup c ⊑ x :=
+  (csup_spec hchain).mpr
+
+theorem le_csup {c : α → Prop} (hchain : chain c) {y : α} (hy : c y) : y ⊑ csup c :=
+  (csup_spec hchain).mp rel_refl y hy
+
+/--
+The bottom element is the least upper bound of the empty chain.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+def bot : α := csup (fun _ => False)
+
+scoped notation "⊥" => bot
+
+theorem bot_le (x : α) : ⊥ ⊑ x := by
+  apply csup_le
+  · intro x y hx hy; contradiction
+  · intro x hx; contradiction
+
+end CCPO
+
+section monotone
+
+variable {α : Sort u} [PartialOrder α]
+variable {β : Sort v} [PartialOrder β]
+
+/--
+A function is monotone if if it maps related elements to releated elements.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+def monotone (f : α → β) : Prop := ∀ x y, x ⊑ y → f x ⊑ f y
+
+theorem monotone_const (c : β) : monotone (fun (_ : α) => c) :=
+  fun _ _ _ => PartialOrder.rel_refl
+
+theorem monotone_id : monotone (fun (x : α) => x) :=
+  fun _ _ hxy => hxy
+
+theorem monotone_compose
+    {γ : Sort w} [PartialOrder γ]
+    {f : α → β} {g : β → γ}
+    (hf : monotone f) (hg : monotone g) :
+   monotone (fun x => g (f x)) := fun _ _ hxy => hg _ _ (hf _ _ hxy)
+
+end monotone
+
+section admissibility
+
+variable {α : Sort u} [CCPO α]
+
+open PartialOrder CCPO
+
+/--
+A predicate is admissable if it can be transferred from the elements of a chain to the chains least
+upper bound. Such predicates can be used in fixpoint induction.
+
+This definition implies `P ⊥`. Sometimes (e.g. in Isabelle) the empty chain is excluded
+from this definition, and `P ⊥` is a separate condition of the induction predicate.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+def admissible (P : α → Prop) :=
+  ∀ (c : α → Prop), chain c → (∀ x, c x → P x) → P (csup c)
+
+theorem admissible_const_true : admissible (fun (_ : α) => True) :=
+  fun _ _ _ => trivial
+
+theorem admissible_and (P Q : α → Prop)
+  (hadm₁ : admissible P) (hadm₂ : admissible Q) : admissible (fun x => P x ∧ Q x) :=
+    fun c hchain h =>
+    ⟨ hadm₁ c hchain fun x hx => (h x hx).1,
+      hadm₂ c hchain fun x hx => (h x hx).2⟩
+
+theorem chain_conj (c P : α → Prop) (hchain : chain c) : chain (fun x => c x ∧ P x) := by
+  intro x y ⟨hcx, _⟩ ⟨hcy, _⟩
+  exact hchain x y hcx hcy
+
+theorem csup_conj (c P : α → Prop) (hchain : chain c) (h : ∀ x, c x → ∃ y, c y ∧ x ⊑ y ∧ P y) :
+    csup c = csup (fun x => c x ∧ P x) := by
+  apply rel_antisymm
+  · apply csup_le hchain
+    intro x hcx
+    obtain ⟨y, hcy, hxy, hPy⟩ := h x hcx
+    apply rel_trans hxy; clear x hcx hxy
+    apply le_csup (chain_conj _ _ hchain) ⟨hcy, hPy⟩
+  · apply csup_le (chain_conj _ _ hchain)
+    intro x ⟨hcx, hPx⟩
+    apply le_csup hchain hcx
+
+theorem admissible_or (P Q : α → Prop)
+  (hadm₁ : admissible P) (hadm₂ : admissible Q) : admissible (fun x => P x ∨ Q x) := by
+  intro c hchain h
+  have : (∀ x, c x → ∃ y, c y ∧ x ⊑ y ∧ P y) ∨ (∀ x, c x → ∃ y, c y ∧ x ⊑ y ∧ Q y) := by
+    open Classical in
+    apply Decidable.or_iff_not_imp_left.mpr
+    intro h'
+    simp only [not_forall, not_imp, not_exists, not_and] at h'
+    obtain ⟨x, hcx, hx⟩ := h'
+    intro y hcy
+    cases hchain x y hcx hcy  with
+    | inl hxy =>
+      refine ⟨y, hcy, rel_refl, ?_⟩
+      cases h y hcy with
+      | inl hPy => exfalso; apply hx y hcy hxy hPy
+      | inr hQy => assumption
+    | inr hyx =>
+      refine ⟨x, hcx, hyx , ?_⟩
+      cases h x hcx with
+      | inl hPx => exfalso; apply hx x hcx rel_refl hPx
+      | inr hQx => assumption
+  cases this with
+  | inl hP =>
+    left
+    rw [csup_conj (h := hP) (hchain := hchain)]
+    apply hadm₁ _ (chain_conj _ _ hchain)
+    intro x ⟨hcx, hPx⟩
+    exact hPx
+  | inr hQ =>
+    right
+    rw [csup_conj (h := hQ) (hchain := hchain)]
+    apply hadm₂ _ (chain_conj _ _ hchain)
+    intro x ⟨hcx, hQx⟩
+    exact hQx
+
+def admissible_pi (P : α → β → Prop)
+  (hadm₁ : ∀ y, admissible (fun x => P x y)) : admissible (fun x => ∀ y, P x y) :=
+    fun c hchain h y => hadm₁ y c hchain fun x hx => h x hx y
+
+end admissibility
+
+section fix
+
+open PartialOrder CCPO
+
+variable {α  : Sort u} [CCPO α]
+
+variable {c : α → Prop} (hchain : chain c)
+
+/--
+The transfinite iteration of a function `f` is a set that is `⊥ ` and is closed under application
+of `f` and `csup`.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+inductive iterates (f : α → α) : α → Prop where
+  | step : iterates f x → iterates f (f x)
+  | sup {c : α → Prop} (hc : chain c) (hi : ∀ x, c x → iterates f x) : iterates f (csup c)
+
+theorem chain_iterates {f : α → α} (hf : monotone f) : chain (iterates f) := by
+  intros x y hx hy
+  induction hx generalizing y
+  case step x hx ih =>
+    induction hy
+    case step y hy _ =>
+      cases ih y hy
+      · left; apply hf; assumption
+      · right; apply hf; assumption
+    case sup c hchain hi ih2 =>
+      show f x ⊑ csup c ∨ csup c ⊑ f x
+      by_cases h : ∃ z, c z ∧ f x ⊑ z
+      · left
+        obtain ⟨z, hz, hfz⟩ := h
+        apply rel_trans hfz
+        apply le_csup hchain hz
+      · right
+        apply csup_le hchain _
+        intro z hz
+        rw [not_exists] at h
+        specialize h z
+        rw [not_and] at h
+        specialize h hz
+        cases ih2 z hz
+        next => contradiction
+        next => assumption
+  case sup c hchain hi ih =>
+    show rel (csup c) y ∨ rel y (csup c)
+    by_cases h : ∃ z, c z ∧ rel y z
+    · right
+      obtain ⟨z, hz, hfz⟩ := h
+      apply rel_trans hfz
+      apply le_csup hchain hz
+    · left
+      apply csup_le hchain _
+      intro z hz
+      rw [not_exists] at h
+      specialize h z
+      rw [not_and] at h
+      specialize h hz
+      cases ih z hz y hy
+      next => assumption
+      next => contradiction
+
+theorem rel_f_of_iterates {f : α → α} (hf : monotone f) {x : α} (hx : iterates f x) : x ⊑ f x := by
+  induction hx
+  case step ih =>
+    apply hf
+    assumption
+  case sup c hchain hi ih =>
+    apply csup_le hchain
+    intro y hy
+    apply rel_trans (ih y hy)
+    apply hf
+    apply le_csup hchain hy
+
+set_option linter.unusedVariables false in
+/--
+The least fixpoint of a monotone function is the least upper bound of its transfinite iteration.
+
+The `monotone f` assumption is not strictly necessarily for the definition, but without this the
+definition is not very meaningful and it simplifies applying theorems like `fix_eq` if every use of
+`fix` already has the monotonicty requirement.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+def fix (f : α → α) (hmono : monotone f) := csup (iterates f)
+
+/--
+The main fixpoint theorem for fixedpoints of monotone functions in chain-complete partial orders.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+theorem fix_eq {f : α → α} (hf : monotone f) : fix f hf = f (fix f hf) := by
+  apply rel_antisymm
+  · apply rel_f_of_iterates hf
+    apply iterates.sup (chain_iterates hf)
+    exact fun _ h => h
+  · apply le_csup (chain_iterates hf)
+    apply iterates.step
+    apply iterates.sup (chain_iterates hf)
+    intro y hy
+    exact hy
+
+/--
+The fixpoint induction theme: An admissible predicate holds for a least fixpoint if it is preserved
+by the fixpoint's function.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+theorem fix_induct {f : α → α} (hf : monotone f)
+    (motive : α → Prop) (hadm: admissible motive)
+    (h : ∀ x, motive x → motive (f x)) : motive (fix f hf) := by
+  apply hadm _ (chain_iterates hf)
+  intro x hiterates
+  induction hiterates with
+  | @step x hiter ih => apply h x ih
+  | @sup c hchain hiter ih => apply hadm c hchain ih
+
+end fix
+
+section fun_order
+
+open PartialOrder
+
+variable {α : Sort u}
+variable {β : α → Sort v}
+variable {γ : Sort w}
+
+instance instOrderPi [∀ x, PartialOrder (β x)] : PartialOrder (∀ x, β x) where
+  rel f g := ∀ x, f x ⊑ g x
+  rel_refl _ := rel_refl
+  rel_trans hf hg x := rel_trans (hf x) (hg x)
+  rel_antisymm hf hg := funext (fun x => rel_antisymm (hf x) (hg x))
+
+theorem monotone_of_monotone_apply [PartialOrder γ] [∀ x, PartialOrder (β x)] (f : γ → (∀ x, β x))
+  (h : ∀ y, monotone (fun x => f x y)) : monotone f :=
+  fun x y hxy z => h z x y hxy
+
+theorem monotone_apply [PartialOrder γ] [∀ x, PartialOrder (β x)] (a : α) (f : γ → ∀ x, β x)
+    (h : monotone f) :
+    monotone (fun x => f x a) := fun _ _ hfg => h _ _ hfg a
+
+theorem chain_apply [∀ x, PartialOrder (β x)] {c : (∀ x, β x) → Prop} (hc : chain c) (x : α) :
+    chain (fun y => ∃ f, c f ∧ f x = y) := by
+  intro _ _ ⟨f, hf, hfeq⟩ ⟨g, hg, hgeq⟩
+  subst hfeq; subst hgeq
+  cases hc f g hf hg
+  next h => left; apply h x
+  next h => right; apply h x
+
+def fun_csup [∀ x, CCPO (β x)] (c : (∀ x, β x) → Prop) (x : α) :=
+  CCPO.csup (fun y => ∃ f, c f ∧ f x = y)
+
+instance instCCPOPi [∀ x, CCPO (β x)] : CCPO (∀ x, β x) where
+  csup := fun_csup
+  csup_spec := by
+    intro f c hc
+    constructor
+    next =>
+      intro hf g hg x
+      apply rel_trans _ (hf x); clear hf
+      apply le_csup (chain_apply hc x)
+      exact ⟨g, hg, rfl⟩
+    next =>
+      intro h x
+      apply csup_le (chain_apply hc x)
+      intro y ⟨z, hz, hyz⟩
+      subst y
+      apply h z hz
+
+def admissible_apply [∀ x, CCPO (β x)] (P : ∀ x, β x → Prop) (x : α)
+  (hadm : admissible (P x)) : admissible (fun (f : ∀ x, β x) => P x (f x)) := by
+  intro c hchain h
+  apply hadm _ (chain_apply hchain x)
+  rintro _ ⟨f, hcf, rfl⟩
+  apply h _ hcf
+
+def admissible_pi_apply [∀ x, CCPO (β x)] (P : ∀ x, β x → Prop) (hadm : ∀ x, admissible (P x)) :
+    admissible (fun (f : ∀ x, β x) => ∀ x, P x (f x)) := by
+  apply admissible_pi
+  intro
+  apply admissible_apply
+  apply hadm
+
+end fun_order
+
+section monotone_lemmas
+
+theorem monotone_letFun
+    {α : Sort u} {β : Sort v} {γ : Sort w} [PartialOrder α] [PartialOrder β]
+    (v : γ) (k : α → γ → β)
+    (hmono : ∀ y, monotone (fun x => k x y)) :
+  monotone fun (x : α) => letFun v (k x) := hmono v
+
+theorem monotone_ite
+    {α : Sort u} {β : Sort v} [PartialOrder α] [PartialOrder β]
+    (c : Prop) [Decidable c]
+    (k₁ : α → β) (k₂ : α → β)
+    (hmono₁ : monotone k₁) (hmono₂ : monotone k₂) :
+  monotone fun x => if c then k₁ x else k₂ x := by
+    split
+    · apply hmono₁
+    · apply hmono₂
+
+theorem monotone_dite
+    {α : Sort u} {β : Sort v} [PartialOrder α] [PartialOrder β]
+    (c : Prop) [Decidable c]
+    (k₁ : α → c → β) (k₂ : α → ¬ c → β)
+    (hmono₁ : monotone k₁) (hmono₂ : monotone k₂) :
+  monotone fun x => dite c (k₁ x) (k₂ x) := by
+    split
+    · apply monotone_apply _ _ hmono₁
+    · apply monotone_apply _ _ hmono₂
+
+end monotone_lemmas
+
+section pprod_order
+
+open PartialOrder
+
+variable {α : Sort u}
+variable {β : Sort v}
+variable {γ : Sort w}
+
+instance [PartialOrder α] [PartialOrder β] : PartialOrder (α ×' β) where
+  rel a b := a.1 ⊑ b.1 ∧ a.2 ⊑ b.2
+  rel_refl := ⟨rel_refl, rel_refl⟩
+  rel_trans ha hb := ⟨rel_trans ha.1 hb.1, rel_trans ha.2 hb.2⟩
+  rel_antisymm := fun {a} {b} ha hb => by
+    cases a; cases b;
+    dsimp at *
+    rw [rel_antisymm ha.1 hb.1, rel_antisymm ha.2 hb.2]
+
+theorem monotone_pprod [PartialOrder α] [PartialOrder β] [PartialOrder γ]
+    {f : γ → α} {g : γ → β} (hf : monotone f) (hg : monotone g) :
+    monotone (fun x => PProd.mk (f x) (g x)) :=
+  fun _ _ h12 => ⟨hf _ _ h12, hg _ _ h12⟩
+
+theorem monotone_pprod_fst [PartialOrder α] [PartialOrder β] [PartialOrder γ]
+    {f : γ → α ×' β} (hf : monotone f) : monotone (fun x => (f x).1) :=
+  fun _ _ h12 => (hf _ _ h12).1
+
+theorem monotone_pprod_snd [PartialOrder α] [PartialOrder β] [PartialOrder γ]
+    {f : γ → α ×' β} (hf : monotone f) : monotone (fun x => (f x).2) :=
+  fun _ _ h12 => (hf _ _ h12).2
+
+def chain_pprod_fst [CCPO α] [CCPO β] (c : α ×' β → Prop) : α → Prop := fun a => ∃ b, c ⟨a, b⟩
+def chain_pprod_snd [CCPO α] [CCPO β] (c : α ×' β → Prop) : β → Prop := fun b => ∃ a, c ⟨a, b⟩
+
+theorem chain.pprod_fst [CCPO α] [CCPO β] (c : α ×' β → Prop) (hchain : chain c) :
+    chain (chain_pprod_fst c) := by
+  intro a₁ a₂ ⟨b₁, h₁⟩ ⟨b₂, h₂⟩
+  cases hchain ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ h₁ h₂
+  case inl h => left; exact h.1
+  case inr h => right; exact h.1
+
+theorem chain.pprod_snd [CCPO α] [CCPO β] (c : α ×' β → Prop) (hchain : chain c) :
+    chain (chain_pprod_snd c) := by
+  intro b₁ b₂ ⟨a₁, h₁⟩ ⟨a₂, h₂⟩
+  cases hchain ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ h₁ h₂
+  case inl h => left; exact h.2
+  case inr h => right; exact h.2
+
+instance [CCPO α] [CCPO β] : CCPO (α ×' β) where
+  csup c := ⟨CCPO.csup (chain_pprod_fst c), CCPO.csup (chain_pprod_snd c)⟩
+  csup_spec := by
+    intro ⟨a, b⟩ c hchain
+    dsimp
+    constructor
+    next =>
+      intro ⟨h₁, h₂⟩ ⟨a', b'⟩ cab
+      constructor <;> dsimp at *
+      · apply rel_trans ?_ h₁
+        apply le_csup hchain.pprod_fst
+        exact ⟨b', cab⟩
+      · apply rel_trans ?_ h₂
+        apply le_csup hchain.pprod_snd
+        exact ⟨a', cab⟩
+    next =>
+      intro h
+      constructor <;> dsimp
+      · apply csup_le hchain.pprod_fst
+        intro a' ⟨b', hcab⟩
+        apply (h _ hcab).1
+      · apply csup_le hchain.pprod_snd
+        intro b' ⟨a', hcab⟩
+        apply (h _ hcab).2
+
+theorem admissible_pprod_fst {α : Sort u} {β : Sort v} [CCPO α] [CCPO β] (P : α → Prop)
+    (hadm : admissible P) : admissible (fun (x : α ×' β) => P x.1) := by
+  intro c hchain h
+  apply hadm _ hchain.pprod_fst
+  intro x ⟨y, hxy⟩
+  apply h ⟨x,y⟩ hxy
+
+theorem admissible_pprod_snd {α : Sort u} {β : Sort v} [CCPO α] [CCPO β] (P : β → Prop)
+    (hadm : admissible P) : admissible (fun (x : α ×' β) => P x.2) := by
+  intro c hchain h
+  apply hadm _ hchain.pprod_snd
+  intro y ⟨x, hxy⟩
+  apply h ⟨x,y⟩ hxy
+
+end pprod_order
+
+section flat_order
+
+variable {α : Sort u}
+
+set_option linter.unusedVariables false in
+/--
+`FlatOrder b` wraps the type `α` with the flat partial order generated by `∀ x, b ⊑ x`.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+def FlatOrder {α : Sort u} (b : α) := α
+
+variable {b : α}
+
+/--
+The flat partial order generated by `∀ x, b ⊑ x`.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+inductive FlatOrder.rel : (x y : FlatOrder b) → Prop where
+  | bot : rel b x
+  | refl : rel x x
+
+instance FlatOrder.instOrder : PartialOrder (FlatOrder b) where
+  rel := rel
+  rel_refl := .refl
+  rel_trans {x y z : α} (hxy : rel x y) (hyz : rel y z) := by
+    cases hxy <;> cases hyz <;> constructor
+  rel_antisymm {x y : α} (hxy : rel x y) (hyz : rel y x) : x = y := by
+    cases hxy <;> cases hyz <;> constructor
+
+open Classical in
+private theorem Classical.some_spec₂ {α : Sort _} {p : α → Prop} {h : ∃ a, p a} (q : α → Prop)
+    (hpq : ∀ a, p a → q a) : q (choose h) := hpq _ <| choose_spec _
+
+noncomputable def flat_csup (c : FlatOrder b → Prop) : FlatOrder b := by
+  by_cases h : ∃ (x : FlatOrder b), c x ∧ x ≠ b
+  · exact Classical.choose h
+  · exact b
+
+noncomputable instance FlatOrder.instCCPO : CCPO (FlatOrder b) where
+  csup := flat_csup
+  csup_spec := by
+    intro x c hc
+    unfold flat_csup
+    split
+    next hex =>
+      apply Classical.some_spec₂ (q := (· ⊑ x ↔ (∀ y, c y → y ⊑ x)))
+      clear hex
+      intro z ⟨hz, hnb⟩
+      constructor
+      · intro h y hy
+        apply PartialOrder.rel_trans _ h; clear h
+        cases hc y z hy hz
+        next => assumption
+        next h =>
+          cases h
+          · contradiction
+          · constructor
+      · intro h
+        cases h z hz
+        · contradiction
+        · constructor
+    next hnotex =>
+      constructor
+      · intro h y hy; clear h
+        suffices y = b by rw [this]; exact rel.bot
+        rw [not_exists] at hnotex
+        specialize hnotex y
+        rw [not_and] at hnotex
+        specialize hnotex hy
+        rw [@Classical.not_not] at hnotex
+        assumption
+      · intro; exact rel.bot
+
+theorem admissible_flatOrder (P : FlatOrder b → Prop) (hnot : P b) : admissible P := by
+  intro c hchain h
+  by_cases h' : ∃ (x : FlatOrder b), c x ∧ x ≠ b
+  · simp [CCPO.csup, flat_csup, h']
+    apply Classical.some_spec₂ (q := (P ·))
+    intro x ⟨hcx, hneb⟩
+    apply h x hcx
+  · simp [CCPO.csup, flat_csup, h', hnot]
+
+end flat_order
+
+section mono_bind
+
+/--
+The class `MonoBind m` indicates that every `m α` has a `PartialOrder`, and that the bind operation
+on `m` is monotone in both arguments with regard to that order.
+
+This is intended to be used in the construction of `partial_fixpoint`, and not meant to be used otherwise.
+-/
+class MonoBind (m : Type u → Type v) [Bind m] [∀ α, PartialOrder (m α)] where
+  bind_mono_left {a₁ a₂ : m α} {f : α → m b} (h : a₁ ⊑ a₂) : a₁ >>= f ⊑ a₂ >>= f
+  bind_mono_right {a : m α} {f₁ f₂ : α → m b} (h : ∀ x, f₁ x ⊑ f₂ x) : a >>= f₁ ⊑ a >>= f₂
+
+theorem monotone_bind
+    (m : Type u → Type v) [Bind m] [∀ α, PartialOrder (m α)] [MonoBind m]
+    {α β : Type u}
+    {γ : Type w} [PartialOrder γ]
+    (f : γ → m α) (g : γ → α → m β)
+    (hmono₁ : monotone f)
+    (hmono₂ : monotone g) :
+    monotone (fun (x : γ) => f x >>= g x) := by
+  intro x₁ x₂ hx₁₂
+  apply PartialOrder.rel_trans
+  · apply MonoBind.bind_mono_left (hmono₁ _ _ hx₁₂)
+  · apply MonoBind.bind_mono_right (fun y => monotone_apply y _ hmono₂ _ _ hx₁₂)
+
+instance : PartialOrder (Option α) := inferInstanceAs (PartialOrder (FlatOrder none))
+noncomputable instance : CCPO (Option α) := inferInstanceAs (CCPO (FlatOrder none))
+noncomputable instance : MonoBind Option where
+  bind_mono_left h := by
+    cases h
+    · exact FlatOrder.rel.bot
+    · exact FlatOrder.rel.refl
+  bind_mono_right h := by
+    cases ‹Option _›
+    · exact FlatOrder.rel.refl
+    · exact h _
+
+theorem admissible_eq_some (P : Prop) (y : α) :
+    admissible (fun (x : Option α) => x = some y → P) := by
+  apply admissible_flatOrder; simp
+
+instance [Monad m] [inst : ∀ α, PartialOrder (m α)] : PartialOrder (ExceptT ε m α) := inst _
+instance [Monad m] [∀ α, PartialOrder (m α)] [inst : ∀ α, CCPO (m α)] : CCPO (ExceptT ε m α) := inst _
+instance [Monad m] [∀ α, PartialOrder (m α)] [∀ α, CCPO (m α)] [MonoBind m] : MonoBind (ExceptT ε m) where
+  bind_mono_left h₁₂ := by
+    apply MonoBind.bind_mono_left (m := m)
+    exact h₁₂
+  bind_mono_right h₁₂ := by
+    apply MonoBind.bind_mono_right (m := m)
+    intro x
+    cases x
+    · apply PartialOrder.rel_refl
+    · apply h₁₂
+
+end mono_bind
+
+namespace Example
+
+def findF (P : Nat → Bool) (rec : Nat → Option Nat) (x : Nat) : Option Nat :=
+  if P x then
+    some x
+  else
+    rec (x + 1)
+
+noncomputable def find (P : Nat → Bool) : Nat → Option Nat := fix (findF P) <| by
+  unfold findF
+  apply monotone_of_monotone_apply
+  intro n
+  split
+  · apply monotone_const
+  · apply monotone_apply
+    apply monotone_id
+
+theorem find_eq : find P = findF P (find P) := fix_eq ..
+
+theorem find_spec : ∀ n m, find P n = some m → n ≤ m ∧ P m := by
+  unfold find
+  refine fix_induct (motive := fun (f : Nat → Option Nat) => ∀ n m, f n = some m → n ≤ m ∧ P m) _ ?hadm ?hstep
+  case hadm =>
+    -- apply admissible_pi_apply does not work well, hard to infer everything
+    exact admissible_pi_apply _ (fun n => admissible_pi _ (fun m => admissible_eq_some _ m))
+  case hstep =>
+    intro f ih n m heq
+    simp only [findF] at heq
+    split at heq
+    · simp_all
+    · obtain ⟨ih1, ih2⟩ := ih _ _ heq
+      constructor
+      · exact Nat.le_trans (Nat.le_add_right _ _ ) ih1
+      · exact ih2
+
+end Example
+
+end Lean.Order

src/Init/Internal/Order/Tactic.lean

@@ -0,0 +1,20 @@
+/-
+Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Joachim Breitner
+-/
+
+prelude
+import Init.Notation
+
+namespace Lean.Order
+/--
+`monotonicity` performs one compositional step solving `monotone` goals,
+using lemma tagged with `@[partial_fixpoint_monotone]`.
+
+This tactic is mostly used internally by lean in `partial_fixpoint` definitions, but
+can be useful on its own for debugging or when proving new `@[partial_fixpoint_monotone]` lemmas.
+-/
+scoped syntax (name := monotonicity) "monotonicity" : tactic
+
+end Lean.Order

src/Lean/Compiler/ExternAttr.lean

@@ -18,6 +18,7 @@ inductive ExternEntry where
   | inline   (backend : Name) (pattern : String)
   | standard (backend : Name) (fn : String)
   | foreign  (backend : Name) (fn : String)
+  deriving BEq, Hashable
 
 /--
 - `@[extern]`
@@ -36,7 +37,7 @@ inductive ExternEntry where
 structure ExternAttrData where
   arity?   : Option Nat := none
   entries  : List ExternEntry
-  deriving Inhabited
+  deriving Inhabited, BEq, Hashable
 
 -- def externEntry := leading_parser optional ident >> optional (nonReservedSymbol "inline ") >> strLit
 -- @[builtin_attr_parser] def extern     := leading_parser nonReservedSymbol "extern " >> optional numLit >> many externEntry

src/Lean/Compiler/LCNF/Basic.lean

@@ -7,6 +7,7 @@ prelude
 import Init.Data.List.BasicAux
 import Lean.Expr
 import Lean.Meta.Instances
+import Lean.Compiler.ExternAttr
 import Lean.Compiler.InlineAttrs
 import Lean.Compiler.Specialize
 import Lean.Compiler.LCNF.Types
@@ -429,6 +430,80 @@ where
     | .cases c => c.alts.forM fun alt => go alt.getCode
     | .unreach .. | .return .. | .jmp .. => return ()
 
+partial def Code.instantiateValueLevelParams (code : Code) (levelParams : List Name) (us : List Level) : Code :=
+  instCode code
+where
+  instLevel (u : Level) :=
+    u.instantiateParams levelParams us
+
+  instExpr (e : Expr) :=
+    e.instantiateLevelParamsNoCache levelParams us
+
+  instParams (ps : Array Param) :=
+    ps.mapMono fun p => p.updateCore (instExpr p.type)
+
+  instAlt (alt : Alt) :=
+    match alt with
+    | .default k => alt.updateCode (instCode k)
+    | .alt _ ps k => alt.updateAlt! (instParams ps) (instCode k)
+
+  instArg (arg : Arg) : Arg :=
+    match arg with
+    | .type e => arg.updateType! (instExpr e)
+    | .fvar .. | .erased => arg
+
+  instLetValue (e : LetValue) : LetValue :=
+    match e with
+    | .const declName vs args => e.updateConst! declName (vs.mapMono instLevel) (args.mapMono instArg)
+    | .fvar fvarId args => e.updateFVar! fvarId (args.mapMono instArg)
+    | .proj .. | .value .. | .erased => e
+
+  instLetDecl (decl : LetDecl) :=
+    decl.updateCore (instExpr decl.type) (instLetValue decl.value)
+
+  instFunDecl (decl : FunDecl) :=
+    decl.updateCore (instExpr decl.type) (instParams decl.params) (instCode decl.value)
+
+  instCode (code : Code) :=
+    match code with
+    | .let decl k => code.updateLet! (instLetDecl decl) (instCode k)
+    | .jp decl k | .fun decl k => code.updateFun! (instFunDecl decl) (instCode k)
+    | .cases c => code.updateCases! (instExpr c.resultType) c.discr (c.alts.mapMono instAlt)
+    | .jmp fvarId args => code.updateJmp! fvarId (args.mapMono instArg)
+    | .return .. => code
+    | .unreach type => code.updateUnreach! (instExpr type)
+
+inductive DeclValue where
+  | code (code : Code)
+  | extern (externAttrData : ExternAttrData)
+  deriving Inhabited, BEq
+
+partial def DeclValue.size : DeclValue → Nat
+  | .code c => c.size
+  | .extern .. => 0
+
+def DeclValue.mapCode (f : Code → Code) : DeclValue → DeclValue :=
+  fun
+    | .code c => .code (f c)
+    | .extern e => .extern e
+
+def DeclValue.mapCodeM [Monad m] (f : Code → m Code) : DeclValue → m DeclValue :=
+  fun v => do
+    match v with
+    | .code c => return .code (← f c)
+    | .extern .. => return v
+
+def DeclValue.forCodeM [Monad m] (f : Code → m Unit) : DeclValue → m Unit :=
+  fun v => do
+    match v with
+    | .code c => f c
+    | .extern .. => return ()
+
+def DeclValue.isCodeAndM [Monad m] (v : DeclValue) (f : Code → m Bool) : m Bool :=
+  match v with
+  | .code c => f c
+  | .extern .. => pure false
+
 /--
 Declaration being processed by the Lean to Lean compiler passes.
 -/
@@ -455,7 +530,7 @@ structure Decl where
   The body of the declaration, usually changes as it progresses
   through compiler passes.
   -/
-  value : Code
+  value : DeclValue
   /--
   We set this flag to true during LCNF conversion. When we receive
   a block of functions to be compiled, we set this flag to `true`
@@ -536,7 +611,9 @@ We use this function to decide whether we should inline a declaration tagged wit
 `[inline_if_reduce]` or not.
 -/
 def Decl.isCasesOnParam? (decl : Decl) : Option Nat :=
-  go decl.value
+  match decl.value with
+  | .code c => go c
+  | .extern .. => none
 where
   go (code : Code) : Option Nat :=
     match code with
@@ -550,49 +627,6 @@ def Decl.instantiateTypeLevelParams (decl : Decl) (us : List Level) : Expr :=
 def Decl.instantiateParamsLevelParams (decl : Decl) (us : List Level) : Array Param :=
   decl.params.mapMono fun param => param.updateCore (param.type.instantiateLevelParamsNoCache decl.levelParams us)
 
-partial def Decl.instantiateValueLevelParams (decl : Decl) (us : List Level) : Code :=
-  instCode decl.value
-where
-  instLevel (u : Level) :=
-    u.instantiateParams decl.levelParams us
-
-  instExpr (e : Expr) :=
-    e.instantiateLevelParamsNoCache decl.levelParams us
-
-  instParams (ps : Array Param) :=
-    ps.mapMono fun p => p.updateCore (instExpr p.type)
-
-  instAlt (alt : Alt) :=
-    match alt with
-    | .default k => alt.updateCode (instCode k)
-    | .alt _ ps k => alt.updateAlt! (instParams ps) (instCode k)
-
-  instArg (arg : Arg) : Arg :=
-    match arg with
-    | .type e => arg.updateType! (instExpr e)
-    | .fvar .. | .erased => arg
-
-  instLetValue (e : LetValue) : LetValue :=
-    match e with
-    | .const declName vs args => e.updateConst! declName (vs.mapMono instLevel) (args.mapMono instArg)
-    | .fvar fvarId args => e.updateFVar! fvarId (args.mapMono instArg)
-    | .proj .. | .value .. | .erased => e
-
-  instLetDecl (decl : LetDecl) :=
-    decl.updateCore (instExpr decl.type) (instLetValue decl.value)
-
-  instFunDecl (decl : FunDecl) :=
-    decl.updateCore (instExpr decl.type) (instParams decl.params) (instCode decl.value)
-
-  instCode (code : Code) :=
-    match code with
-    | .let decl k => code.updateLet! (instLetDecl decl) (instCode k)
-    | .jp decl k | .fun decl k => code.updateFun! (instFunDecl decl) (instCode k)
-    | .cases c => code.updateCases! (instExpr c.resultType) c.discr (c.alts.mapMono instAlt)
-    | .jmp fvarId args => code.updateJmp! fvarId (args.mapMono instArg)
-    | .return .. => code
-    | .unreach type => code.updateUnreach! (instExpr type)
-
 /--
 Return `true` if the arrow type contains an instance implicit argument.
 -/
@@ -693,7 +727,7 @@ where
       visit k
 
   go : StateM NameSet Unit :=
-    decls.forM fun decl => visit decl.value
+    decls.forM (·.value.forCodeM visit)
 
 def instantiateRangeArgs (e : Expr) (beginIdx endIdx : Nat) (args : Array Arg) : Expr :=
   if !e.hasLooseBVars then

src/Lean/Compiler/LCNF/Bind.lean

@@ -123,7 +123,10 @@ def FunDeclCore.etaExpand (decl : FunDecl) : CompilerM FunDecl := do
   decl.update decl.type params value
 
 def Decl.etaExpand (decl : Decl) : CompilerM Decl := do
-  let some (params, value) ← etaExpandCore? decl.type decl.params decl.value | return decl
-  return { decl with params, value }
+  match decl.value with
+  | .code code =>
+    let some (params, newCode) ← etaExpandCore? decl.type decl.params code | return decl
+    return { decl with params, value := .code newCode}
+  | .extern .. => return decl
 
 end Lean.Compiler.LCNF

src/Lean/Compiler/LCNF/CSE.lean

@@ -102,7 +102,7 @@ end CSE
 Common sub-expression elimination
 -/
 def Decl.cse (decl : Decl) : CompilerM Decl := do
-  let value ← decl.value.cse
+  let value ← decl.value.mapCodeM (·.cse)
   return { decl with value }
 
 def cse (phase : Phase := .base) (occurrence := 0) : Pass :=

src/Lean/Compiler/LCNF/Check.lean

@@ -261,7 +261,7 @@ def run (x : CheckM α) : CompilerM α :=
 end Check
 
 def Decl.check (decl : Decl) : CompilerM Unit := do
-  Check.run do Check.checkFunDeclCore decl.name decl.params decl.type decl.value
+  Check.run do decl.value.forCodeM (Check.checkFunDeclCore decl.name decl.params decl.type)
 
 /--
 Check whether every local declaration in the local context is used in one of given `decls`.
@@ -299,7 +299,7 @@ where
 
   visitDecl (decl : Decl) : StateM FVarIdHashSet Unit := do
     visitParams decl.params
-    visitCode decl.value
+    decl.value.forCodeM visitCode
 
   visitDecls (decls : Array Decl) : StateM FVarIdHashSet Unit :=
     decls.forM visitDecl

src/Lean/Compiler/LCNF/CompilerM.lean

@@ -148,7 +148,7 @@ def eraseCodeDecls (decls : Array CodeDecl) : CompilerM Unit := do
 
 def eraseDecl (decl : Decl) : CompilerM Unit := do
   eraseParams decl.params
-  eraseCode decl.value
+  decl.value.forCodeM eraseCode
 
 abbrev Decl.erase (decl : Decl) : CompilerM Unit :=
   eraseDecl decl

src/Lean/Compiler/LCNF/DeclHash.lean

@@ -38,6 +38,7 @@ end
 instance : Hashable Code where
   hash c := hashCode c
 
+deriving instance Hashable for DeclValue
 deriving instance Hashable for Decl
 
-end Lean.Compiler.LCNF
+end Lean.Compiler.LCNF

src/Lean/Compiler/LCNF/ElimDead.lean

@@ -95,6 +95,6 @@ def Code.elimDead (code : Code) : CompilerM Code :=
   ElimDead.elimDead code |>.run' {}
 
 def Decl.elimDead (decl : Decl) : CompilerM Decl := do
-  return { decl with value := (← decl.value.elimDead) }
+  return { decl with value := (← decl.value.mapCodeM Code.elimDead) }
 
 end Lean.Compiler.LCNF

src/Lean/Compiler/LCNF/ElimDeadBranches.lean

@@ -513,7 +513,7 @@ def inferStep : InterpM Bool := do
     let currentVal ← getFunVal idx
     withReader (fun ctx => { ctx with currFnIdx := idx }) do
       decl.params.forM fun p => updateVarAssignment p.fvarId .top
-      interpCode decl.value
+      decl.value.forCodeM interpCode
     let newVal ← getFunVal idx
     if currentVal != newVal then
       return true
@@ -538,7 +538,7 @@ Use the information produced by the abstract interpreter to:
 -/
 partial def elimDead (assignment : Assignment) (decl : Decl) : CompilerM Decl := do
   trace[Compiler.elimDeadBranches] s!"Eliminating {decl.name} with {repr (← assignment.toArray |>.mapM (fun (name, val) => do return (toString (← getBinderName name), val)))}"
-  return { decl with value := (← go decl.value) }
+  return { decl with value := (← decl.value.mapCodeM go) }
 where
   go (code : Code) : CompilerM Code := do
     match code with

src/Lean/Compiler/LCNF/FixedParams.lean

@@ -141,8 +141,9 @@ partial def evalApp (declName : Name) (args : Array Arg) : FixParamM Unit := do
       let key := (declName, values)
       unless (← get).visited.contains key do
         modify fun s => { s with visited := s.visited.insert key }
-        let assignment := mkAssignment decl values
-        withReader (fun ctx => { ctx with assignment }) <| evalCode decl.value
+        decl.value.forCodeM fun c =>
+          let assignment := mkAssignment decl values
+          withReader (fun ctx => { ctx with assignment }) <| evalCode c
 
 end
 
@@ -169,8 +170,12 @@ def mkFixedParamsMap (decls : Array Decl) : NameMap (Array Bool) := Id.run do
     let values := mkInitialValues decl.params.size
     let assignment := mkAssignment decl values
     let fixed := Array.mkArray decl.params.size true
-    match evalCode decl.value |>.run { main := decl, decls, assignment } |>.run { fixed } with
-    | .ok _ s | .error _ s => result := result.insert decl.name s.fixed
+    match decl.value with
+    | .code c =>
+      match evalCode c |>.run { main := decl, decls, assignment } |>.run { fixed } with
+      | .ok _ s | .error _ s => result := result.insert decl.name s.fixed
+    | .extern .. =>
+      result := result.insert decl.name fixed
   return result
 
 end Lean.Compiler.LCNF

src/Lean/Compiler/LCNF/FloatLetIn.lean

@@ -239,7 +239,7 @@ Iterate through `decl`, pushing local declarations that are only used in one
 control flow arm into said arm in order to avoid useless computations.
 -/
 partial def floatLetIn (decl : Decl) : CompilerM Decl := do
-  let newValue ← go decl.value |>.run {}
+  let newValue ← decl.value.mapCodeM go |>.run {}
   return { decl with value := newValue }
 where
   /--

src/Lean/Compiler/LCNF/Internalize.lean

@@ -108,7 +108,7 @@ where
   go (decl : Decl) : InternalizeM Decl := do
     let type ← normExpr decl.type
     let params ← decl.params.mapM internalizeParam
-    let value ← internalizeCode decl.value
+    let value ← decl.value.mapCodeM internalizeCode
     return { decl with type, params, value }
 
 /--

src/Lean/Compiler/LCNF/JoinPoints.lean

@@ -133,7 +133,7 @@ this. This is because otherwise the calls to `myjp` in `f` and `g` would
 produce out of scope join point jumps.
 -/
 partial def find (decl : Decl) : CompilerM FindState := do
-  let (_, candidates) ← go decl.value |>.run none |>.run {} |>.run' {}
+  let (_, candidates) ← decl.value.forCodeM go |>.run none |>.run {} |>.run' {}
   return candidates
 where
   go : Code → FindM Unit
@@ -178,7 +178,7 @@ and all calls to them with `jmp`s.
 partial def replace (decl : Decl) (state : FindState) : CompilerM Decl := do
   let mapper := fun acc cname _ => do return acc.insert cname (← mkFreshJpName)
   let replaceCtx : ReplaceCtx ← state.candidates.foldM (init := .empty) mapper
-  let newValue ← go decl.value |>.run replaceCtx
+  let newValue ← decl.value.mapCodeM go |>.run replaceCtx
   return { decl with value := newValue }
 where
   go (code : Code) : ReplaceM Code := do
@@ -389,7 +389,7 @@ position within the code so we can pull them out as far as possible, hopefully
 enabling new inlining possibilities in the next simplifier run.
 -/
 partial def extend (decl : Decl) : CompilerM Decl := do
-  let newValue ← go decl.value |>.run {} |>.run' {} |>.run' {}
+  let newValue ← decl.value.mapCodeM go |>.run {} |>.run' {} |>.run' {}
   let decl := { decl with value := newValue }
   decl.pullFunDecls
 where
@@ -510,8 +510,8 @@ After we have performed all of these optimizations we can take away the
 code that has as little arguments as possible in the join points.
 -/
 partial def reduce (decl : Decl) : CompilerM Decl := do
-  let (_, analysis) ← goAnalyze decl.value |>.run {} |>.run {} |>.run' {}
-  let newValue ← goReduce decl.value |>.run analysis
+  let (_, analysis) ← decl.value.forCodeM goAnalyze |>.run {} |>.run {} |>.run' {}
+  let newValue ← decl.value.mapCodeM goReduce |>.run analysis
   return { decl with value := newValue }
 where
   goAnalyzeFunDecl (fn : FunDecl) : ReduceAnalysisM Unit := do

src/Lean/Compiler/LCNF/LambdaLifting.lean

@@ -108,9 +108,10 @@ def mkAuxDecl (closure : Array Param) (decl : FunDecl) : LiftM LetDecl := do
 where
   go (nameNew : Name) (safe : Bool) (inlineAttr? : Option InlineAttributeKind) : InternalizeM Decl := do
     let params := (← closure.mapM internalizeParam) ++ (← decl.params.mapM internalizeParam)
-    let value ← internalizeCode decl.value
-    let type ← value.inferType
+    let code ← internalizeCode decl.value
+    let type ← code.inferType
     let type ← mkForallParams params type
+    let value := .code code
     let decl := { name := nameNew, levelParams := [], params, type, value, safe, inlineAttr?, recursive := false : Decl }
     return decl.setLevelParams
 
@@ -149,7 +150,7 @@ mutual
 end
 
 def main (decl : Decl) : LiftM Decl := do
-  let value ← withParams decl.params <| visitCode decl.value
+  let value ← withParams decl.params <| decl.value.mapCodeM visitCode
   return { decl with value }
 
 end LambdaLifting

src/Lean/Compiler/LCNF/Level.lean

@@ -139,6 +139,10 @@ mutual
     | .jmp _ args => visitArgs args
 end
 
+def visitDeclValue : DeclValue → Visitor
+  | .code c => visitCode c
+  | .extern .. => id
+
 end CollectLevelParams
 
 open Lean.CollectLevelParams
@@ -149,7 +153,7 @@ Collect universe level parameters collecting in the type, parameters, and value,
 set `decl.levelParams` with the resulting value.
 -/
 def Decl.setLevelParams (decl : Decl) : Decl :=
-  let levelParams := (visitCode decl.value ∘ visitParams decl.params ∘ visitType decl.type) {} |>.params.toList
+  let levelParams := (visitDeclValue decl.value ∘ visitParams decl.params ∘ visitType decl.type) {} |>.params.toList
   { decl with levelParams }
 
 end Lean.Compiler.LCNF

src/Lean/Compiler/LCNF/Main.lean

@@ -28,10 +28,10 @@ and `[specialize]` since they can be partially applied.
 -/
 def shouldGenerateCode (declName : Name) : CoreM Bool := do
   if (← isCompIrrelevant |>.run') then return false
+  let env ← getEnv
+  if isExtern env declName then return true
   let some info ← getDeclInfo? declName | return false
   unless info.hasValue (allowOpaque := true) do return false
-  let env ← getEnv
-  if isExtern env declName then return false
   if hasMacroInlineAttribute env declName then return false
   if (← Meta.isMatcher declName) then return false
   if isCasesOnRecursor env declName then return false

src/Lean/Compiler/LCNF/PrettyPrinter.lean

@@ -105,6 +105,11 @@ mutual
         return f!"⊥ : {← ppExpr type}"
       else
         return "⊥"
+
+  partial def ppDeclValue (b : DeclValue) : M Format := do
+    match b with
+    | .code c => ppCode c
+    | .extern .. => return "extern"
 end
 
 def run (x : M α) : CompilerM α :=
@@ -121,7 +126,7 @@ def ppLetValue (e : LetValue) : CompilerM Format :=
 
 def ppDecl (decl : Decl) : CompilerM Format :=
   PP.run do
-    return f!"def {decl.name}{← PP.ppParams decl.params} : {← PP.ppExpr (← PP.getFunType decl.params decl.type)} :={indentD (← PP.ppCode decl.value)}"
+    return f!"def {decl.name}{← PP.ppParams decl.params} : {← PP.ppExpr (← PP.getFunType decl.params decl.type)} :={indentD (← PP.ppDeclValue decl.value)}"
 
 def ppFunDecl (decl : FunDecl) : CompilerM Format :=
   PP.run do

src/Lean/Compiler/LCNF/Probing.lean

@@ -57,7 +57,7 @@ where
     | .cases (cases : CasesCore Code) => cases.alts.forM (go ·.getCode)
     | .jmp .. | .return .. | .unreach .. => return ()
   start (decls : Array Decl) : StateRefT (Array LetValue) CompilerM Unit :=
-    decls.forM (go ·.value)
+    decls.forM (·.value.forCodeM go)
 
 partial def getJps : Probe Decl FunDecl := fun decls => do
   let (_, res) ← start decls |>.run #[]
@@ -72,10 +72,10 @@ where
     | .jmp .. | .return .. | .unreach .. => return ()
 
   start (decls : Array Decl) : StateRefT (Array FunDecl) CompilerM Unit :=
-    decls.forM fun decl => go decl.value
+    decls.forM (·.value.forCodeM go)
 
 partial def filterByLet (f : LetDecl → CompilerM Bool) : Probe Decl Decl :=
-  filter (fun decl => go decl.value)
+  filter (·.value.isCodeAndM go)
 where
   go : Code → CompilerM Bool
   | .let decl k => do if (← f decl) then return true else go k
@@ -84,7 +84,7 @@ where
   | .jmp .. | .return .. | .unreach .. => return false
 
 partial def filterByFun (f : FunDecl → CompilerM Bool) : Probe Decl Decl :=
-  filter (fun decl => go decl.value)
+  filter (·.value.isCodeAndM go)
 where
   go : Code → CompilerM Bool
   | .let _ k | .jp _ k  => go k
@@ -93,7 +93,7 @@ where
   | .jmp .. | .return .. | .unreach .. => return false
 
 partial def filterByJp (f : FunDecl → CompilerM Bool) : Probe Decl Decl :=
-  filter (fun decl => go decl.value)
+  filter (·.value.isCodeAndM go)
 where
   go : Code → CompilerM Bool
   | .let _ k => go k
@@ -103,7 +103,7 @@ where
   | .jmp .. | .return .. | .unreach .. => return false
 
 partial def filterByFunDecl (f : FunDecl → CompilerM Bool) : Probe Decl Decl :=
-  filter (fun decl => go decl.value)
+  filter (·.value.isCodeAndM go)
 where
   go : Code → CompilerM Bool
   | .let _ k => go k
@@ -112,7 +112,7 @@ where
   | .jmp .. | .return .. | .unreach .. => return false
 
 partial def filterByCases (f : Cases → CompilerM Bool) : Probe Decl Decl :=
-  filter (fun decl => go decl.value)
+  filter (·.value.isCodeAndM go)
 where
   go : Code → CompilerM Bool
   | .let _ k => go k
@@ -121,7 +121,7 @@ where
   | .jmp .. | .return .. | .unreach .. => return false
 
 partial def filterByJmp (f : FVarId → Array Arg → CompilerM Bool) : Probe Decl Decl :=
-  filter (fun decl => go decl.value)
+  filter (·.value.isCodeAndM go)
 where
   go : Code → CompilerM Bool
   | .let _ k => go k
@@ -131,7 +131,7 @@ where
   | .return .. | .unreach .. => return false
 
 partial def filterByReturn (f : FVarId → CompilerM Bool) : Probe Decl Decl :=
-  filter (fun decl => go decl.value)
+  filter (·.value.isCodeAndM go)
 where
   go : Code → CompilerM Bool
   | .let _ k => go k
@@ -141,7 +141,7 @@ where
   | .return var  => f var
 
 partial def filterByUnreach (f : Expr → CompilerM Bool) : Probe Decl Decl :=
-  filter (fun decl => go decl.value)
+  filter (·.value.isCodeAndM go)
 where
   go : Code → CompilerM Bool
   | .let _ k => go k

src/Lean/Compiler/LCNF/PullFunDecls.lean

@@ -172,8 +172,8 @@ open PullFunDecls
 Pull local function declarations and join points in the given declaration.
 -/
 def Decl.pullFunDecls (decl : Decl) : CompilerM Decl := do
-  let (value, ps) ← pull decl.value |>.run []
-  let value := attach ps.toArray value
+  let (value, ps) ← decl.value.mapCodeM pull |>.run []
+  let value := value.mapCode (attach ps.toArray)
   return { decl with value }
 
 def pullFunDecls : Pass :=

src/Lean/Compiler/LCNF/PullLetDecls.lean

@@ -96,8 +96,8 @@ open PullLetDecls
 def Decl.pullLetDecls (decl : Decl) (isCandidateFn : LetDecl → FVarIdSet → CompilerM Bool) : CompilerM Decl := do
   PullM.run (isCandidateFn := isCandidateFn) do
     withParams decl.params do
-      let value ← pullDecls decl.value
-      let value ← attachToPull value
+      let value ← decl.value.mapCodeM pullDecls
+      let value ← value.mapCodeM attachToPull
       return { decl with value }
 
 def Decl.pullInstances (decl : Decl) : CompilerM Decl :=

src/Lean/Compiler/LCNF/ReduceArity.lean

@@ -108,7 +108,7 @@ partial def visit (code : Code) : FindUsedM Unit := do
 
 def collectUsedParams (decl : Decl) : CompilerM FVarIdSet := do
   let params := decl.params.foldl (init := {}) fun s p => s.insert p.fvarId
-  let (_, { used, .. }) ← visit decl.value |>.run { decl, params } |>.run {}
+  let (_, { used, .. }) ← decl.value.forCodeM visit |>.run { decl, params } |>.run {}
   return used
 
 end FindUsed
@@ -146,37 +146,40 @@ end ReduceArity
 open FindUsed ReduceArity Internalize
 
 def Decl.reduceArity (decl : Decl) : CompilerM (Array Decl) := do
-  let used ← collectUsedParams decl
-  if used.size == decl.params.size then
-    return #[decl] -- Declarations uses all parameters
-  else
-    trace[Compiler.reduceArity] "{decl.name}, used params: {used.toList.map mkFVar}"
-    let mask   := decl.params.map fun param => used.contains param.fvarId
-    let auxName   := decl.name ++ `_redArg
-    let mkAuxDecl : CompilerM Decl := do
-      let params := decl.params.filter fun param => used.contains param.fvarId
-      let value  ← reduce decl.value |>.run { declName := decl.name, auxDeclName := auxName, paramMask := mask }
-      let type ← value.inferType
-      let type ← mkForallParams params type
-      let auxDecl := { decl with name := auxName, levelParams := [], type, params, value }
-      auxDecl.saveMono
-      return auxDecl
-    let updateDecl : InternalizeM Decl := do
-      let params ← decl.params.mapM internalizeParam
-      let mut args := #[]
-      for used in mask, param in params do
-        if used then
-          args := args.push param.toArg
-      let letDecl ← mkAuxLetDecl (.const auxName [] args)
-      let value := .let letDecl (.return letDecl.fvarId)
-      let decl := { decl with params, value, inlineAttr? := some .inline, recursive := false }
-      decl.saveMono
-      return decl
-    let unusedParams := decl.params.filter fun param => !used.contains param.fvarId
-    let auxDecl ← mkAuxDecl
-    let decl ← updateDecl |>.run' {}
-    eraseParams unusedParams
-    return #[auxDecl, decl]
+  match decl.value with
+  | .code code =>
+    let used ← collectUsedParams decl
+    if used.size == decl.params.size then
+      return #[decl] -- Declarations uses all parameters
+    else
+      trace[Compiler.reduceArity] "{decl.name}, used params: {used.toList.map mkFVar}"
+      let mask   := decl.params.map fun param => used.contains param.fvarId
+      let auxName   := decl.name ++ `_redArg
+      let mkAuxDecl : CompilerM Decl := do
+        let params := decl.params.filter fun param => used.contains param.fvarId
+        let value  ← decl.value.mapCodeM reduce |>.run { declName := decl.name, auxDeclName := auxName, paramMask := mask }
+        let type ← code.inferType
+        let type ← mkForallParams params type
+        let auxDecl := { decl with name := auxName, levelParams := [], type, params, value }
+        auxDecl.saveMono
+        return auxDecl
+      let updateDecl : InternalizeM Decl := do
+        let params ← decl.params.mapM internalizeParam
+        let mut args := #[]
+        for used in mask, param in params do
+          if used then
+            args := args.push param.toArg
+        let letDecl ← mkAuxLetDecl (.const auxName [] args)
+        let value := .code (.let letDecl (.return letDecl.fvarId))
+        let decl := { decl with params, value, inlineAttr? := some .inline, recursive := false }
+        decl.saveMono
+        return decl
+      let unusedParams := decl.params.filter fun param => !used.contains param.fvarId
+      let auxDecl ← mkAuxDecl
+      let decl ← updateDecl |>.run' {}
+      eraseParams unusedParams
+      return #[auxDecl, decl]
+  | .extern .. => return #[decl]
 
 def reduceArity : Pass where
   phase := .mono
@@ -187,4 +190,4 @@ def reduceArity : Pass where
 builtin_initialize
   registerTraceClass `Compiler.reduceArity (inherited := true)
 
-end Lean.Compiler.LCNF
+end Lean.Compiler.LCNF

src/Lean/Compiler/LCNF/ReduceJpArity.lean

@@ -68,7 +68,7 @@ open ReduceJpArity
 Try to reduce arity of join points
 -/
 def Decl.reduceJpArity (decl : Decl) : CompilerM Decl := do
-  let value ← reduce decl.value |>.run {}
+  let value ← decl.value.mapCodeM reduce |>.run {}
   return { decl with value }
 
 def reduceJpArity (phase := Phase.base) : Pass :=

src/Lean/Compiler/LCNF/Renaming.lean

@@ -55,7 +55,7 @@ def Decl.applyRenaming (decl : Decl) (r : Renaming) : CompilerM Decl := do
     return decl
   else
     let params ← decl.params.mapMonoM (·.applyRenaming r)
-    let value ← decl.value.applyRenaming r
+    let value ← decl.value.mapCodeM (·.applyRenaming r)
     return { decl with params, value }
 
-end Lean.Compiler.LCNF
+end Lean.Compiler.LCNF

src/Lean/Compiler/LCNF/Simp.lean

@@ -22,19 +22,20 @@ namespace Lean.Compiler.LCNF
 open Simp
 
 def Decl.simp? (decl : Decl) : SimpM (Option Decl) := do
-  updateFunDeclInfo decl.value
+  let .code code := decl.value | return none
+  updateFunDeclInfo code
   traceM `Compiler.simp.inline.info do return m!"{decl.name}:{Format.nest 2 (← (← get).funDeclInfoMap.format)}"
   traceM `Compiler.simp.step do ppDecl decl
-  let value ← simp decl.value
+  let code ← simp code
   let s ← get
-  let value ← value.applyRenaming s.binderRenaming
-  traceM `Compiler.simp.step.new do return m!"{decl.name} :=\n{← ppCode value}"
-  trace[Compiler.simp.stat] "{decl.name}, size: {value.size}, # visited: {s.visited}, # inline: {s.inline}, # inline local: {s.inlineLocal}"
-  if let some value ← simpJpCases? value then
-    let decl := { decl with value }
+  let code ← code.applyRenaming s.binderRenaming
+  traceM `Compiler.simp.step.new do return m!"{decl.name} :=\n{← ppCode code}"
+  trace[Compiler.simp.stat] "{decl.name}, size: {code.size}, # visited: {s.visited}, # inline: {s.inline}, # inline local: {s.inlineLocal}"
+  if let some code ← simpJpCases? code then
+    let decl := { decl with value := .code code }
     decl.reduceJpArity
   else if (← get).simplified then
-    return some { decl with value }
+    return some { decl with value := .code code }
   else
     return none
 

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

@@ -43,6 +43,7 @@ def inlineCandidate? (e : LetValue) : SimpM (Option InlineCandidateInfo) := do
     unless (← read).config.inlineDefs do
       return none
     let some decl ← getDecl? declName | return none
+    let .code code := decl.value | return none
     let shouldInline : SimpM Bool := do
       if !decl.inlineIfReduceAttr && decl.recursive then return false
       if mustInline then return true
@@ -63,9 +64,8 @@ def inlineCandidate? (e : LetValue) : SimpM (Option InlineCandidateInfo) := do
       if decl.alwaysInlineAttr then return true
       -- TODO: check inlining quota
       if decl.inlineAttr || decl.inlineIfReduceAttr then return true
-      unless decl.noinlineAttr do
-        if (← isSmall decl.value) then return true
-      return false
+      if decl.noinlineAttr then return false
+      isSmall code
     unless (← shouldInline) do return none
     /- check arity -/
     let arity := decl.getArity
@@ -77,7 +77,7 @@ def inlineCandidate? (e : LetValue) : SimpM (Option InlineCandidateInfo) := do
       let arg := args[paramIdx]!
       unless (← arg.isConstructorApp) do return none
     let params := decl.instantiateParamsLevelParams us
-    let value := decl.instantiateValueLevelParams us
+    let value := code.instantiateValueLevelParams decl.levelParams us
     let type := decl.instantiateTypeLevelParams us
     incInline
     return some {

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

@@ -69,11 +69,14 @@ where
           visit fvarId projs
       else
         let some decl ← getDecl? declName | failure
-        guard (decl.getArity == args.size)
-        let params := decl.instantiateParamsLevelParams us
-        let code := decl.instantiateValueLevelParams us
-        let code ← betaReduce params code args (mustInline := true)
-        visitCode code projs
+        match decl.value with
+        | .code code =>
+          guard (decl.getArity == args.size)
+          let params := decl.instantiateParamsLevelParams us
+          let code := code.instantiateValueLevelParams decl.levelParams us
+          let code ← betaReduce params code args (mustInline := true)
+          visitCode code projs
+        | .extern .. => failure
 
   visitCode (code : Code) (projs : List Nat) : OptionT (StateRefT (Array CodeDecl) SimpM) FVarId := do
     match code with

src/Lean/Compiler/LCNF/Specialize.lean

@@ -222,6 +222,7 @@ def mkSpecDecl (decl : Decl) (us : List Level) (argMask : Array (Option Arg)) (p
     eraseDecl decl
 where
   go (decl : Decl) (nameNew : Name) : InternalizeM Decl := do
+    let .code code := decl.value | panic! "can only specialize decls with code"
     let mut params ← params.mapM internalizeParam
     let decls ← decls.mapM internalizeCodeDecl
     for param in decl.params, arg in argMask do
@@ -235,11 +236,12 @@ where
     for param in decl.params[argMask.size:] do
       let param := { param with type := param.type.instantiateLevelParamsNoCache decl.levelParams us }
       params := params.push (← internalizeParam param)
-    let value := decl.instantiateValueLevelParams us
-    let value ← internalizeCode value
-    let value := attachCodeDecls decls value
-    let type ← value.inferType
+    let code := code.instantiateValueLevelParams decl.levelParams us
+    let code ← internalizeCode code
+    let code := attachCodeDecls decls code
+    let type ← code.inferType
     let type ← mkForallParams params type
+    let value := .code code
     let safe := decl.safe
     let recursive := decl.recursive
     let decl := { name := nameNew, levelParams := levelParamsNew, params, type, value, safe, recursive, inlineAttr? := none : Decl }
@@ -268,6 +270,7 @@ mutual
     let some paramsInfo ← getSpecParamInfo? declName | return none
     unless (← shouldSpecialize paramsInfo args) do return none
     let some decl ← getDecl? declName | return none
+    let .code _ := decl.value | return none
     trace[Compiler.specialize.candidate] "{e.toExpr}, {paramsInfo}"
     let (argMask, params, decls) ← Collector.collect paramsInfo args
     let keyBody := .const declName us (argMask.filterMap id)
@@ -290,7 +293,7 @@ mutual
       let specDecl ← specDecl.simp {}
       let specDecl ← specDecl.simp { etaPoly := true, inlinePartial := true, implementedBy := true }
       let value ← withReader (fun _ => { declName := specDecl.name }) do
-         withParams specDecl.params <| visitCode specDecl.value
+         withParams specDecl.params <| specDecl.value.mapCodeM visitCode
       let specDecl := { specDecl with value }
       modify fun s => { s with decls := s.decls.push specDecl }
       return some (.const specDecl.name usNew argsNew)
@@ -325,7 +328,7 @@ def main (decl : Decl) : SpecializeM Decl := do
   if (← decl.isTemplateLike) then
     return decl
   else
-    let value ← withParams decl.params <| visitCode decl.value
+    let value ← withParams decl.params <| decl.value.mapCodeM visitCode
     return { decl with value }
 
 end Specialize

src/Lean/Compiler/LCNF/Testing.lean

@@ -235,12 +235,17 @@ 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 (fun _ decl => !decl.value.containsConst constName) msg
+  assertForEachDeclAfterEachOccurrence
+    fun _ decl =>
+      match decl.value with
+      | .code c => !c.containsConst constName
+      | .extern .. => true
+    msg
 
 def assertNoFun : TestInstaller :=
   assertAfter do
     for decl in (← getDecls) do
-      decl.value.forM fun
+      decl.value.forCodeM fun
         | .fun .. => throwError "declaration `{decl.name}` contains a local function declaration"
         | _ => return ()
 

src/Lean/Compiler/LCNF/ToDecl.lean

@@ -6,6 +6,7 @@ Authors: Leonardo de Moura
 prelude
 import Lean.Meta.Transform
 import Lean.Meta.Match.MatcherInfo
+import Lean.Compiler.ExternAttr
 import Lean.Compiler.ImplementedByAttr
 import Lean.Compiler.LCNF.ToLCNF
 
@@ -96,31 +97,48 @@ The steps for this are roughly:
 def toDecl (declName : Name) : CompilerM Decl := do
   let declName := if let some name := isUnsafeRecName? declName then name else declName
   let some info ← getDeclInfo? declName | throwError "declaration `{declName}` not found"
-  let some value := info.value? (allowOpaque := true) | throwError "declaration `{declName}` does not have a value"
-  let (type, value) ← Meta.MetaM.run' do
-    let type  ← toLCNFType info.type
-    let value ← Meta.lambdaTelescope value fun xs body => do Meta.mkLambdaFVars xs (← Meta.etaExpand body)
-    let value ← replaceUnsafeRecNames value
-    let value ← macroInline value
-    /- Recall that some declarations tagged with `macro_inline` contain matchers. -/
-    let value ← inlineMatchers value
-    /- Recall that `inlineMatchers` may have exposed `ite`s and `dite`s which are tagged as `[macro_inline]`. -/
-    let value ← macroInline value
-    /-
-    Remark: we have disabled the following transformatbion, we will perform it at phase 2, after code specialization.
-    It prevents many optimizations (e.g., "cases-of-ctor").
-    -/
-    -- let value ← applyCasesOnImplementedBy value
-    return (type, value)
-  let value ← toLCNF value
   let safe := !info.isPartial && !info.isUnsafe
   let inlineAttr? := getInlineAttribute? (← getEnv) declName
-  let decl ← if let .fun decl (.return _) := value then
-    eraseFunDecl decl (recursive := false)
-    pure { name := declName, params := decl.params, type, value := decl.value, levelParams := info.levelParams, safe, inlineAttr? : Decl }
+  if let some externAttrData := getExternAttrData? (← getEnv) declName then
+    let paramsFromTypeBinders (expr : Expr) : CompilerM (Array Param) := do
+      let mut params := #[]
+      let mut currentExpr := expr
+      repeat
+        match currentExpr with
+        | .forallE binderName type body _ =>
+          let borrow := isMarkedBorrowed type
+          params := params.push (← mkParam binderName type borrow)
+          currentExpr := body
+        | _ => break
+      return params
+
+    let type ← Meta.MetaM.run' (toLCNFType info.type)
+    let params ← paramsFromTypeBinders type
+    return { name := declName, params, type, value := .extern externAttrData, levelParams := info.levelParams, safe, inlineAttr? }
   else
-    pure { name := declName, params := #[], type, value, levelParams := info.levelParams, safe, inlineAttr? }
-  /- `toLCNF` may eta-reduce simple declarations. -/
-  decl.etaExpand
+    let some value := info.value? (allowOpaque := true) | throwError "declaration `{declName}` does not have a value"
+    let (type, value) ← Meta.MetaM.run' do
+      let type  ← toLCNFType info.type
+      let value ← Meta.lambdaTelescope value fun xs body => do Meta.mkLambdaFVars xs (← Meta.etaExpand body)
+      let value ← replaceUnsafeRecNames value
+      let value ← macroInline value
+      /- Recall that some declarations tagged with `macro_inline` contain matchers. -/
+      let value ← inlineMatchers value
+      /- Recall that `inlineMatchers` may have exposed `ite`s and `dite`s which are tagged as `[macro_inline]`. -/
+      let value ← macroInline value
+      /-
+      Remark: we have disabled the following transformatbion, we will perform it at phase 2, after code specialization.
+      It prevents many optimizations (e.g., "cases-of-ctor").
+      -/
+      -- let value ← applyCasesOnImplementedBy value
+      return (type, value)
+    let code ← toLCNF value
+    let decl ← if let .fun decl (.return _) := code then
+      eraseFunDecl decl (recursive := false)
+      pure { name := declName, params := decl.params, type, value := .code decl.value, levelParams := info.levelParams, safe, inlineAttr? : Decl }
+    else
+      pure { name := declName, params := #[], type, value := .code code, levelParams := info.levelParams, safe, inlineAttr? }
+    /- `toLCNF` may eta-reduce simple declarations. -/
+    decl.etaExpand
 
 end Lean.Compiler.LCNF

src/Lean/Compiler/LCNF/ToExpr.lean

@@ -110,7 +110,4 @@ def Code.toExpr (code : Code) (xs : Array FVarId := #[]) : Expr :=
 def FunDeclCore.toExpr (decl : FunDecl) (xs : Array FVarId := #[]) : Expr :=
   run' decl.toExprM xs
 
-def Decl.toExpr (decl : Decl) : Expr :=
-  run do withParams decl.params do mkLambdaM decl.params (← decl.value.toExprM)
-
 end Lean.Compiler.LCNF

src/Lean/Compiler/LCNF/ToMono.lean

@@ -143,7 +143,7 @@ where
   go : ToMonoM Decl := do
     let type ← toMonoType decl.type
     let params ← decl.params.mapM (·.toMono)
-    let value ← decl.value.toMono
+    let value ← decl.value.mapCodeM (·.toMono)
     let decl := { decl with type, params, value, levelParams := [] }
     decl.saveMono
     return decl

src/Lean/Data/Lsp.lean

@@ -6,6 +6,7 @@ Authors: Marc Huisinga, Wojciech Nawrocki
 -/
 prelude
 import Lean.Data.Lsp.Basic
+import Lean.Data.Lsp.CancelParams
 import Lean.Data.Lsp.Capabilities
 import Lean.Data.Lsp.Client
 import Lean.Data.Lsp.Communication

src/Lean/Data/Lsp/Basic.lean

@@ -6,7 +6,6 @@ Authors: Marc Huisinga, Wojciech Nawrocki
 -/
 prelude
 import Lean.Data.Json
-import Lean.Data.JsonRpc
 
 /-! Defines most of the 'Basic Structures' in the LSP specification
 (https://microsoft.github.io/language-server-protocol/specifications/specification-current/),
@@ -19,10 +18,6 @@ namespace Lsp
 
 open Json
 
-structure CancelParams where
-  id : JsonRpc.RequestID
-  deriving Inhabited, BEq, ToJson, FromJson
-
 abbrev DocumentUri := String
 
 /-- We adopt the convention that zero-based UTF-16 positions as sent by LSP clients

src/Lean/Data/Lsp/CancelParams.lean

@@ -0,0 +1,25 @@
+/-
+Copyright (c) 2020 Marc Huisinga. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+
+Authors: Marc Huisinga, Wojciech Nawrocki
+-/
+prelude
+import Lean.Data.JsonRpc
+
+/-! # Defines `Lean.Lsp.CancelParams`.
+
+This is separate from `Lean.Data.Lsp.Basic` to reduce transitive dependencies.
+-/
+
+namespace Lean
+namespace Lsp
+
+open Json
+
+structure CancelParams where
+  id : JsonRpc.RequestID
+  deriving Inhabited, BEq, ToJson, FromJson
+
+end Lsp
+end Lean

src/Lean/Data/Lsp/Utf16.lean

@@ -6,7 +6,6 @@ Authors: Marc Huisinga, Wojciech Nawrocki
 -/
 prelude
 import Init.Data.String
-import Init.Data.Array
 import Lean.Data.Lsp.Basic
 import Lean.Data.Position
 import Lean.DeclarationRange

src/Lean/Data/PersistentHashSet.lean

@@ -49,3 +49,8 @@ variable {_ : BEq α} {_ : Hashable α}
 
 @[inline] def fold {β : Type v} (f : β → α → β) (init : β) (s : PersistentHashSet α) : β :=
   Id.run $ s.foldM f init
+
+def toList (s : PersistentHashSet α) : List α :=
+  s.set.toList.map (·.1)
+
+end PersistentHashSet

src/Lean/Elab/Calc.lean

@@ -131,14 +131,18 @@ def throwCalcFailure (steps : Array CalcStepView) (expectedType result : Expr) :
     if ← isDefEqGuarded r er then
       let mut failed := false
       unless ← isDefEqGuarded lhs elhs do
+        let (lhs, elhs) ← addPPExplicitToExposeDiff lhs elhs
+        let (lhsTy, elhsTy) ← addPPExplicitToExposeDiff (← inferType lhs) (← inferType elhs)
         logErrorAt steps[0]!.term m!"\
-          invalid 'calc' step, left-hand side is{indentD m!"{lhs} : {← inferType lhs}"}\n\
-          but is expected to be{indentD m!"{elhs} : {← inferType elhs}"}"
+          invalid 'calc' step, left-hand side is{indentD m!"{lhs} : {lhsTy}"}\n\
+          but is expected to be{indentD m!"{elhs} : {elhsTy}"}"
         failed := true
       unless ← isDefEqGuarded rhs erhs do
+        let (rhs, erhs) ← addPPExplicitToExposeDiff rhs erhs
+        let (rhsTy, erhsTy) ← addPPExplicitToExposeDiff (← inferType rhs) (← inferType erhs)
         logErrorAt steps.back!.term m!"\
-          invalid 'calc' step, right-hand side is{indentD m!"{rhs} : {← inferType rhs}"}\n\
-          but is expected to be{indentD m!"{erhs} : {← inferType erhs}"}"
+          invalid 'calc' step, right-hand side is{indentD m!"{rhs} : {rhsTy}"}\n\
+          but is expected to be{indentD m!"{erhs} : {erhsTy}"}"
         failed := true
       if failed then
         throwAbortTerm

src/Lean/Elab/CheckTactic.lean

@@ -38,6 +38,7 @@ def elabCheckTactic : CommandElab := fun stx => do
       | [next] => do
         let (val, _, _) ← matchCheckGoalType stx (←next.getType)
         if !(← Meta.withReducible <| isDefEq val expTerm) then
+          let (val, expTerm) ← addPPExplicitToExposeDiff val expTerm
           throwErrorAt stx
             m!"Term reduces to{indentExpr val}\nbut is expected to reduce to {indentExpr expTerm}"
       | _ => do

src/Lean/Elab/Deriving.lean

@@ -16,3 +16,4 @@ import Lean.Elab.Deriving.FromToJson
 import Lean.Elab.Deriving.SizeOf
 import Lean.Elab.Deriving.Hashable
 import Lean.Elab.Deriving.Ord
+import Lean.Elab.Deriving.ToExpr

src/Lean/Elab/Deriving/ToExpr.lean

@@ -0,0 +1,237 @@
+/-
+Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Kyle Miller
+-/
+prelude
+import Lean.Meta.Transform
+import Lean.Elab.Deriving.Basic
+import Lean.Elab.Deriving.Util
+import Lean.ToLevel
+import Lean.ToExpr
+
+/-!
+# `ToExpr` deriving handler
+
+This module defines a `ToExpr` deriving handler for inductive types.
+It supports mutually inductive types as well.
+
+The `ToExpr` deriving handlers support universe level polymorphism, via the `Lean.ToLevel` class.
+To use `ToExpr` in places where there is universe polymorphism, make sure a `[ToLevel.{u}]` instance is available,
+though be aware that the `ToLevel` mechanism does not support `max` or `imax` expressions.
+
+Implementation note: this deriving handler was initially modeled after the `Repr` deriving handler, but
+1. we need to account for universe levels,
+2. the `ToExpr` class has two fields rather than one, and
+3. we don't handle structures specially.
+-/
+
+namespace Lean.Elab.Deriving.ToExpr
+
+open Lean Elab Parser.Term
+open Meta Command Deriving
+
+/--
+Given `args := #[e₁, e₂, …, eₙ]`, constructs the syntax `Expr.app (… (Expr.app (Expr.app f e₁) e₂) …) eₙ`.
+-/
+def mkAppNTerm (f : Term) (args : Array Term) : MetaM Term :=
+  args.foldlM (fun a b => ``(Expr.app $a $b)) f
+
+/-- Fixes the output of `mkInductiveApp` to explicitly reference universe levels. -/
+def updateIndType (indVal : InductiveVal) (t : Term) : TermElabM Term :=
+  let levels := indVal.levelParams.toArray.map mkIdent
+  match t with
+  | `(@$f $args*) => `(@$f.{$levels,*} $args*)
+  | _ => throwError "(internal error) expecting output of `mkInductiveApp`"
+
+/--
+Creates a term that evaluates to an expression representing the inductive type.
+Uses `toExpr` and `toTypeExpr` for the arguments to the type constructor.
+-/
+def mkToTypeExpr (indVal : InductiveVal) (argNames : Array Name) : TermElabM Term := do
+  let levels ← indVal.levelParams.toArray.mapM (fun u => `(Lean.toLevel.{$(mkIdent u)}))
+  forallTelescopeReducing indVal.type fun xs _ => do
+    let mut args : Array Term := #[]
+    for argName in argNames, x in xs do
+      let a := mkIdent argName
+      if ← Meta.isType x then
+        args := args.push <| ← ``(toTypeExpr $a)
+      else
+        args := args.push <| ← ``(toExpr $a)
+    mkAppNTerm (← ``(Expr.const $(quote indVal.name) [$levels,*])) args
+
+/--
+Creates the body of the `toExpr` function for the `ToExpr` instance, which is a `match` expression
+that calls `toExpr` and `toTypeExpr` to assemble an expression for a given term.
+For recursive inductive types, `auxFunName` refers to the `ToExpr` instance for the current type.
+For mutually recursive types, we rely on the local instances set up by `mkLocalInstanceLetDecls`.
+-/
+def mkToExprBody (header : Header) (indVal : InductiveVal) (auxFunName : Name) (levelInsts : Array Term) :
+    TermElabM Term := do
+  let discrs ← mkDiscrs header indVal
+  let alts ← mkAlts
+  `(match $[$discrs],* with $alts:matchAlt*)
+where
+  /-- Create the `match` cases, one per constructor. -/
+  mkAlts : TermElabM (Array (TSyntax ``matchAlt)) := do
+    let levels ← levelInsts.mapM fun inst => `($(inst).toLevel)
+    let mut alts := #[]
+    for ctorName in indVal.ctors do
+      let ctorInfo ← getConstInfoCtor ctorName
+      let alt ← forallTelescopeReducing ctorInfo.type fun xs _ => do
+        let mut patterns := #[]
+        -- add `_` pattern for indices, before the constructor's pattern
+        for _ in [:indVal.numIndices] do
+          patterns := patterns.push (← `(_))
+        let mut ctorArgs := #[]
+        let mut rhsArgs : Array Term := #[]
+        let mkArg (x : Expr) (a : Term) : TermElabM Term := do
+          if (← inferType x).isAppOf indVal.name then
+            `($(mkIdent auxFunName) $levelInsts* $a)
+          else if ← Meta.isType x then
+            ``(toTypeExpr $a)
+          else
+            ``(toExpr $a)
+        -- add `_` pattern for inductive parameters, which are inaccessible
+        for i in [:ctorInfo.numParams] do
+          let a := mkIdent header.argNames[i]!
+          ctorArgs := ctorArgs.push (← `(_))
+          rhsArgs := rhsArgs.push <| ← mkArg xs[i]! a
+        for i in [:ctorInfo.numFields] do
+          let a := mkIdent (← mkFreshUserName `a)
+          ctorArgs := ctorArgs.push a
+          rhsArgs := rhsArgs.push <| ← mkArg xs[ctorInfo.numParams + i]! a
+        patterns := patterns.push (← `(@$(mkIdent ctorName):ident $ctorArgs:term*))
+        let rhs : Term ← mkAppNTerm (← ``(Expr.const $(quote ctorInfo.name) [$levels,*])) rhsArgs
+        `(matchAltExpr| | $[$patterns:term],* => $rhs)
+      alts := alts.push alt
+    return alts
+
+/--
+For nested and mutually recursive inductive types, we define `partial` instances,
+and the strategy is to have local `ToExpr` instances in scope for the body of each instance.
+This way, each instance can freely use `toExpr` and `toTypeExpr` for each of the types in `ctx`.
+
+This is a modified copy of `Lean.Elab.Deriving.mkLocalInstanceLetDecls`,
+since we need to include the `toTypeExpr` field in the `letDecl`
+Note that, for simplicity, each instance gets its own definition of each others' `toTypeExpr` fields.
+These are very simple fields, so avoiding the duplication is not worth it.
+-/
+def mkLocalInstanceLetDecls (ctx : Deriving.Context) (argNames : Array Name) (levelInsts : Array Term) :
+    TermElabM (Array (TSyntax ``Parser.Term.letDecl)) := do
+  let mut letDecls := #[]
+  for indVal in ctx.typeInfos, auxFunName in ctx.auxFunNames do
+    let currArgNames ← mkInductArgNames indVal
+    let numParams    := indVal.numParams
+    let currIndices  := currArgNames[numParams:]
+    let binders      ← mkImplicitBinders currIndices
+    let argNamesNew  := argNames[:numParams] ++ currIndices
+    let indType      ← mkInductiveApp indVal argNamesNew
+    let instName     ← mkFreshUserName `localinst
+    let toTypeExpr   ← mkToTypeExpr indVal argNames
+    -- Recall that mutually inductive types all use the same universe levels, hence we pass the same ToLevel instances to each aux function.
+    let letDecl      ← `(Parser.Term.letDecl| $(mkIdent instName):ident $binders:implicitBinder* : ToExpr $indType :=
+                          { toExpr     := $(mkIdent auxFunName) $levelInsts*,
+                            toTypeExpr := $toTypeExpr })
+    letDecls := letDecls.push letDecl
+  return letDecls
+
+open TSyntax.Compat in
+/--
+Makes a `toExpr` function for the given inductive type.
+The implementation of each `toExpr` function for a (mutual) inductive type is given as top-level private definitions.
+These are assembled into `ToExpr` instances in `mkInstanceCmds`.
+For mutual/nested inductive types, then each of the types' `ToExpr` instances are provided as local instances,
+to wire together the recursion (necessitating these auxiliary definitions being `partial`).
+-/
+def mkAuxFunction (ctx : Deriving.Context) (i : Nat) : TermElabM Command := do
+  let auxFunName := ctx.auxFunNames[i]!
+  let indVal     := ctx.typeInfos[i]!
+  let header     ← mkHeader ``ToExpr 1 indVal
+  /- We make the `ToLevel` instances be explicit here so that we can pass the instances from the instances to the
+     aux functions. This lets us ensure universe level variables are being lined up,
+     without needing to use `ident.{u₁,…,uₙ}` syntax, which could conditionally be incorrect
+     depending on the ambient CommandElabM scope state.
+     TODO(kmill): deriving handlers should run in a scope with no `universes` or `variables`. -/
+  let (toLevelInsts, levelBinders) := Array.unzip <| ← indVal.levelParams.toArray.mapM fun u => do
+    let inst := mkIdent (← mkFreshUserName `inst)
+    return (inst, ← `(explicitBinderF| ($inst : ToLevel.{$(mkIdent u)})))
+  let mut body ← mkToExprBody header indVal auxFunName toLevelInsts
+  if ctx.usePartial then
+    let letDecls ← mkLocalInstanceLetDecls ctx header.argNames toLevelInsts
+    body ← mkLet letDecls body
+  /- We need to alter the last binder (the one for the "target") to have explicit universe levels
+     so that the `ToLevel` instance arguments can use them. -/
+  let addLevels binder :=
+    match binder with
+    | `(bracketedBinderF| ($a : $ty)) => do `(bracketedBinderF| ($a : $(← updateIndType indVal ty)))
+    | _ => throwError "(internal error) expecting inst binder"
+  let binders := header.binders.pop ++ levelBinders ++ #[← addLevels header.binders.back!]
+  if ctx.usePartial then
+    `(private partial def $(mkIdent auxFunName):ident $binders:bracketedBinder* : Expr := $body:term)
+  else
+    `(private         def $(mkIdent auxFunName):ident $binders:bracketedBinder* : Expr := $body:term)
+
+/--
+Creates all the auxiliary functions (using `mkAuxFunction`) for the (mutual) inductive type(s).
+Wraps the resulting definition commands in `mutual ... end`.
+-/
+def mkAuxFunctions (ctx : Deriving.Context) : TermElabM Syntax := do
+  let mut auxDefs := #[]
+  for i in [:ctx.typeInfos.size] do
+    auxDefs := auxDefs.push (← mkAuxFunction ctx i)
+  `(mutual $auxDefs:command* end)
+
+open TSyntax.Compat in
+/--
+Assuming all of the auxiliary definitions exist,
+creates all the `instance` commands for the `ToExpr` instances for the (mutual) inductive type(s).
+This is a modified copy of `Lean.Elab.Deriving.mkInstanceCmds` to account for `ToLevel` instances.
+-/
+def mkInstanceCmds (ctx : Deriving.Context) (typeNames : Array Name) :
+    TermElabM (Array Command) := do
+  let mut instances := #[]
+  for indVal in ctx.typeInfos, auxFunName in ctx.auxFunNames do
+    if typeNames.contains indVal.name then
+      let argNames     ← mkInductArgNames indVal
+      let binders      ← mkImplicitBinders argNames
+      let binders      := binders ++ (← mkInstImplicitBinders ``ToExpr indVal argNames)
+      let (toLevelInsts, levelBinders) := Array.unzip <| ← indVal.levelParams.toArray.mapM fun u => do
+        let inst := mkIdent (← mkFreshUserName `inst)
+        return (inst, ← `(instBinderF| [$inst : ToLevel.{$(mkIdent u)}]))
+      let binders      := binders ++ levelBinders
+      let indType      ← updateIndType indVal (← mkInductiveApp indVal argNames)
+      let toTypeExpr   ← mkToTypeExpr indVal argNames
+      let instCmd ← `(instance $binders:implicitBinder* : ToExpr $indType where
+                        toExpr := $(mkIdent auxFunName) $toLevelInsts*
+                        toTypeExpr := $toTypeExpr)
+      instances := instances.push instCmd
+  return instances
+
+/--
+Returns all the commands necessary to construct the `ToExpr` instances.
+-/
+def mkToExprInstanceCmds (declNames : Array Name) : TermElabM (Array Syntax) := do
+  let ctx ← mkContext "toExpr" declNames[0]!
+  let cmds := #[← mkAuxFunctions ctx] ++ (← mkInstanceCmds ctx declNames)
+  trace[Elab.Deriving.toExpr] "\n{cmds}"
+  return cmds
+
+/--
+The main entry point to the `ToExpr` deriving handler.
+-/
+def mkToExprInstanceHandler (declNames : Array Name) : CommandElabM Bool := do
+  if (← declNames.allM isInductive) && declNames.size > 0 then
+    let cmds ← withFreshMacroScope <| liftTermElabM <| mkToExprInstanceCmds declNames
+    -- Enable autoimplicits, used for universe levels.
+    withScope (fun scope => { scope with opts := autoImplicit.set scope.opts true }) do
+      elabCommand (mkNullNode cmds)
+    return true
+  else
+    return false
+
+builtin_initialize
+  registerDerivingHandler ``Lean.ToExpr mkToExprInstanceHandler
+  registerTraceClass `Elab.Deriving.toExpr
+
+end Lean.Elab.Deriving.ToExpr

src/Lean/Elab/Structure.lean

@@ -691,6 +691,9 @@ private def addProjections (r : ElabHeaderResult) (fieldInfos : Array StructFiel
   let env ← getEnv
   let env ← ofExceptKernelException (mkProjections env r.view.declName projNames.toList r.view.isClass)
   setEnv env
+  for fieldInfo in fieldInfos do
+    if fieldInfo.isSubobject then
+      addDeclarationRangesFromSyntax fieldInfo.declName r.view.ref fieldInfo.ref
 
 private def registerStructure (structName : Name) (infos : Array StructFieldInfo) : TermElabM Unit := do
   let fields ← infos.filterMapM fun info => do
@@ -775,14 +778,14 @@ private def setSourceInstImplicit (type : Expr) : Expr :=
 /--
 Creates a projection function to a non-subobject parent.
 -/
-private partial def mkCoercionToCopiedParent (levelParams : List Name) (params : Array Expr) (view : StructView) (source : Expr) (parentStructName : Name) (parentType : Expr) : MetaM StructureParentInfo := do
+private partial def mkCoercionToCopiedParent (levelParams : List Name) (params : Array Expr) (view : StructView) (source : Expr) (parent : StructParentInfo) (parentType : Expr) : MetaM StructureParentInfo := do
   let isProp ← Meta.isProp parentType
   let env ← getEnv
   let structName := view.declName
   let sourceFieldNames := getStructureFieldsFlattened env structName
-  let binfo := if view.isClass && isClass env parentStructName then BinderInfo.instImplicit else BinderInfo.default
+  let binfo := if view.isClass && isClass env parent.structName then BinderInfo.instImplicit else BinderInfo.default
   let mut declType ← instantiateMVars (← mkForallFVars params (← mkForallFVars #[source] parentType))
-  if view.isClass && isClass env parentStructName then
+  if view.isClass && isClass env parent.structName then
     declType := setSourceInstImplicit declType
   declType := declType.inferImplicit params.size true
   let rec copyFields (parentType : Expr) : MetaM Expr := do
@@ -823,7 +826,8 @@ private partial def mkCoercionToCopiedParent (levelParams : List Name) (params :
   -- (Instances will get instance reducibility in `Lean.Elab.Command.addParentInstances`.)
   if !binfo.isInstImplicit && !(← Meta.isProp parentType) then
     setReducibleAttribute declName
-  return { structName := parentStructName, subobject := false, projFn := declName }
+  addDeclarationRangesFromSyntax declName view.ref parent.ref
+  return { structName := parent.structName, subobject := false, projFn := declName }
 
 private def mkRemainingProjections (levelParams : List Name) (params : Array Expr) (view : StructView)
     (parents : Array StructParentInfo) (fieldInfos : Array StructFieldInfo) : TermElabM (Array StructureParentInfo) := do
@@ -844,7 +848,7 @@ private def mkRemainingProjections (levelParams : List Name) (params : Array Exp
           pure { structName := parent.structName, subobject := true, projFn := info.declName }
         else
           let parent_type := (← instantiateMVars parent.type).replace fun e => parentFVarToConst[e]?
-          mkCoercionToCopiedParent levelParams params view source parent.structName parent_type)
+          mkCoercionToCopiedParent levelParams params view source parent parent_type)
       parentInfos := parentInfos.push parentInfo
       if let some fvar := parent.fvar? then
         parentFVarToConst := parentFVarToConst.insert fvar <|

src/Lean/Elab/Tactic.lean

@@ -44,3 +44,5 @@ import Lean.Elab.Tactic.DiscrTreeKey
 import Lean.Elab.Tactic.BVDecide
 import Lean.Elab.Tactic.BoolToPropSimps
 import Lean.Elab.Tactic.Classical
+import Lean.Elab.Tactic.Grind
+import Lean.Elab.Tactic.Monotonicity

src/Lean/Elab/Tactic/BVDecide/Frontend/BVDecide/Reflect.lean

@@ -82,7 +82,7 @@ instance : ToExpr Gate where
     | .and => mkConst ``Gate.and
     | .xor => mkConst ``Gate.xor
     | .beq => mkConst ``Gate.beq
-    | .imp => mkConst ``Gate.imp
+    | .or => mkConst ``Gate.or
   toTypeExpr := mkConst ``Gate
 
 instance : ToExpr BVPred where

src/Lean/Elab/Tactic/BVDecide/Frontend/BVDecide/ReifiedBVLogical.lean

@@ -91,7 +91,7 @@ where
     | .and => ``Std.Tactic.BVDecide.Reflect.Bool.and_congr
     | .xor => ``Std.Tactic.BVDecide.Reflect.Bool.xor_congr
     | .beq => ``Std.Tactic.BVDecide.Reflect.Bool.beq_congr
-    | .imp => ``Std.Tactic.BVDecide.Reflect.Bool.imp_congr
+    | .or => ``Std.Tactic.BVDecide.Reflect.Bool.or_congr
 
 /--
 Construct the reified version of `Bool.not subExpr`.
@@ -136,7 +136,7 @@ def mkIte (discr lhs rhs : ReifiedBVLogical) (discrExpr lhsExpr rhsExpr : Expr)
         lhsEvalExpr lhsProof?
         rhsEvalExpr rhsProof? | return none
     return mkApp9
-      (mkConst ``Std.Tactic.BVDecide.Reflect.Bool.ite_congr)
+      (mkConst ``Std.Tactic.BVDecide.Reflect.Bool.cond_congr)
       discrExpr lhsExpr rhsExpr
       discrEvalExpr lhsEvalExpr rhsEvalExpr
       discrProof lhsProof rhsProof

src/Lean/Elab/Tactic/BVDecide/Frontend/BVDecide/ReifiedLemmas.lean

@@ -22,67 +22,70 @@ This function adds the two lemmas:
 - `discrExpr = false → atomExpr = rhsExpr`
 It assumes that `discrExpr`, `lhsExpr` and `rhsExpr` are the expressions corresponding to `discr`,
 `lhs` and `rhs`. Furthermore it assumes that `atomExpr` is of the form
-`if discrExpr = true then lhsExpr else rhsExpr`.
+`bif discrExpr then lhsExpr else rhsExpr`.
 -/
-def addIfLemmas (discr : ReifiedBVLogical) (atom lhs rhs : ReifiedBVExpr)
+def addCondLemmas (discr : ReifiedBVLogical) (atom lhs rhs : ReifiedBVExpr)
     (discrExpr atomExpr lhsExpr rhsExpr : Expr) : LemmaM Unit := do
-  let some trueLemma ← mkIfTrueLemma discr atom lhs rhs discrExpr atomExpr lhsExpr rhsExpr | return ()
+  let some trueLemma ← mkCondTrueLemma discr atom lhs discrExpr atomExpr lhsExpr rhsExpr | return ()
   LemmaM.addLemma trueLemma
-  let some falseLemma ← mkIfFalseLemma discr atom lhs rhs discrExpr atomExpr lhsExpr rhsExpr | return ()
+  let some falseLemma ← mkCondFalseLemma discr atom rhs discrExpr atomExpr lhsExpr rhsExpr | return ()
   LemmaM.addLemma falseLemma
 where
-  mkIfTrueLemma (discr : ReifiedBVLogical) (atom lhs rhs : ReifiedBVExpr)
-      (discrExpr atomExpr lhsExpr rhsExpr : Expr) : M (Option SatAtBVLogical) :=
-    mkIfLemma true discr atom lhs rhs discrExpr atomExpr lhsExpr rhsExpr
-
-  mkIfFalseLemma (discr : ReifiedBVLogical) (atom lhs rhs : ReifiedBVExpr)
-      (discrExpr atomExpr lhsExpr rhsExpr : Expr) : M (Option SatAtBVLogical) :=
-    mkIfLemma false discr atom lhs rhs discrExpr atomExpr lhsExpr rhsExpr
-
-  mkIfLemma (discrVal : Bool) (discr : ReifiedBVLogical) (atom lhs rhs : ReifiedBVExpr)
+  mkCondTrueLemma (discr : ReifiedBVLogical) (atom lhs : ReifiedBVExpr)
       (discrExpr atomExpr lhsExpr rhsExpr : Expr) : M (Option SatAtBVLogical) := do
-    let resExpr := if discrVal then lhsExpr else rhsExpr
-    let resValExpr := if discrVal then lhs else rhs
-    let lemmaName :=
-      if discrVal then
-        ``Std.Tactic.BVDecide.Reflect.BitVec.if_true
-      else
-        ``Std.Tactic.BVDecide.Reflect.BitVec.if_false
-    let discrValExpr := toExpr discrVal
-    let discrVal ← ReifiedBVLogical.mkBoolConst discrVal
+    let resExpr := lhsExpr
+    let resValExpr := lhs
+    let lemmaName := ``Std.Tactic.BVDecide.Reflect.BitVec.cond_true
 
-    let eqDiscrExpr ← mkAppM ``BEq.beq #[discrExpr, discrValExpr]
-    let eqDiscr ← ReifiedBVLogical.mkGate discr discrVal discrExpr discrValExpr .beq
+
+    let notDiscrExpr := mkApp (mkConst ``Bool.not) discrExpr
+    let notDiscr ← ReifiedBVLogical.mkNot discr discrExpr
 
     let eqBVExpr ← mkAppM ``BEq.beq #[atomExpr, resExpr]
     let some eqBVPred ← ReifiedBVPred.mkBinPred atom resValExpr atomExpr resExpr .eq | return none
     let eqBV ← ReifiedBVLogical.ofPred eqBVPred
 
-    let imp ← ReifiedBVLogical.mkGate eqDiscr eqBV eqDiscrExpr eqBVExpr .imp
+    let imp ← ReifiedBVLogical.mkGate notDiscr eqBV notDiscrExpr eqBVExpr .or
 
     let proof := do
       let evalExpr ← ReifiedBVLogical.mkEvalExpr imp.expr
       let congrProof := (← imp.evalsAtAtoms).getD (ReifiedBVLogical.mkRefl evalExpr)
       let lemmaProof := mkApp4 (mkConst lemmaName) (toExpr lhs.width) discrExpr lhsExpr rhsExpr
 
-      let trueExpr := mkConst ``Bool.true
-      let eqDiscrTrueExpr ← mkEq eqDiscrExpr trueExpr
-      let eqBVExprTrueExpr ← mkEq eqBVExpr trueExpr
-      let impExpr ← mkArrow eqDiscrTrueExpr eqBVExprTrueExpr
-      -- construct a `Decidable` instance for the implication using forall_prop_decidable
-      let decEqDiscrTrue := mkApp2 (mkConst ``instDecidableEqBool) eqDiscrExpr trueExpr
-      let decEqBVExprTrue := mkApp2 (mkConst ``instDecidableEqBool) eqBVExpr trueExpr
-      let impDecidable := mkApp4 (mkConst ``forall_prop_decidable)
-        eqDiscrTrueExpr
-        (.lam .anonymous eqDiscrTrueExpr eqBVExprTrueExpr .default)
-        decEqDiscrTrue
-        (.lam .anonymous eqDiscrTrueExpr decEqBVExprTrue .default)
-
-      let decideImpExpr := mkApp2 (mkConst ``Decidable.decide) impExpr impDecidable
+      -- !discr || (atom == rhs)
+      let impExpr := mkApp2 (mkConst ``Bool.or) notDiscrExpr eqBVExpr
 
       return mkApp4
         (mkConst ``Std.Tactic.BVDecide.Reflect.Bool.lemma_congr)
-        decideImpExpr
+        impExpr
+        evalExpr
+        congrProof
+        lemmaProof
+    return some ⟨imp.bvExpr, proof, imp.expr⟩
+
+  mkCondFalseLemma (discr : ReifiedBVLogical) (atom rhs : ReifiedBVExpr)
+      (discrExpr atomExpr lhsExpr rhsExpr : Expr) : M (Option SatAtBVLogical) := do
+    let resExpr := rhsExpr
+    let resValExpr := rhs
+    let lemmaName := ``Std.Tactic.BVDecide.Reflect.BitVec.cond_false
+
+    let eqBVExpr ← mkAppM ``BEq.beq #[atomExpr, resExpr]
+    let some eqBVPred ← ReifiedBVPred.mkBinPred atom resValExpr atomExpr resExpr .eq | return none
+    let eqBV ← ReifiedBVLogical.ofPred eqBVPred
+
+    let imp ← ReifiedBVLogical.mkGate discr eqBV discrExpr eqBVExpr .or
+
+    let proof := do
+      let evalExpr ← ReifiedBVLogical.mkEvalExpr imp.expr
+      let congrProof := (← imp.evalsAtAtoms).getD (ReifiedBVLogical.mkRefl evalExpr)
+      let lemmaProof := mkApp4 (mkConst lemmaName) (toExpr rhs.width) discrExpr lhsExpr rhsExpr
+
+      -- discr || (atom == rhs)
+      let impExpr := mkApp2 (mkConst ``Bool.or) discrExpr eqBVExpr
+
+      return mkApp4
+        (mkConst ``Std.Tactic.BVDecide.Reflect.Bool.lemma_congr)
+        impExpr
         evalExpr
         congrProof
         lemmaProof

src/Lean/Elab/Tactic/BVDecide/Frontend/BVDecide/Reify.lean

@@ -220,15 +220,12 @@ where
         .rotateRight
         ``BVUnOp.rotateRight
         ``Std.Tactic.BVDecide.Reflect.BitVec.rotateRight_congr
-    | ite _ discrExpr _ lhsExpr rhsExpr =>
-      let_expr Eq α discrExpr val := discrExpr | return none
-      let_expr Bool := α | return none
-      let_expr Bool.true := val | return none
+    | cond _ discrExpr lhsExpr rhsExpr =>
       let some atom ← ReifiedBVExpr.bitVecAtom x true | return none
       let some discr ← ReifiedBVLogical.of discrExpr | return none
       let some lhs ← goOrAtom lhsExpr | return none
       let some rhs ← goOrAtom rhsExpr | return none
-      addIfLemmas discr atom lhs rhs discrExpr x lhsExpr rhsExpr
+      addCondLemmas discr atom lhs rhs discrExpr x lhsExpr rhsExpr
       return some atom
     | _ => return none
 
@@ -392,10 +389,7 @@ where
       | Bool => gateReflection lhsExpr rhsExpr .beq
       | BitVec _ => goPred t
       | _ => return none
-    | ite _ discrExpr _ lhsExpr rhsExpr =>
-      let_expr Eq α discrExpr val := discrExpr | return none
-      let_expr Bool := α | return none
-      let_expr Bool.true := val | return none
+    | cond _ discrExpr lhsExpr rhsExpr =>
       let some discr ← goOrAtom discrExpr | return none
       let some lhs ← goOrAtom lhsExpr | return none
       let some rhs ← goOrAtom rhsExpr | return none

src/Lean/Elab/Tactic/BVDecide/Frontend/Normalize.lean

@@ -28,6 +28,18 @@ namespace Frontend.Normalize
 open Lean.Meta
 open Std.Tactic.BVDecide.Normalize
 
+builtin_simproc ↓ [bv_normalize] reduceCond (cond _ _ _) := fun e => do
+  let_expr f@cond α c tb eb := e | return .continue
+  let r ← Simp.simp c
+  if r.expr.cleanupAnnotations.isConstOf ``Bool.true then
+    let pr := mkApp (mkApp4 (mkConst ``Bool.cond_pos f.constLevels!) α c tb eb) (← r.getProof)
+    return .visit { expr := tb, proof? := pr }
+  else if r.expr.cleanupAnnotations.isConstOf ``Bool.false then
+    let pr := mkApp (mkApp4 (mkConst ``Bool.cond_neg f.constLevels!) α c tb eb) (← r.getProof)
+    return .visit { expr := eb, proof? := pr }
+  else
+    return .continue
+
 builtin_simproc [bv_normalize] eqToBEq (((_ : Bool) = (_ : Bool))) := fun e => do
   let_expr Eq _ lhs rhs := e | return .continue
   match_expr rhs with
@@ -127,8 +139,6 @@ builtin_simproc [bv_normalize] bv_add_const' (((_ : BitVec _) + (_ : BitVec _))
       else
         return .continue
 
-attribute [builtin_bv_normalize_proc↓] reduceIte
-
 /-- Return a number `k` such that `2^k = n`. -/
 private def Nat.log2Exact (n : Nat) : Option Nat := do
   guard <| n ≠ 0

src/Lean/Elab/Tactic/Grind.lean

@@ -0,0 +1,69 @@
+/-
+Copyright (c) 2024 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
+-/
+prelude
+import Init.Grind.Tactics
+import Lean.Meta.Tactic.Grind
+import Lean.Elab.Command
+import Lean.Elab.Tactic.Basic
+import Lean.Elab.Tactic.Config
+
+namespace Lean.Elab.Tactic
+open Meta
+
+declare_config_elab elabGrindConfig Grind.Config
+
+open Command Term in
+@[builtin_command_elab Lean.Parser.Command.grindPattern]
+def elabGrindPattern : CommandElab := fun stx => do
+  match stx with
+  | `(grind_pattern $thmName:ident => $terms,*) => do
+    liftTermElabM do
+      let declName ← resolveGlobalConstNoOverload thmName
+      discard <| addTermInfo thmName (← mkConstWithLevelParams declName)
+      let info ← getConstInfo declName
+      forallTelescope info.type fun xs _ => do
+        let patterns ← terms.getElems.mapM fun term => do
+          let pattern ← elabTerm term none
+          synthesizeSyntheticMVarsUsingDefault
+          let pattern ← instantiateMVars pattern
+          let pattern ← Grind.preprocessPattern pattern
+          return pattern.abstract xs
+        Grind.addEMatchTheorem declName xs.size patterns.toList
+  | _ => throwUnsupportedSyntax
+
+def grind (mvarId : MVarId) (config : Grind.Config) (mainDeclName : Name) (fallback : Grind.Fallback) : MetaM Unit := do
+  let mvarIds ← Grind.main mvarId config mainDeclName fallback
+  unless mvarIds.isEmpty do
+    throwError "`grind` failed\n{goalsToMessageData mvarIds}"
+
+private def elabFallback (fallback? : Option Term) : TermElabM (Grind.GoalM Unit) := do
+  let some fallback := fallback? | return (pure ())
+  let type := mkApp (mkConst ``Grind.GoalM) (mkConst ``Unit)
+  let value ← withLCtx {} {} do Term.elabTermAndSynthesize fallback type
+  let auxDeclName ← if let .const declName _ := value then
+    pure declName
+  else
+    let auxDeclName ← Term.mkAuxName `_grind_fallback
+    let decl := Declaration.defnDecl {
+      name := auxDeclName
+      levelParams := []
+      type, value, hints := .opaque, safety := .safe
+    }
+    addAndCompile decl
+    pure auxDeclName
+  unsafe evalConst (Grind.GoalM Unit) auxDeclName
+
+@[builtin_tactic Lean.Parser.Tactic.grind] def evalApplyRfl : Tactic := fun stx => do
+  match stx with
+  | `(tactic| grind $config:optConfig $[on_failure $fallback?]?) =>
+    let fallback ← elabFallback fallback?
+    logWarningAt stx "The `grind` tactic is experimental and still under development. Avoid using it in production projects"
+    let declName := (← Term.getDeclName?).getD `_grind
+    let config ← elabGrindConfig config
+    withMainContext do liftMetaFinishingTactic (grind · config declName fallback)
+  | _ => throwUnsupportedSyntax
+
+end Lean.Elab.Tactic

src/Lean/Elab/Tactic/Induction.lean

@@ -579,12 +579,25 @@ private def checkAltsOfOptInductionAlts (optInductionAlts : Syntax) : TacticM Un
           throwErrorAt alt "more than one wildcard alternative '| _ => ...' used"
         found := true
 
-def getInductiveValFromMajor (major : Expr) : TacticM InductiveVal :=
+def getInductiveValFromMajor (induction : Bool) (major : Expr) : TacticM InductiveVal :=
   liftMetaMAtMain fun mvarId => do
     let majorType ← inferType major
     let majorType ← whnf majorType
     matchConstInduct majorType.getAppFn
-      (fun _ => Meta.throwTacticEx `induction mvarId m!"major premise type is not an inductive type {indentExpr majorType}")
+      (fun _ => do
+        let tacticName := if induction then `induction else `cases
+        let mut hint := m!"\n\nExplanation: the '{tacticName}' tactic is for constructor-based reasoning \
+          as well as for applying custom {tacticName} principles with a 'using' clause or a registered '@[{tacticName}_eliminator]' theorem. \
+          The above type neither is an inductive type nor has a registered theorem."
+        if majorType.isProp then
+          hint := m!"{hint}\n\n\
+            Consider using the 'by_cases' tactic, which does true/false reasoning for propositions."
+        else if majorType.isType then
+          hint := m!"{hint}\n\n\
+            Type universes are not inductive types, and type-constructor-based reasoning is not possible. \
+            This is a strong limitation. According to Lean's underlying theory, the only provable distinguishing \
+            feature of types is their cardinalities."
+        Meta.throwTacticEx tacticName mvarId m!"major premise type is not an inductive type{indentExpr majorType}{hint}")
       (fun val _ => pure val)
 
 /--
@@ -627,7 +640,7 @@ private def getElimNameInfo (optElimId : Syntax) (targets : Array Expr) (inducti
         return ← getElimInfo elimName
     unless targets.size == 1 do
       throwError "eliminator must be provided when multiple targets are used (use 'using <eliminator-name>'), and no default eliminator has been registered using attribute `[eliminator]`"
-    let indVal ← getInductiveValFromMajor targets[0]!
+    let indVal ← getInductiveValFromMajor induction targets[0]!
     if induction && indVal.all.length != 1 then
       throwError "'induction' tactic does not support mutually inductive types, the eliminator '{mkRecName indVal.name}' has multiple motives"
     if induction && indVal.isNested then

src/Lean/Elab/Tactic/Monotonicity.lean

@@ -0,0 +1,223 @@
+/-
+Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Joachim Breitner
+-/
+prelude
+import Lean.Meta.Tactic.Split
+import Lean.Elab.RecAppSyntax
+import Lean.Elab.Tactic.Basic
+import Init.Internal.Order
+
+namespace Lean.Meta.Monotonicity
+
+open Lean Meta
+open Lean.Order
+
+partial def headBetaUnderLambda (f : Expr) : Expr := Id.run do
+  let mut f := f.headBeta
+  if f.isLambda then
+    while f.bindingBody!.isHeadBetaTarget do
+      f := f.updateLambda! f.bindingInfo! f.bindingDomain! f.bindingBody!.headBeta
+  return f
+
+
+/-- Environment extensions for monotonicity lemmas -/
+builtin_initialize monotoneExt :
+    SimpleScopedEnvExtension (Name × Array DiscrTree.Key) (DiscrTree Name) ←
+  registerSimpleScopedEnvExtension {
+    addEntry := fun dt (n, ks) => dt.insertCore ks n
+    initial := {}
+  }
+
+builtin_initialize registerBuiltinAttribute {
+  name := `partial_fixpoint_monotone
+  descr := "monotonicity theorem"
+  add := fun decl _ kind => MetaM.run' do
+    let declTy := (← getConstInfo decl).type
+    let (xs, _, targetTy) ← withReducible <| forallMetaTelescopeReducing declTy
+    let_expr monotone α inst_α β inst_β f := targetTy |
+      throwError "@[partial_fixpoint_monotone] attribute only applies to lemmas proving {.ofConstName ``monotone}"
+    let f := f.headBeta
+    let f ← if f.isLambda then pure f else etaExpand f
+    let f := headBetaUnderLambda f
+    lambdaBoundedTelescope f 1 fun _ e => do
+      let key ← withReducible <| DiscrTree.mkPath e
+      monotoneExt.add (decl, key) kind
+}
+
+/--
+Finds tagged monotonicity theorems of the form `monotone (fun x => e)`.
+-/
+def findMonoThms (e : Expr) : MetaM (Array Name) := do
+  (monotoneExt.getState (← getEnv)).getMatch e
+
+private def defaultFailK (f : Expr) (monoThms : Array Name) : MetaM α :=
+  let extraMsg := if monoThms.isEmpty then m!"" else
+    m!"Tried to apply {.andList (monoThms.toList.map (m!"'{·}'"))}, but failed."
+  throwError "Failed to prove monotonicity of:{indentExpr f}\n{extraMsg}"
+
+private def applyConst (goal : MVarId) (name : Name) : MetaM (List MVarId) := do
+  mapError (f := (m!"Could not apply {.ofConstName name}:{indentD ·}")) do
+    goal.applyConst name (cfg := { synthAssignedInstances := false})
+
+/--
+Base case for solveMonoStep: Handles goals of the form
+```
+monotone (fun f => f.1.2 x y)
+```
+
+It's tricky to solve them compositionally from the outside in, so here we construct the proof
+from the inside out.
+-/
+partial def solveMonoCall (α inst_α : Expr) (e : Expr) : MetaM (Option Expr) := do
+  if e.isApp && !e.appArg!.hasLooseBVars then
+    let some hmono ← solveMonoCall α inst_α e.appFn! | return none
+    let hmonoType ← inferType hmono
+    let_expr monotone _ _ _ inst _ := hmonoType | throwError "solveMonoCall {e}: unexpected type {hmonoType}"
+    let some inst ← whnfUntil inst ``instOrderPi | throwError "solveMonoCall {e}: unexpected instance {inst}"
+    let_expr instOrderPi γ δ inst ← inst | throwError "solveMonoCall {e}: whnfUntil failed?{indentExpr inst}"
+    return ← mkAppOptM ``monotone_apply #[γ, δ, α, inst_α, inst, e.appArg!, none, hmono]
+
+  if e.isProj then
+    let some hmono ← solveMonoCall α inst_α e.projExpr! | return none
+    let hmonoType ← inferType hmono
+    let_expr monotone _ _ _ inst _ := hmonoType | throwError "solveMonoCall {e}: unexpected type {hmonoType}"
+    let some inst ← whnfUntil inst ``instPartialOrderPProd | throwError "solveMonoCall {e}: unexpected instance {inst}"
+    let_expr instPartialOrderPProd β γ inst_β inst_γ ← inst | throwError "solveMonoCall {e}: whnfUntil failed?{indentExpr inst}"
+    let n := if e.projIdx! == 0 then ``monotone_pprod_fst else ``monotone_pprod_snd
+    return ← mkAppOptM n #[β, γ, α, inst_β, inst_γ, inst_α, none, hmono]
+
+  if e == .bvar 0 then
+    let hmono ← mkAppOptM ``monotone_id #[α, inst_α]
+    return some hmono
+
+  return none
+
+
+def solveMonoStep (failK : ∀ {α}, Expr → Array Name → MetaM α := @defaultFailK) (goal : MVarId) : MetaM (List MVarId) :=
+  goal.withContext do
+  trace[Elab.Tactic.monotonicity] "monotonicity at\n{goal}"
+  let type ← goal.getType
+  if type.isForall then
+    let (_, goal) ← goal.intro1P
+    return [goal]
+
+  match_expr type with
+  | monotone α inst_α β inst_β f =>
+    -- Ensure f is not headed by a redex and headed by at least one lambda, and clean some
+    -- redexes left by some of the lemmas we tend to apply
+    let f ← instantiateMVars f
+    let f := f.headBeta
+    let f ← if f.isLambda then pure f else etaExpand f
+    let f := headBetaUnderLambda f
+    let e := f.bindingBody!
+
+    -- No recursive calls left
+    if !e.hasLooseBVars then
+      return ← applyConst goal ``monotone_const
+
+    -- NB: `e` is now an open term.
+
+    -- Look through mdata
+    if e.isMData then
+      let f' := f.updateLambdaE! f.bindingDomain! e.mdataExpr!
+      let goal' ← mkFreshExprSyntheticOpaqueMVar (mkApp type.appFn! f')
+      goal.assign goal'
+      return [goal'.mvarId!]
+
+    -- Float letE to the environment
+    if let .letE n t v b _nonDep := e then
+      if t.hasLooseBVars || v.hasLooseBVars then
+        failK f #[]
+      let goal' ← withLetDecl n t v fun x => do
+        let b' := f.updateLambdaE! f.bindingDomain! (b.instantiate1 x)
+        let goal' ← mkFreshExprSyntheticOpaqueMVar (mkApp type.appFn! b')
+        goal.assign (← mkLetFVars #[x] goal')
+        pure goal'
+      return [goal'.mvarId!]
+
+    -- Float `letFun` to the environment.
+    -- `applyConst` tends to reduce the redex
+    match_expr e with
+    | letFun γ _ v b =>
+      if γ.hasLooseBVars || v.hasLooseBVars then
+        failK f #[]
+      let b' := f.updateLambdaE! f.bindingDomain! b
+      let p  ← mkAppOptM ``monotone_letFun #[α, β, γ, inst_α, inst_β, v, b']
+      let new_goals ← mapError (f := (m!"Could not apply {p}:{indentD ·}")) do
+        goal.apply p
+      let [new_goal] := new_goals
+          | throwError "Unexpected number of goals after {.ofConstName ``monotone_letFun}."
+      let (_, new_goal) ←
+        if b.isLambda then
+          new_goal.intro b.bindingName!
+        else
+          new_goal.intro1
+      return [new_goal]
+    | _ => pure ()
+
+    -- Handle lambdas, preserving the name of the binder
+    if e.isLambda then
+      let [new_goal] ← applyConst goal ``monotone_of_monotone_apply
+        | throwError "Unexpected number of goals after {.ofConstName ``monotone_of_monotone_apply}."
+      let (_, new_goal) ← new_goal.intro e.bindingName!
+      return [new_goal]
+
+    -- A recursive call directly here
+    if e.isBVar then
+      return ← applyConst goal ``monotone_id
+
+    -- A recursive call
+    if let some hmono ← solveMonoCall α inst_α e then
+      trace[Elab.Tactic.monotonicity] "Found recursive call {e}:{indentExpr hmono}"
+      unless ← goal.checkedAssign hmono do
+        trace[Elab.Tactic.monotonicity] "Failed to assign {hmono} : {← inferType hmono} to goal"
+        failK f #[]
+      return []
+
+    let monoThms ← withLocalDeclD `f f.bindingDomain! fun f =>
+      -- The discrimination tree does not like open terms
+      findMonoThms (e.instantiate1 f)
+    trace[Elab.Tactic.monotonicity] "Found monoThms: {monoThms.map MessageData.ofConstName}"
+    for monoThm in monoThms do
+      let new_goals? ← try
+        let new_goals ← applyConst goal monoThm
+        trace[Elab.Tactic.monotonicity] "Succeeded with {.ofConstName monoThm}"
+        pure (some new_goals)
+      catch e =>
+        trace[Elab.Tactic.monotonicity] "{e.toMessageData}"
+        pure none
+      if let some new_goals := new_goals? then
+        return new_goals
+
+    -- Split match-expressions
+    if let some info := isMatcherAppCore? (← getEnv) e then
+      let candidate ← id do
+        let args := e.getAppArgs
+        for i in [info.getFirstDiscrPos : info.getFirstDiscrPos + info.numDiscrs] do
+          if args[i]!.hasLooseBVars then
+            return false
+        return true
+      if candidate then
+        -- We could be even more deliberate here and use the `lifter` lemmas
+        -- for the match statements instead of the `split` tactic.
+        -- For now using `splitMatch` works fine.
+        return ← Split.splitMatch goal e
+
+    failK f monoThms
+  | _ =>
+    throwError "Unexpected goal:{goal}"
+
+partial def solveMono (failK : ∀ {α}, Expr → Array Name → MetaM α := defaultFailK) (goal : MVarId) : MetaM Unit := do
+  let new_goals ← solveMonoStep failK goal
+  new_goals.forM (solveMono failK)
+
+open Elab Tactic in
+@[builtin_tactic Lean.Order.monotonicity]
+def evalMonotonicity : Tactic := fun _stx =>
+  liftMetaTactic Lean.Meta.Monotonicity.solveMonoStep
+
+end Lean.Meta.Monotonicity
+
+builtin_initialize Lean.registerTraceClass `Elab.Tactic.monotonicity

src/Lean/Elab/Tactic/NormCast.lean

@@ -63,7 +63,7 @@ def isNumeral? (e : Expr) : Option (Expr × Nat) :=
   if e.isConstOf ``Nat.zero then
     (mkConst ``Nat, 0)
   else if let Expr.app (Expr.app (Expr.app (Expr.const ``OfNat.ofNat ..) α ..)
-      (Expr.lit (Literal.natVal n) ..) ..) .. := e then
+      (Expr.lit (Literal.natVal n) ..) ..) .. := e.consumeMData then
     some (α, n)
   else
     none

src/Lean/Expr.lean

@@ -769,6 +769,11 @@ opaque quickLt (a : @& Expr) (b : @& Expr) : Bool
 @[extern "lean_expr_lt"]
 opaque lt (a : @& Expr) (b : @& Expr) : Bool
 
+def quickComp (a b : Expr) : Ordering :=
+  if quickLt a b then .lt
+  else if quickLt b a then .gt
+  else .eq
+
 /--
 Return true iff `a` and `b` are alpha equivalent.
 Binder annotations are ignored.
@@ -1643,6 +1648,23 @@ def isFalse (e : Expr) : Bool :=
 def isTrue (e : Expr) : Bool :=
   e.cleanupAnnotations.isConstOf ``True
 
+/--
+`getForallArity type` returns the arity of a `forall`-type. This function consumes nested annotations,
+and performs pending beta reductions. It does **not** use whnf.
+Examples:
+- If `a` is `Nat`, `getForallArity a` returns `0`
+- If `a` is `Nat → Bool`, `getForallArity a` returns `1`
+-/
+partial def getForallArity : Expr → Nat
+  | .mdata _ b       => getForallArity b
+  | .forallE _ _ b _ => getForallArity b + 1
+  | e                =>
+    if e.isHeadBetaTarget then
+      getForallArity e.headBeta
+    else
+      let e' := e.cleanupAnnotations
+      if e != e' then getForallArity e' else 0
+
 /--
 Checks if an expression is a "natural number numeral in normal form",
 i.e. of type `Nat`, and explicitly of the form `OfNat.ofNat n`

src/Lean/Linter/MissingDocs.lean

@@ -4,6 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Mario Carneiro
 -/
 prelude
+import Lean.Parser.Syntax
 import Lean.Meta.Tactic.Simp.RegisterCommand
 import Lean.Elab.Command
 import Lean.Elab.SetOption

src/Lean/Meta/AppBuilder.lean

@@ -176,6 +176,14 @@ def mkEqOfHEq (h : Expr) : MetaM Expr := do
   | _ =>
     throwAppBuilderException ``eq_of_heq m!"heterogeneous equality proof expected{indentExpr h}"
 
+/-- Given `h : Eq a b`, returns a proof of `HEq a b`. -/
+def mkHEqOfEq (h : Expr) : MetaM Expr := do
+  let hType ← infer h
+  let some (α, a, b) := hType.eq?
+    | throwAppBuilderException ``heq_of_eq m!"equality proof expected{indentExpr h}"
+  let u ← getLevel α
+  return mkApp4 (mkConst ``heq_of_eq [u]) α a b h
+
 /--
 If `e` is `@Eq.refl α a`, return `a`.
 -/

src/Lean/Meta/Basic.lean

@@ -605,6 +605,9 @@ variable [MonadControlT MetaM n] [Monad n]
 @[inline] def modifyCache (f : Cache → Cache) : MetaM Unit :=
   modify fun { mctx, cache, zetaDeltaFVarIds, postponed, diag } => { mctx, cache := f cache, zetaDeltaFVarIds, postponed, diag }
 
+def resetCache : MetaM Unit :=
+  modifyCache fun _ => {}
+
 @[inline] def modifyInferTypeCache (f : InferTypeCache → InferTypeCache) : MetaM Unit :=
   modifyCache fun ⟨ic, c1, c2, c3, c4, c5⟩ => ⟨f ic, c1, c2, c3, c4, c5⟩
 
@@ -1777,9 +1780,9 @@ private def withMVarContextImp (mvarId : MVarId) (x : MetaM α) : MetaM α := do
   withLocalContextImp mvarDecl.lctx mvarDecl.localInstances x
 
 /--
-  Execute `x` using the given metavariable `LocalContext` and `LocalInstances`.
-  The type class resolution cache is flushed when executing `x` if its `LocalInstances` are
-  different from the current ones. -/
+Executes `x` using the given metavariable `LocalContext` and `LocalInstances`.
+The type class resolution cache is flushed when executing `x` if its `LocalInstances` are
+different from the current ones. -/
 def _root_.Lean.MVarId.withContext (mvarId : MVarId) : n α → n α :=
   mapMetaM <| withMVarContextImp mvarId
 
@@ -1789,13 +1792,25 @@ private def withMCtxImp (mctx : MetavarContext) (x : MetaM α) : MetaM α := do
   try x finally setMCtx mctx'
 
 /--
-  `withMCtx mctx k` replaces the metavariable context and then executes `k`.
-  The metavariable context is restored after executing `k`.
+`withMCtx mctx k` replaces the metavariable context and then executes `k`.
+The metavariable context is restored after executing `k`.
 
-  This method is used to implement the type class resolution procedure. -/
+This method is used to implement the type class resolution procedure. -/
 def withMCtx (mctx : MetavarContext) : n α → n α :=
   mapMetaM <| withMCtxImp mctx
 
+/--
+`withoutModifyingMCtx k` executes `k` and then restores the metavariable context.
+-/
+def withoutModifyingMCtx : n α → n α :=
+  mapMetaM fun x => do
+    let mctx ← getMCtx
+    try
+      x
+    finally
+      resetCache
+      setMCtx mctx
+
 @[inline] private def approxDefEqImp (x : MetaM α) : MetaM α :=
   withConfig (fun config => { config with foApprox := true, ctxApprox := true, quasiPatternApprox := true}) x
 

src/Lean/Meta/Check.lean

@@ -17,14 +17,6 @@ namespace Lean.Meta
 private def ensureType (e : Expr) : MetaM Unit := do
   discard <| getLevel e
 
-def throwLetTypeMismatchMessage {α} (fvarId : FVarId) : MetaM α := do
-  let lctx ← getLCtx
-  match lctx.find? fvarId with
-  | some (LocalDecl.ldecl _ _ _ t v _ _) => do
-    let vType ← inferType v
-    throwError "invalid let declaration, term{indentExpr v}\nhas type{indentExpr vType}\nbut is expected to have type{indentExpr t}"
-  | _ => unreachable!
-
 private def checkConstant (constName : Name) (us : List Level) : MetaM Unit := do
   let cinfo ← getConstInfo constName
   unless us.length == cinfo.levelParams.length do
@@ -177,6 +169,15 @@ where
     catch _ =>
       return (a, b)
 
+def throwLetTypeMismatchMessage {α} (fvarId : FVarId) : MetaM α := do
+  let lctx ← getLCtx
+  match lctx.find? fvarId with
+  | some (LocalDecl.ldecl _ _ _ t v _ _) => do
+    let vType ← inferType v
+    let (vType, t) ← addPPExplicitToExposeDiff vType t
+    throwError "invalid let declaration, term{indentExpr v}\nhas type{indentExpr vType}\nbut is expected to have type{indentExpr t}"
+  | _ => unreachable!
+
 /--
   Return error message "has type{givenType}\nbut is expected to have type{expectedType}"
 -/

src/Lean/Meta/ExprDefEq.lean

@@ -167,7 +167,7 @@ def isDefEqStringLit (s t : Expr) : MetaM LBool := do
   Remark: `n` may be 0. -/
 def isEtaUnassignedMVar (e : Expr) : MetaM Bool := do
   match e.etaExpanded? with
-  | some (Expr.mvar mvarId) =>
+  | some (.mvar mvarId) =>
     if (← mvarId.isReadOnlyOrSyntheticOpaque) then
       pure false
     else if (← mvarId.isAssigned) then
@@ -361,9 +361,9 @@ private partial def isDefEqBindingAux (lctx : LocalContext) (fvars : Array Expr)
     let fvars  := fvars.push (mkFVar fvarId)
     isDefEqBindingAux lctx fvars b₁ b₂ (ds₂.push d₂)
   match e₁, e₂ with
-  | Expr.forallE n d₁ b₁ _, Expr.forallE _ d₂ b₂ _ => process n d₁ d₂ b₁ b₂
-  | Expr.lam     n d₁ b₁ _, Expr.lam     _ d₂ b₂ _ => process n d₁ d₂ b₁ b₂
-  | _,                      _                      =>
+  | .forallE n d₁ b₁ _, .forallE _ d₂ b₂ _ => process n d₁ d₂ b₁ b₂
+  | .lam     n d₁ b₁ _, .lam     _ d₂ b₂ _ => process n d₁ d₂ b₁ b₂
+  | _,                  _                  =>
     withLCtx' lctx do
       isDefEqBindingDomain fvars ds₂ do
         Meta.isExprDefEqAux (e₁.instantiateRev fvars) (e₂.instantiateRev fvars)
@@ -1037,13 +1037,13 @@ def checkedAssignImpl (mvarId : MVarId) (val : Expr) : MetaM Bool := do
 
 private def processAssignmentFOApproxAux (mvar : Expr) (args : Array Expr) (v : Expr) : MetaM Bool :=
   match v with
-  | .mdata _ e   => processAssignmentFOApproxAux mvar args e
-  | Expr.app f a =>
+  | .mdata _ e => processAssignmentFOApproxAux mvar args e
+  | .app f a   =>
     if args.isEmpty then
       pure false
     else
       Meta.isExprDefEqAux args.back! a <&&> Meta.isExprDefEqAux (mkAppRange mvar 0 (args.size - 1) args) f
-  | _            => pure false
+  | _ => pure false
 
 /--
   Auxiliary method for applying first-order unification. It is an approximation.
@@ -1177,7 +1177,7 @@ private partial def processAssignment (mvarApp : Expr) (v : Expr) : MetaM Bool :
         let arg ← simpAssignmentArg arg
         let args := args.set i arg
         match arg with
-        | Expr.fvar fvarId =>
+        | .fvar fvarId =>
           if args[0:i].any fun prevArg => prevArg == arg then
             useFOApprox args
           else if mvarDecl.lctx.contains fvarId && !cfg.quasiPatternApprox then
@@ -1233,7 +1233,7 @@ private def processAssignment' (mvarApp : Expr) (v : Expr) : MetaM Bool := do
 
 private def isDeltaCandidate? (t : Expr) : MetaM (Option ConstantInfo) := do
   match t.getAppFn with
-  | Expr.const c _ =>
+  | .const c _ =>
     match (← getUnfoldableConst? c) with
     | r@(some info) => if info.hasValue then return r else return none
     | _             => return none
@@ -1375,8 +1375,8 @@ private def unfoldBothDefEq (fn : Name) (t s : Expr) : MetaM LBool := do
 
 private def sameHeadSymbol (t s : Expr) : Bool :=
   match t.getAppFn, s.getAppFn with
-  | Expr.const c₁ _, Expr.const c₂ _ => c₁ == c₂
-  | _,               _               => false
+  | .const c₁ _, .const c₂ _ => c₁ == c₂
+  | _,           _           => false
 
 /--
   - If headSymbol (unfold t) == headSymbol s, then unfold t
@@ -1521,8 +1521,8 @@ private def isDefEqDelta (t s : Expr) : MetaM LBool := do
       unfoldNonProjFnDefEq tInfo sInfo t s
 
 private def isAssigned : Expr → MetaM Bool
-  | Expr.mvar mvarId => mvarId.isAssigned
-  | _                => pure false
+  | .mvar mvarId => mvarId.isAssigned
+  | _            => pure false
 
 private def expandDelayedAssigned? (t : Expr) : MetaM (Option Expr) := do
   let tFn := t.getAppFn
@@ -1647,8 +1647,8 @@ private partial def isDefEqQuick (t s : Expr) : MetaM LBool :=
   | .sort u,       .sort v     => toLBoolM <| isLevelDefEqAux u v
   | .lam ..,       .lam ..     => if t == s then pure LBool.true else toLBoolM <| isDefEqBinding t s
   | .forallE ..,   .forallE .. => if t == s then pure LBool.true else toLBoolM <| isDefEqBinding t s
-  -- | Expr.mdata _ t _,    s                   => isDefEqQuick t s
-  -- | t,                   Expr.mdata _ s _    => isDefEqQuick t s
+  -- | .mdata _ t _, s               => isDefEqQuick t s
+  -- | t,            .mdata _ s _    => isDefEqQuick t s
   | .fvar fvarId₁, .fvar fvarId₂ => do
     if fvarId₁ == fvarId₂ then
       return .true

src/Lean/Meta/Tactic/Cases.lean

@@ -66,30 +66,31 @@ structure GeneralizeIndicesSubgoal where
   numEqs         : Nat
 
 /--
-  Similar to `generalizeTargets` but customized for the `casesOn` motive.
-  Given a metavariable `mvarId` representing the
-  ```
-  Ctx, h : I A j, D |- T
-  ```
-  where `fvarId` is `h`s id, and the type `I A j` is an inductive datatype where `A` are parameters,
-  and `j` the indices. Generate the goal
-  ```
-  Ctx, h : I A j, D, j' : J, h' : I A j' |- j == j' -> h == h' -> T
-  ```
-  Remark: `(j == j' -> h == h')` is a "telescopic" equality.
-  Remark: `j` is sequence of terms, and `j'` a sequence of free variables.
-  The result contains the fields
-  - `mvarId`: the new goal
-  - `indicesFVarIds`: `j'` ids
-  - `fvarId`: `h'` id
-  - `numEqs`: number of equations in the target -/
-def generalizeIndices (mvarId : MVarId) (fvarId : FVarId) : MetaM GeneralizeIndicesSubgoal :=
+Given a metavariable `mvarId` representing the goal
+```
+Ctx |- T
+```
+and an expression `e : I A j`, where `I A j` is an inductive datatype where `A` are parameters,
+and `j` the indices. Generate the goal
+```
+Ctx, j' : J, h' : I A j' |- j == j' -> e == h' -> T
+```
+Remark: `(j == j' -> e == h')` is a "telescopic" equality.
+Remark: `j` is sequence of terms, and `j'` a sequence of free variables.
+The result contains the fields
+- `mvarId`: the new goal
+- `indicesFVarIds`: `j'` ids
+- `fvarId`: `h'` id
+- `numEqs`: number of equations in the target
+
+If `varName?` is not none, it is used to name `h'`.
+-/
+def generalizeIndices' (mvarId : MVarId) (e : Expr) (varName? : Option Name := none) : MetaM GeneralizeIndicesSubgoal :=
   mvarId.withContext do
     let lctx       ← getLCtx
     let localInsts ← getLocalInstances
     mvarId.checkNotAssigned `generalizeIndices
-    let fvarDecl ← fvarId.getDecl
-    let type ← whnf fvarDecl.type
+    let type ← whnfD (← inferType e)
     type.withApp fun f args => matchConstInduct f (fun _ => throwTacticEx `generalizeIndices mvarId "inductive type expected") fun val _ => do
       unless val.numIndices > 0 do throwTacticEx `generalizeIndices mvarId "indexed inductive type expected"
       unless args.size == val.numIndices + val.numParams do throwTacticEx `generalizeIndices mvarId "ill-formed inductive datatype"
@@ -98,9 +99,10 @@ def generalizeIndices (mvarId : MVarId) (fvarId : FVarId) : MetaM GeneralizeIndi
       let IAType ← inferType IA
       forallTelescopeReducing IAType fun newIndices _ => do
       let newType := mkAppN IA newIndices
-      withLocalDeclD fvarDecl.userName newType fun h' =>
+      let varName ← if let some varName := varName? then pure varName else mkFreshUserName `x
+      withLocalDeclD varName newType fun h' =>
       withNewEqs indices newIndices fun newEqs newRefls => do
-      let (newEqType, newRefl) ← mkEqAndProof fvarDecl.toExpr h'
+      let (newEqType, newRefl) ← mkEqAndProof e h'
       let newRefls := newRefls.push newRefl
       withLocalDeclD `h newEqType fun newEq => do
       let newEqs := newEqs.push newEq
@@ -112,7 +114,7 @@ def generalizeIndices (mvarId : MVarId) (fvarId : FVarId) : MetaM GeneralizeIndi
       let auxType ← mkForallFVars newIndices auxType
       let newMVar ← mkFreshExprMVarAt lctx localInsts auxType MetavarKind.syntheticOpaque tag
       /- assign mvarId := newMVar indices h refls -/
-      mvarId.assign (mkAppN (mkApp (mkAppN newMVar indices) fvarDecl.toExpr) newRefls)
+      mvarId.assign (mkAppN (mkApp (mkAppN newMVar indices) e) newRefls)
       let (indicesFVarIds, newMVarId) ← newMVar.mvarId!.introNP newIndices.size
       let (fvarId, newMVarId) ← newMVarId.intro1P
       return {
@@ -122,6 +124,29 @@ def generalizeIndices (mvarId : MVarId) (fvarId : FVarId) : MetaM GeneralizeIndi
         numEqs         := newEqs.size
       }
 
+/--
+Similar to `generalizeTargets` but customized for the `casesOn` motive.
+Given a metavariable `mvarId` representing the
+```
+Ctx, h : I A j, D |- T
+```
+where `fvarId` is `h`s id, and the type `I A j` is an inductive datatype where `A` are parameters,
+and `j` the indices. Generate the goal
+```
+Ctx, h : I A j, D, j' : J, h' : I A j' |- j == j' -> h == h' -> T
+```
+Remark: `(j == j' -> h == h')` is a "telescopic" equality.
+Remark: `j` is sequence of terms, and `j'` a sequence of free variables.
+The result contains the fields
+- `mvarId`: the new goal
+- `indicesFVarIds`: `j'` ids
+- `fvarId`: `h'` id
+- `numEqs`: number of equations in the target -/
+def generalizeIndices (mvarId : MVarId) (fvarId : FVarId) : MetaM GeneralizeIndicesSubgoal :=
+  mvarId.withContext do
+    let fvarDecl ← fvarId.getDecl
+    generalizeIndices' mvarId fvarDecl.toExpr fvarDecl.userName
+
 structure CasesSubgoal extends InductionSubgoal where
   ctorName : Name
 

src/Lean/Meta/Tactic/Grind.lean

@@ -7,19 +7,47 @@ prelude
 import Lean.Meta.Tactic.Grind.Attr
 import Lean.Meta.Tactic.Grind.RevertAll
 import Lean.Meta.Tactic.Grind.Types
-import Lean.Meta.Tactic.Grind.Preprocessor
 import Lean.Meta.Tactic.Grind.Util
 import Lean.Meta.Tactic.Grind.Cases
 import Lean.Meta.Tactic.Grind.Injection
 import Lean.Meta.Tactic.Grind.Core
+import Lean.Meta.Tactic.Grind.Canon
+import Lean.Meta.Tactic.Grind.MarkNestedProofs
+import Lean.Meta.Tactic.Grind.Inv
+import Lean.Meta.Tactic.Grind.Proof
+import Lean.Meta.Tactic.Grind.Propagate
+import Lean.Meta.Tactic.Grind.PP
+import Lean.Meta.Tactic.Grind.Simp
+import Lean.Meta.Tactic.Grind.Ctor
+import Lean.Meta.Tactic.Grind.Parser
+import Lean.Meta.Tactic.Grind.EMatchTheorem
+import Lean.Meta.Tactic.Grind.EMatch
+import Lean.Meta.Tactic.Grind.Main
+
 
 namespace Lean
 
+/-! Trace options for `grind` users -/
 builtin_initialize registerTraceClass `grind
-builtin_initialize registerTraceClass `grind.eq
+builtin_initialize registerTraceClass `grind.assert
+builtin_initialize registerTraceClass `grind.eqc
+builtin_initialize registerTraceClass `grind.internalize
+builtin_initialize registerTraceClass `grind.ematch
+builtin_initialize registerTraceClass `grind.ematch.pattern
+builtin_initialize registerTraceClass `grind.ematch.pattern.search
+builtin_initialize registerTraceClass `grind.ematch.instance
+builtin_initialize registerTraceClass `grind.ematch.instance.assignment
 builtin_initialize registerTraceClass `grind.issues
-builtin_initialize registerTraceClass `grind.add
-builtin_initialize registerTraceClass `grind.pre
+builtin_initialize registerTraceClass `grind.simp
+
+/-! Trace options for `grind` developers -/
 builtin_initialize registerTraceClass `grind.debug
+builtin_initialize registerTraceClass `grind.debug.proofs
+builtin_initialize registerTraceClass `grind.debug.congr
+builtin_initialize registerTraceClass `grind.debug.proof
+builtin_initialize registerTraceClass `grind.debug.proj
+builtin_initialize registerTraceClass `grind.debug.parent
+builtin_initialize registerTraceClass `grind.debug.final
+builtin_initialize registerTraceClass `grind.debug.forallPropagator
 
 end Lean

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

@@ -0,0 +1,159 @@
+/-
+Copyright (c) 2024 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
+-/
+prelude
+import Init.Grind.Util
+import Lean.Meta.Basic
+import Lean.Meta.FunInfo
+import Lean.Util.FVarSubset
+import Lean.Util.PtrSet
+import Lean.Util.FVarSubset
+
+namespace Lean.Meta.Grind
+namespace Canon
+
+/-!
+A canonicalizer module for the `grind` tactic. The canonicalizer defined in `Meta/Canonicalizer.lean` is
+not suitable for the `grind` tactic. It was designed for tactics such as `omega`, where the goal is
+to detect when two structurally different atoms are definitionally equal.
+
+The `grind` tactic, on the other hand, uses congruence closure. Moreover, types, type formers, proofs, and instances
+are considered supporting elements and are not factored into congruence detection.
+
+This module minimizes the number of `isDefEq` checks by comparing two terms `a` and `b` only if they instances,
+types, or type formers and are the `i`-th arguments of two different `f`-applications. This approach is
+sufficient for the congruence closure procedure used by the `grind` tactic.
+
+To further optimize `isDefEq` checks, instances are compared using `TransparencyMode.instances`, which reduces
+the number of constants that need to be unfolded. If diagnostics are enabled, instances are compared using
+the default transparency mode too for sanity checking, and discrepancies are reported.
+Types and type formers are always checked using default transparency.
+
+Remark:
+The canonicalizer minimizes issues with non-canonical instances and structurally different but definitionally equal types,
+but it does not solve all problems. For example, consider a situation where we have `(a : BitVec n)`
+and `(b : BitVec m)`, along with instances `inst1 n : Add (BitVec n)` and `inst2 m : Add (BitVec m)` where `inst1`
+and `inst2` are structurally different. Now consider the terms `a + a` and `b + b`. After canonicalization, the two
+additions will still use structurally different (and definitionally different) instances: `inst1 n` and `inst2 m`.
+Furthermore, `grind` will not be able to infer that  `HEq (a + a) (b + b)` even if we add the assumptions `n = m` and `HEq a b`.
+-/
+
+structure State where
+  argMap     : PHashMap (Expr × Nat) (List Expr) := {}
+  canon      : PHashMap Expr Expr := {}
+  proofCanon : PHashMap Expr Expr := {}
+  deriving Inhabited
+
+/--
+Helper function for canonicalizing `e` occurring as the `i`th argument of an `f`-application.
+`isInst` is true if `e` is an type class instance.
+
+Recall that we use `TransparencyMode.instances` for checking whether two instances are definitionally equal or not.
+Thus, if diagnostics are enabled, we also check them using `TransparencyMode.default`. If the result is different
+we report to the user.
+-/
+def canonElemCore (f : Expr) (i : Nat) (e : Expr) (isInst : Bool) : StateT State MetaM Expr := do
+  let s ← get
+  if let some c := s.canon.find? e then
+    return c
+  let key := (f, i)
+  let cs := s.argMap.find? key |>.getD []
+  for c in cs do
+    if (← isDefEq e c) then
+      -- We used to check `c.fvarsSubset e` because it is not
+      -- in general safe to replace `e` with `c` if `c` has more free variables than `e`.
+      -- However, we don't revert previously canonicalized elements in the `grind` tactic.
+      modify fun s => { s with canon := s.canon.insert e c }
+      return c
+    if isInst then
+      if (← isDiagnosticsEnabled <&&> pure (c.fvarsSubset e) <&&> (withDefault <| isDefEq e c)) then
+        -- TODO: consider storing this information in some structure that can be browsed later.
+        trace[grind.issues] "the following `grind` static elements are definitionally equal with `default` transparency, but not with `instances` transparency{indentExpr e}\nand{indentExpr c}"
+  modify fun s => { s with canon := s.canon.insert e e, argMap := s.argMap.insert key (e::cs) }
+  return e
+
+abbrev canonType (f : Expr) (i : Nat) (e : Expr) := withDefault <| canonElemCore f i e false
+abbrev canonInst (f : Expr) (i : Nat) (e : Expr) := withReducibleAndInstances <| canonElemCore f i e true
+
+/--
+Return type for the `shouldCanon` function.
+-/
+private inductive ShouldCanonResult where
+  | /- Nested types (and type formers) are canonicalized. -/
+    canonType
+  | /- Nested instances are canonicalized. -/
+    canonInst
+  | /-
+    Term is not a proof, type (former), nor an instance.
+    Thus, it must be recursively visited by the canonizer.
+    -/
+    visit
+  deriving Inhabited
+
+/--
+See comments at `ShouldCanonResult`.
+-/
+def shouldCanon (pinfos : Array ParamInfo) (i : Nat) (arg : Expr) : MetaM ShouldCanonResult := do
+  if h : i < pinfos.size then
+    let pinfo := pinfos[i]
+    if pinfo.isInstImplicit then
+      return .canonInst
+    else if pinfo.isProp then
+      return .visit
+  if (← isTypeFormer arg) then
+    return .canonType
+  else
+    return .visit
+
+unsafe def canonImpl (e : Expr) : StateT State MetaM Expr := do
+  visit e |>.run' mkPtrMap
+where
+  visit (e : Expr) : StateRefT (PtrMap Expr Expr) (StateT State MetaM) Expr := do
+    unless e.isApp || e.isForall do return e
+    -- Check whether it is cached
+    if let some r := (← get).find? e then
+      return r
+    let e' ← match e with
+      | .app .. => e.withApp fun f args => do
+        if f.isConstOf ``Lean.Grind.nestedProof && args.size == 2 then
+          let prop := args[0]!
+          let prop' ← visit prop
+          if let some r := (← getThe State).proofCanon.find? prop' then
+            pure r
+          else
+            let e' := if ptrEq prop prop' then e else mkAppN f (args.set! 0 prop')
+            modifyThe State fun s => { s with proofCanon := s.proofCanon.insert prop' e' }
+            pure e'
+        else
+          let pinfos := (← getFunInfo f).paramInfo
+          let mut modified := false
+          let mut args := args
+          for i in [:args.size] do
+            let arg := args[i]!
+            let arg' ← match (← shouldCanon pinfos i arg) with
+            | .canonType  => canonType f i arg
+            | .canonInst  => canonInst f i arg
+            | .visit      => visit arg
+            unless ptrEq arg arg' do
+              args := args.set! i arg'
+              modified := true
+          pure <| if modified then mkAppN f args else e
+      | .forallE _ d b _ =>
+        -- Recall that we have `ForallProp.lean`.
+        let d' ← visit d
+        -- Remark: users may not want to convert `p → q` into `¬p ∨ q`
+        let b' ← if b.hasLooseBVars then pure b else visit b
+        pure <| e.updateForallE! d' b'
+      | _ => unreachable!
+    modify fun s => s.insert e e'
+    return e'
+
+/-- Canonicalizes nested types, type formers, and instances in `e`. -/
+def canon (e : Expr) : StateT State MetaM Expr :=
+  unsafe canonImpl e
+
+end Canon
+
+end Lean.Meta.Grind

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

@@ -11,28 +11,29 @@ namespace Lean.Meta.Grind
 The `grind` tactic includes an auxiliary `cases` tactic that is not intended for direct use by users.
 This method implements it.
 This tactic is automatically applied when introducing local declarations with a type tagged with `[grind_cases]`.
+It is also used for "case-splitting" on terms during the search.
+
 It differs from the user-facing Lean `cases` tactic in the following ways:
 
 - It avoids unnecessary `revert` and `intro` operations.
 
 - It does not introduce new local declarations for each minor premise. Instead, the `grind` tactic preprocessor is responsible for introducing them.
 
-- It assumes that the major premise (i.e., the parameter `fvarId`) is the latest local declaration in the current goal.
-
 - If the major premise type is an indexed family, auxiliary declarations and (heterogeneous) equalities are introduced.
   However, these equalities are not resolved using `unifyEqs`. Instead, the `grind` tactic employs union-find and
   congruence closure to process these auxiliary equalities. This approach avoids applying substitution to propositions
   that have already been internalized by `grind`.
 -/
-def cases (mvarId : MVarId) (fvarId : FVarId) : MetaM (List MVarId) := mvarId.withContext do
+def cases (mvarId : MVarId) (e : Expr) : MetaM (List MVarId) := mvarId.withContext do
   let tag ← mvarId.getTag
-  let type ← whnf (← fvarId.getType)
+  let type ← whnf (← inferType e)
   let .const declName _ := type.getAppFn | throwInductiveExpected type
   let .inductInfo _ ← getConstInfo declName | throwInductiveExpected type
   let recursorInfo ← mkRecursorInfo (mkCasesOnName declName)
-  let k (mvarId : MVarId) (fvarId : FVarId) (indices : Array Expr) (clearMajor : Bool) : MetaM (List MVarId) := do
-    let recursor ← mkRecursorAppPrefix mvarId `grind.cases fvarId recursorInfo indices
-    let mut recursor := mkApp (mkAppN recursor indices) (mkFVar fvarId)
+  let k (mvarId : MVarId) (fvarId : FVarId) (indices : Array FVarId) : MetaM (List MVarId) := do
+    let indicesExpr := indices.map mkFVar
+    let recursor ← mkRecursorAppPrefix mvarId `grind.cases fvarId recursorInfo indicesExpr
+    let mut recursor := mkApp (mkAppN recursor indicesExpr) (mkFVar fvarId)
     let mut recursorType ← inferType recursor
     let mut mvarIdsNew := #[]
     for _ in [:recursorInfo.numMinors] do
@@ -41,22 +42,22 @@ def cases (mvarId : MVarId) (fvarId : FVarId) : MetaM (List MVarId) := mvarId.wi
       recursorType := recursorTypeNew
       let mvar ← mkFreshExprSyntheticOpaqueMVar targetNew tag
       recursor := mkApp recursor mvar
-      let mvarIdNew ← if clearMajor then
-        mvar.mvarId!.clear fvarId
-      else
-        pure mvar.mvarId!
+      let mvarIdNew ← mvar.mvarId!.tryClearMany (indices.push fvarId)
       mvarIdsNew := mvarIdsNew.push mvarIdNew
     mvarId.assign recursor
     return mvarIdsNew.toList
   if recursorInfo.numIndices > 0 then
-    let s ← generalizeIndices mvarId fvarId
+    let s ← generalizeIndices' mvarId e
     s.mvarId.withContext do
-      k s.mvarId s.fvarId (s.indicesFVarIds.map mkFVar) (clearMajor := false)
+      k s.mvarId s.fvarId s.indicesFVarIds
+  else if let .fvar fvarId := e then
+    k mvarId fvarId #[]
   else
-    let indices ← getMajorTypeIndices mvarId `grind.cases recursorInfo type
-    k mvarId fvarId indices (clearMajor := true)
+    let mvarId ← mvarId.assert (← mkFreshUserName `x) type e
+    let (fvarId, mvarId) ← mvarId.intro1
+    mvarId.withContext do k mvarId fvarId #[]
 where
   throwInductiveExpected {α} (type : Expr) : MetaM α := do
-    throwTacticEx `grind.cases mvarId m!"(non-recursive) inductive type expected at {mkFVar fvarId}{indentExpr type}"
+    throwTacticEx `grind.cases mvarId m!"(non-recursive) inductive type expected at {e}{indentExpr type}"
 
 end Lean.Meta.Grind

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

@@ -4,144 +4,15 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Leonardo de Moura
 -/
 prelude
-import Lean.Meta.Tactic.Grind.Types
+import Init.Grind.Util
 import Lean.Meta.LitValues
+import Lean.Meta.Tactic.Grind.Types
+import Lean.Meta.Tactic.Grind.Inv
+import Lean.Meta.Tactic.Grind.PP
+import Lean.Meta.Tactic.Grind.Ctor
+import Lean.Meta.Tactic.Grind.Internalize
 
 namespace Lean.Meta.Grind
-/-- Helper function for pretty printing the state for debugging purposes. -/
-def ppENodeRef (e : Expr) : GoalM Format := do
-  let some n ← getENode? e | return "_"
-  return f!"#{n.idx}"
-
-/-- Returns expressions in the given expression equivalence class. -/
-partial def getEqc (e : Expr) : GoalM (List Expr) :=
-  go e e []
-where
-  go (first : Expr) (e : Expr) (acc : List Expr) : GoalM (List Expr) := do
-    let next ← getNext e
-    let acc := e :: acc
-    if isSameExpr first next then
-      return acc
-    else
-      go first next acc
-
-/-- Returns all equivalence classes in the current goal. -/
-partial def getEqcs : GoalM (List (List Expr)) := do
-  let mut r := []
-  for (_, node) in (← get).enodes do
-    if isSameExpr node.root node.self then
-      r := (← getEqc node.self) :: r
-  return r
-
-/-- Helper function for pretty printing the state for debugging purposes. -/
-def ppENodeDeclValue (e : Expr) : GoalM Format := do
-  if e.isApp && !(← isLitValue e) then
-    e.withApp fun f args => do
-      let r ← if f.isConst then
-        ppExpr f
-      else
-        ppENodeRef f
-      let mut r := r
-      for arg in args do
-        r := r ++ " " ++ (← ppENodeRef arg)
-      return r
-  else
-    ppExpr e
-
-/-- Helper function for pretty printing the state for debugging purposes. -/
-def ppENodeDecl (e : Expr) : GoalM Format := do
-  let mut r := f!"{← ppENodeRef e} := {← ppENodeDeclValue e}"
-  let n ← getENode e
-  unless isSameExpr e n.root do
-    r := r ++ f!" ↦ {← ppENodeRef n.root}"
-  if n.interpreted then
-    r := r ++ ", [val]"
-  if n.ctor then
-    r := r ++ ", [ctor]"
-  return r
-
-/-- Pretty print goal state for debugging purposes. -/
-def ppState : GoalM Format := do
-  let mut r := f!"Goal:"
-  let nodes := (← get).enodes.toArray.map (·.2)
-  let nodes := nodes.qsort fun a b => a.idx < b.idx
-  for node in nodes do
-    r := r ++ "\n" ++ (← ppENodeDecl node.self)
-  let eqcs ← getEqcs
-  for eqc in eqcs do
-    if eqc.length > 1 then
-      r := r ++ "\n" ++ "{" ++ (Format.joinSep (← eqc.mapM ppENodeRef) ", ") ++  "}"
-  return r
-
-/--
-Returns `true` if `e` is `True`, `False`, or a literal value.
-See `LitValues` for supported literals.
--/
-def isInterpreted (e : Expr) : MetaM Bool := do
-  if e.isTrue || e.isFalse then return true
-  isLitValue e
-
-/--
-Creates an `ENode` for `e` if one does not already exist.
-This method assumes `e` has been hashconsed.
--/
-def mkENode (e : Expr) (generation : Nat) : GoalM Unit := do
-  if (← alreadyInternalized e) then return ()
-  let ctor := (← isConstructorAppCore? e).isSome
-  let interpreted ← isInterpreted e
-  mkENodeCore e interpreted ctor generation
-
-private def pushNewEqCore (lhs rhs proof : Expr) (isHEq : Bool) : GoalM Unit :=
-  modify fun s => { s with newEqs := s.newEqs.push { lhs, rhs, proof, isHEq } }
-
-@[inline] private def pushNewEq (lhs rhs proof : Expr) : GoalM Unit :=
-  pushNewEqCore lhs rhs proof (isHEq := false)
-
-@[inline] private def pushNewHEq (lhs rhs proof : Expr) : GoalM Unit :=
-  pushNewEqCore lhs rhs proof (isHEq := true)
-
-/--
-Adds `e` to congruence table.
--/
-def addCongrTable (_e : Expr) : GoalM Unit := do
-  -- TODO
-  return ()
-
-partial def internalize (e : Expr) (generation : Nat) : GoalM Unit := do
-  if (← alreadyInternalized e) then return ()
-  match e with
-  | .bvar .. => unreachable!
-  | .sort .. => return ()
-  | .fvar .. | .letE .. | .lam .. | .forallE .. =>
-    mkENodeCore e (ctor := false) (interpreted := false) (generation := generation)
-  | .lit .. | .const .. =>
-    mkENode e generation
-  | .mvar ..
-  | .mdata ..
-  | .proj .. =>
-    trace[grind.issues] "unexpected term during internalization{indentExpr e}"
-    mkENodeCore e (ctor := false) (interpreted := false) (generation := generation)
-  | .app .. =>
-    if (← isLitValue e) then
-      -- We do not want to internalize the components of a literal value.
-      mkENode e generation
-    else e.withApp fun f args => do
-      unless f.isConst do
-        internalize f generation
-      let info ← getFunInfo f
-      let shouldInternalize (i : Nat) : GoalM Bool := do
-        if h : i < info.paramInfo.size then
-          let pinfo := info.paramInfo[i]
-          if pinfo.binderInfo.isInstImplicit || pinfo.isProp then
-            return false
-        return true
-      for h : i in [: args.size] do
-        let arg := args[i]
-        if (← shouldInternalize i) then
-          unless (← isTypeFormer arg) do
-            internalize arg generation
-      mkENode e generation
-      addCongrTable e
 
 /--
 The fields `target?` and `proof?` in `e`'s `ENode` are encoding a transitivity proof
@@ -163,39 +34,95 @@ where
       proof?  := proofNew?
     }
 
-private def markAsInconsistent : GoalM Unit :=
-  modify fun s => { s with inconsistent := true }
+/--
+Remove `root` parents from the congruence table.
+This is an auxiliary function performed while merging equivalence classes.
+-/
+private def removeParents (root : Expr) : GoalM ParentSet := do
+  let parents ← getParentsAndReset root
+  for parent in parents do
+    -- Recall that we may have `Expr.forallE` in `parents` because of `ForallProp.lean`
+    if (← pure parent.isApp <&&> isCongrRoot parent) then
+      trace[grind.debug.parent] "remove: {parent}"
+      modify fun s => { s with congrTable := s.congrTable.erase { e := parent } }
+  return parents
 
-def isInconsistent : GoalM Bool :=
-  return (← get).inconsistent
+/--
+Reinsert parents into the congruence table and detect new equalities.
+This is an auxiliary function performed while merging equivalence classes.
+-/
+private def reinsertParents (parents : ParentSet) : GoalM Unit := do
+  for parent in parents do
+    if (← pure parent.isApp <&&> isCongrRoot parent) then
+      trace[grind.debug.parent] "reinsert: {parent}"
+      addCongrTable parent
+
+/-- Closes the goal when `True` and `False` are in the same equivalence class. -/
+private def closeGoalWithTrueEqFalse : GoalM Unit := do
+  let mvarId := (← get).mvarId
+  unless (← mvarId.isAssigned) do
+    let trueEqFalse ← mkEqFalseProof (← getTrueExpr)
+    let falseProof ← mkEqMP trueEqFalse (mkConst ``True.intro)
+    closeGoal falseProof
+
+/-- Closes the goal when `lhs` and `rhs` are both literal values and belong to the same equivalence class. -/
+private def closeGoalWithValuesEq (lhs rhs : Expr) : GoalM Unit := do
+  let p ← mkEq lhs rhs
+  let hp ← mkEqProof lhs rhs
+  let d ← mkDecide p
+  let pEqFalse := mkApp3 (mkConst ``eq_false_of_decide) p d.appArg! (mkApp2 (mkConst ``Eq.refl [1]) (mkConst ``Bool) (mkConst ``false))
+  let falseProof ← mkEqMP pEqFalse hp
+  closeGoal falseProof
+
+/--
+Updates the modification time to `gmt` for the parents of `root`.
+The modification time is used to decide which terms are considered during e-matching.
+-/
+private partial def updateMT (root : Expr) : GoalM Unit := do
+  let gmt := (← get).gmt
+  for parent in (← getParents root) do
+    let node ← getENode parent
+    if node.mt < gmt then
+      setENode parent { node with mt := gmt }
+      updateMT parent
 
 private partial def addEqStep (lhs rhs proof : Expr) (isHEq : Bool) : GoalM Unit := do
-  trace[grind.eq] "{lhs} {if isHEq then "≡" else "="} {rhs}"
   let lhsNode ← getENode lhs
   let rhsNode ← getENode rhs
   if isSameExpr lhsNode.root rhsNode.root then
     -- `lhs` and `rhs` are already in the same equivalence class.
     trace[grind.debug] "{← ppENodeRef lhs} and {← ppENodeRef rhs} are already in the same equivalence class"
     return ()
+  trace[grind.eqc] "{← if isHEq then mkHEq lhs rhs else mkEq lhs rhs}"
   let lhsRoot ← getENode lhsNode.root
   let rhsRoot ← getENode rhsNode.root
+  let mut valueInconsistency := false
+  let mut trueEqFalse := false
+  if lhsRoot.interpreted && rhsRoot.interpreted then
+    if lhsNode.root.isTrue || rhsNode.root.isTrue then
+      markAsInconsistent
+      trueEqFalse := true
+    else
+      valueInconsistency := true
   if    (lhsRoot.interpreted && !rhsRoot.interpreted)
      || (lhsRoot.ctor && !rhsRoot.ctor)
      || (lhsRoot.size > rhsRoot.size && !rhsRoot.interpreted && !rhsRoot.ctor) then
     go rhs lhs rhsNode lhsNode rhsRoot lhsRoot true
   else
     go lhs rhs lhsNode rhsNode lhsRoot rhsRoot false
+  if trueEqFalse then
+    closeGoalWithTrueEqFalse
+  unless (← isInconsistent) do
+    if lhsRoot.ctor && rhsRoot.ctor then
+      propagateCtor lhsRoot.self rhsRoot.self
+  unless (← isInconsistent) do
+    if valueInconsistency then
+      closeGoalWithValuesEq lhsRoot.self rhsRoot.self
   trace[grind.debug] "after addEqStep, {← ppState}"
+  checkInvariants
 where
   go (lhs rhs : Expr) (lhsNode rhsNode lhsRoot rhsRoot : ENode) (flipped : Bool) : GoalM Unit := do
     trace[grind.debug] "adding {← ppENodeRef lhs} ↦ {← ppENodeRef rhs}"
-    let mut valueInconsistency := false
-    if lhsRoot.interpreted && rhsRoot.interpreted then
-      if lhsNode.root.isTrue || rhsNode.root.isTrue then
-        markAsInconsistent
-      else
-        valueInconsistency := true
-    -- TODO: process valueInconsistency := true
     /-
     We have the following `target?/proof?`
     `lhs -> ... -> lhsNode.root`
@@ -210,14 +137,12 @@ where
       proof?  := proof
       flipped
     }
-    -- TODO: Remove parents from congruence table
-    -- TODO: set propagateBool
-    updateRoots lhs rhsNode.root true -- TODO
+    let parents ← removeParents lhsRoot.self
+    updateRoots lhs rhsNode.root
     trace[grind.debug] "{← ppENodeRef lhs} new root {← ppENodeRef rhsNode.root}, {← ppENodeRef (← getRoot lhs)}"
-    -- TODO: Reinsert parents into congruence table
-    setENode lhsNode.root { lhsRoot with
+    reinsertParents parents
+    setENode lhsNode.root { (← getENode lhsRoot.self) with -- We must retrieve `lhsRoot` since it was updated.
       next := rhsRoot.next
-      root := rhsNode.root
     }
     setENode rhsNode.root { rhsRoot with
       next := lhsRoot.next
@@ -225,22 +150,35 @@ where
       hasLambdas := rhsRoot.hasLambdas || lhsRoot.hasLambdas
       heqProofs  := isHEq || rhsRoot.heqProofs || lhsRoot.heqProofs
     }
-    -- TODO: copy parentst from lhsRoot parents to rhsRoot parents
+    copyParentsTo parents rhsNode.root
+    unless (← isInconsistent) do
+      for parent in parents do
+        propagateUp parent
+    unless (← isInconsistent) do
+      updateMT rhsRoot.self
 
-  updateRoots (lhs : Expr) (rootNew : Expr) (_propagateBool : Bool) : GoalM Unit := do
+  updateRoots (lhs : Expr) (rootNew : Expr) : GoalM Unit := do
     let rec loop (e : Expr) : GoalM Unit := do
-      -- TODO: propagateBool
       let n ← getENode e
       setENode e { n with root := rootNew }
+      unless (← isInconsistent) do
+        propagateDown e
       if isSameExpr lhs n.next then return ()
       loop n.next
     loop lhs
 
 /-- Ensures collection of equations to be processed is empty. -/
-def resetNewEqs : GoalM Unit :=
+private def resetNewEqs : GoalM Unit :=
   modify fun s => { s with newEqs := #[] }
 
-partial def addEqCore (lhs rhs proof : Expr) (isHEq : Bool) : GoalM Unit := do
+/-- Pops and returns the next equality to be processed. -/
+private def popNextEq? : GoalM (Option NewEq) := do
+  let r := (← get).newEqs.back?
+  if r.isSome then
+    modify fun s => { s with newEqs := s.newEqs.pop }
+  return r
+
+private partial def addEqCore (lhs rhs proof : Expr) (isHEq : Bool) : GoalM Unit := do
   addEqStep lhs rhs proof isHEq
   processTodo
 where
@@ -248,21 +186,29 @@ where
     if (← isInconsistent) then
       resetNewEqs
       return ()
-    let some { lhs, rhs, proof, isHEq } := (← get).newEqs.back? | return ()
+    checkSystem "grind"
+    let some { lhs, rhs, proof, isHEq } := (← popNextEq?) | return ()
     addEqStep lhs rhs proof isHEq
     processTodo
 
+/-- Adds a new equality `lhs = rhs`. It assumes `lhs` and `rhs` have already been internalized. -/
 def addEq (lhs rhs proof : Expr) : GoalM Unit := do
   addEqCore lhs rhs proof false
 
+
+/-- Adds a new heterogeneous equality `HEq lhs rhs`. It assumes `lhs` and `rhs` have already been internalized. -/
 def addHEq (lhs rhs proof : Expr) : GoalM Unit := do
   addEqCore lhs rhs proof true
 
-/--
-Adds a new `fact` justified by the given proof and using the given generation.
--/
+/-- Internalizes `lhs` and `rhs`, and then adds equality `lhs = rhs`. -/
+def addNewEq (lhs rhs proof : Expr) (generation : Nat) : GoalM Unit := do
+  internalize lhs generation
+  internalize rhs generation
+  addEq lhs rhs proof
+
+/-- Adds a new `fact` justified by the given proof and using the given generation. -/
 def add (fact : Expr) (proof : Expr) (generation := 0) : GoalM Unit := do
-  trace[grind.add] "{proof} : {fact}"
+  trace[grind.assert] "{fact}"
   if (← isInconsistent) then return ()
   resetNewEqs
   let_expr Not p := fact
@@ -270,10 +216,9 @@ def add (fact : Expr) (proof : Expr) (generation := 0) : GoalM Unit := do
   go p true
 where
   go (p : Expr) (isNeg : Bool) : GoalM Unit := do
-    trace[grind.add] "isNeg: {isNeg}, {p}"
     match_expr p with
     | Eq _ lhs rhs => goEq p lhs rhs isNeg false
-    | HEq _ _ lhs rhs => goEq p lhs rhs isNeg true
+    | HEq _ lhs _ rhs => goEq p lhs rhs isNeg true
     | _ =>
       internalize p generation
       if isNeg then
@@ -290,10 +235,8 @@ where
       internalize rhs generation
       addEqCore lhs rhs proof isHEq
 
-/--
-Adds a new hypothesis.
--/
-def addHyp (fvarId : FVarId) (generation := 0) : GoalM Unit := do
+/-- Adds a new hypothesis. -/
+def addHypothesis (fvarId : FVarId) (generation := 0) : GoalM Unit := do
   add (← fvarId.getType) (mkFVar fvarId) generation
 
 end Lean.Meta.Grind

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

@@ -0,0 +1,53 @@
+/-
+Copyright (c) 2024 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
+-/
+prelude
+import Lean.Meta.Tactic.Grind.Types
+
+namespace Lean.Meta.Grind
+
+private partial def propagateInjEqs (eqs : Expr) (proof : Expr) : GoalM Unit := do
+  -- Remark: we must use `shareCommon` before using `pushEq` and `pushHEq`.
+  -- This is needed because the result type of the injection theorem may allocate
+  match_expr eqs with
+  | And left right =>
+    propagateInjEqs left (.proj ``And 0 proof)
+    propagateInjEqs right (.proj ``And 1 proof)
+  | Eq _ lhs rhs    =>
+    pushEq (← shareCommon lhs) (← shareCommon rhs) proof
+  | HEq _ lhs _ rhs =>
+    pushHEq (← shareCommon lhs) (← shareCommon rhs) proof
+  | _ =>
+   trace[grind.issues] "unexpected injectivity theorem result type{indentExpr eqs}"
+   return ()
+
+/--
+Given constructors `a` and `b`, propagate equalities if they are the same,
+and close goal if they are different.
+-/
+def propagateCtor (a b : Expr) : GoalM Unit := do
+  let aType ← whnfD (← inferType a)
+  let bType ← whnfD (← inferType b)
+  unless (← withDefault <| isDefEq aType bType) do
+    return ()
+  let ctor₁ := a.getAppFn
+  let ctor₂ := b.getAppFn
+  if ctor₁ == ctor₂ then
+    let .const ctorName _ := a.getAppFn | return ()
+    let injDeclName := Name.mkStr ctorName "inj"
+    unless (← getEnv).contains injDeclName do return ()
+    let info ← getConstInfo injDeclName
+    let n := info.type.getForallArity
+    let mask : Array (Option Expr) := mkArray n none
+    let mask := mask.set! (n-1) (some (← mkEqProof a b))
+    let injLemma ← mkAppOptM injDeclName mask
+    propagateInjEqs (← inferType injLemma) injLemma
+  else
+    let .const declName _ := aType.getAppFn | return ()
+    let noConfusionDeclName := Name.mkStr declName "noConfusion"
+    unless (← getEnv).contains noConfusionDeclName do return ()
+    closeGoal (← mkNoConfusion (← getFalseExpr) (← mkEqProof a b))
+
+end Lean.Meta.Grind

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

@@ -0,0 +1,35 @@
+/-
+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
+-/
+prelude
+import Init.Grind.Util
+import Init.Simproc
+import Lean.Meta.Tactic.Simp.Simproc
+
+namespace Lean.Meta.Grind
+
+/--
+Returns `Grind.doNotSimp e`.
+Recall that `Grind.doNotSimp` is an identity function, but the following simproc is used to prevent the term `e` from being simplified.
+-/
+def markAsDoNotSimp (e : Expr) : MetaM Expr :=
+  mkAppM ``Grind.doNotSimp #[e]
+
+builtin_dsimproc_decl reduceDoNotSimp (Grind.doNotSimp _) := fun e => do
+  let_expr Grind.doNotSimp _ _ ← e | return .continue
+  return .done e
+
+/-- Adds `reduceDoNotSimp` to `s` -/
+def addDoNotSimp (s : Simprocs) : CoreM Simprocs := do
+  s.add ``reduceDoNotSimp (post := false)
+
+/-- Erases `Grind.doNotSimp` annotations. -/
+def eraseDoNotSimp (e : Expr) : CoreM Expr := do
+  let pre (e : Expr) := do
+    let_expr Grind.doNotSimp _ a := e | return .continue e
+    return .continue a
+  Core.transform e (pre := pre)
+
+end Lean.Meta.Grind

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

@@ -0,0 +1,354 @@
+/-
+Copyright (c) 2024 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
+-/
+prelude
+import Lean.Meta.Tactic.Grind.Types
+import Lean.Meta.Tactic.Grind.Intro
+import Lean.Meta.Tactic.Grind.DoNotSimp
+
+namespace Lean.Meta.Grind
+namespace EMatch
+/-! This module implements a simple E-matching procedure as a backtracking search. -/
+
+/-- We represent an `E-matching` problem as a list of constraints. -/
+inductive Cnstr where
+  | /-- Matches pattern `pat` with term `e` -/
+    «match» (pat : Expr) (e : Expr)
+  | /-- Matches offset pattern `pat+k` with term `e` -/
+    offset (pat : Expr) (k : Nat) (e : Expr)
+  | /-- This constraint is used to encode multi-patterns. -/
+    «continue» (pat : Expr)
+  deriving Inhabited
+
+/--
+Internal "marker" for representing unassigned elemens in the `assignment` field.
+This is a small hack to avoid one extra level of indirection by using `Option Expr` at `assignment`.
+-/
+private def unassigned : Expr := mkConst (Name.mkSimple "[grind_unassigned]")
+
+private def assignmentToMessageData (assignment : Array Expr) : Array MessageData :=
+  assignment.reverse.map fun e =>
+    if isSameExpr e unassigned then m!"_" else m!"{e}"
+
+/--
+Choice point for the backtracking search.
+The state of the procedure contains a stack of choices.
+-/
+structure Choice where
+  /-- Contraints to be processed. -/
+  cnstrs     : List Cnstr
+  /-- Maximum term generation found so far. -/
+  gen        : Nat
+  /-- Partial assignment so far. Recall that pattern variables are encoded as de-Bruijn variables. -/
+  assignment : Array Expr
+  deriving Inhabited
+
+/-- Context for the E-matching monad. -/
+structure Context where
+  /-- `useMT` is `true` if we are using the mod-time optimization. It is always set to false for new `EMatchTheorem`s. -/
+  useMT : Bool := true
+  /-- `EMatchTheorem` being processed. -/
+  thm   : EMatchTheorem := default
+  deriving Inhabited
+
+/-- State for the E-matching monad -/
+structure State where
+  /-- Choices that still have to be processed. -/
+  choiceStack  : List Choice := []
+  deriving Inhabited
+
+abbrev M := ReaderT Context $ StateRefT State GoalM
+
+def M.run' (x : M α) : GoalM α :=
+  x {} |>.run' {}
+
+/--
+Assigns `bidx := e` in `c`. If `bidx` is already assigned in `c`, we check whether
+`e` and `c.assignment[bidx]` are in the same equivalence class.
+This function assumes `bidx < c.assignment.size`.
+Recall that we initialize the assignment array with the number of theorem parameters.
+-/
+private def assign? (c : Choice) (bidx : Nat) (e : Expr) : OptionT GoalM Choice := do
+  if h : bidx < c.assignment.size then
+    let v := c.assignment[bidx]
+    if isSameExpr v unassigned then
+      return { c with assignment := c.assignment.set bidx e }
+    else
+      guard (← isEqv v e)
+      return c
+  else
+    -- `Choice` was not properly initialized
+    unreachable!
+
+/--
+Returns `true` if the function `pFn` of a pattern is equivalent to the function `eFn`.
+Recall that we ignore universe levels in patterns.
+-/
+private def eqvFunctions (pFn eFn : Expr) : Bool :=
+  (pFn.isFVar && pFn == eFn)
+  || (pFn.isConst && eFn.isConstOf pFn.constName!)
+
+/-- Matches a pattern argument. See `matchArgs?`. -/
+private def matchArg? (c : Choice) (pArg : Expr) (eArg : Expr) : OptionT GoalM Choice := do
+  if isPatternDontCare pArg then
+    return c
+  else if pArg.isBVar then
+    assign? c pArg.bvarIdx! eArg
+  else if let some pArg := groundPattern? pArg then
+    guard (← isEqv pArg eArg)
+    return c
+  else if let some (pArg, k) := isOffsetPattern? pArg then
+    assert! Option.isNone <| isOffsetPattern? pArg
+    assert! !isPatternDontCare pArg
+    return { c with cnstrs := .offset pArg k eArg :: c.cnstrs }
+  else
+    return { c with cnstrs := .match pArg eArg :: c.cnstrs }
+
+private def Choice.updateGen (c : Choice) (gen : Nat) : Choice :=
+  { c with gen := Nat.max gen c.gen }
+
+private def pushChoice (c : Choice) : M Unit :=
+  modify fun s => { s with choiceStack := c :: s.choiceStack }
+
+/--
+Matches arguments of pattern `p` with term `e`. Returns `some` if successful,
+and `none` otherwise. It may update `c`s assignment and list of contraints to be
+processed.
+-/
+private partial def matchArgs? (c : Choice) (p : Expr) (e : Expr) : OptionT GoalM Choice := do
+  if !p.isApp then return c -- Done
+  let pArg := p.appArg!
+  let eArg := e.appArg!
+  let c ← matchArg? c pArg eArg
+  matchArgs? c p.appFn! e.appFn!
+
+/--
+Matches pattern `p` with term `e` with respect to choice `c`.
+We traverse the equivalence class of `e` looking for applications compatible with `p`.
+For each candidate application, we match the arguments and may update `c`s assignments and contraints.
+We add the updated choices to the choice stack.
+-/
+private partial def processMatch (c : Choice) (p : Expr) (e : Expr) : M Unit := do
+  let maxGeneration ← getMaxGeneration
+  let pFn := p.getAppFn
+  let numArgs := p.getAppNumArgs
+  let mut curr := e
+  repeat
+    let n ← getENode curr
+    -- Remark: we use `<` because the instance generation is the maximum term generation + 1
+    if n.generation < maxGeneration
+       -- uses heterogeneous equality or is the root of its congruence class
+       && (n.heqProofs || n.isCongrRoot)
+       && eqvFunctions pFn curr.getAppFn
+       && curr.getAppNumArgs == numArgs then
+      if let some c ← matchArgs? c p curr |>.run then
+        pushChoice (c.updateGen n.generation)
+    curr ← getNext curr
+    if isSameExpr curr e then break
+
+/--
+Matches offset pattern `pArg+k` with term `e` with respect to choice `c`.
+-/
+private partial def processOffset (c : Choice) (pArg : Expr) (k : Nat) (e : Expr) : M Unit := do
+  let maxGeneration ← getMaxGeneration
+  let mut curr := e
+  repeat
+    let n ← getENode curr
+    if n.generation < maxGeneration then
+      if let some (eArg, k') ← isOffset? curr |>.run then
+        if k' < k then
+          let c := c.updateGen n.generation
+          pushChoice { c with cnstrs := .offset pArg (k - k') eArg :: c.cnstrs }
+        else if k' == k then
+          if let some c ← matchArg? c pArg eArg |>.run then
+            pushChoice (c.updateGen n.generation)
+        else if k' > k then
+          let eArg' := mkNatAdd eArg (mkNatLit (k' - k))
+          let eArg' ← shareCommon (← canon eArg')
+          internalize eArg' (n.generation+1)
+          if let some c ← matchArg? c pArg eArg' |>.run then
+            pushChoice (c.updateGen n.generation)
+      else if let some k' ← evalNat curr |>.run then
+        if k' >= k then
+          let eArg' := mkNatLit (k' - k)
+          let eArg' ← shareCommon (← canon eArg')
+          internalize eArg' (n.generation+1)
+          if let some c ← matchArg? c pArg eArg' |>.run then
+            pushChoice (c.updateGen n.generation)
+    curr ← getNext curr
+    if isSameExpr curr e then break
+
+/-- Processes `continue` contraint used to implement multi-patterns. -/
+private def processContinue (c : Choice) (p : Expr) : M Unit := do
+  let some apps := (← getThe Goal).appMap.find? p.toHeadIndex
+    | return ()
+  let maxGeneration ← getMaxGeneration
+  for app in apps do
+    let n ← getENode app
+    if n.generation < maxGeneration
+       && (n.heqProofs || n.isCongrRoot) then
+      if let some c ← matchArgs? c p app |>.run then
+        let gen := n.generation
+        let c := { c with gen := Nat.max gen c.gen }
+        modify fun s => { s with choiceStack := c :: s.choiceStack }
+
+/-- Helper function for marking parts of `match`-equation theorem as "do-not-simplify" -/
+private partial def annotateMatchEqnType (prop : Expr) : M Expr := do
+  if let .forallE n d b bi := prop then
+    withLocalDecl n bi (← markAsDoNotSimp d) fun x => do
+      mkForallFVars #[x] (← annotateMatchEqnType (b.instantiate1 x))
+  else
+    let_expr f@Eq α lhs rhs := prop | return prop
+    return mkApp3 f α (← markAsDoNotSimp lhs) rhs
+
+/--
+Stores new theorem instance in the state.
+Recall that new instances are internalized later, after a full round of ematching.
+-/
+private def addNewInstance (origin : Origin) (proof : Expr) (generation : Nat) : M Unit := do
+  let proof ← instantiateMVars proof
+  if grind.debug.proofs.get (← getOptions) then
+    check proof
+  let mut prop ← inferType proof
+  if Match.isMatchEqnTheorem (← getEnv) origin.key then
+    prop ← annotateMatchEqnType prop
+  trace[grind.ematch.instance] "{← origin.pp}: {prop}"
+  addTheoremInstance proof prop (generation+1)
+
+/--
+After processing a (multi-)pattern, use the choice assignment to instantiate the proof.
+Missing parameters are synthesized using type inference and type class synthesis."
+-/
+private partial def instantiateTheorem (c : Choice) : M Unit := withDefault do withNewMCtxDepth do
+  let thm := (← read).thm
+  unless (← markTheoremInstance thm.proof c.assignment) do
+    return ()
+  trace[grind.ematch.instance.assignment] "{← thm.origin.pp}: {assignmentToMessageData c.assignment}"
+  let proof ← thm.getProofWithFreshMVarLevels
+  let numParams := thm.numParams
+  assert! c.assignment.size == numParams
+  let (mvars, bis, _) ← forallMetaBoundedTelescope (← inferType proof) numParams
+  if mvars.size != thm.numParams then
+    trace[grind.issues] "unexpected number of parameters at {← thm.origin.pp}"
+    return ()
+  -- Apply assignment
+  for h : i in [:mvars.size] do
+    let v := c.assignment[numParams - i - 1]!
+    unless isSameExpr v unassigned do
+      let mvarId := mvars[i].mvarId!
+      unless (← isDefEq (← mvarId.getType) (← inferType v) <&&> mvarId.checkedAssign v) do
+        trace[grind.issues] "type error constructing proof for {← thm.origin.pp}\nwhen assigning metavariable {mvars[i]} with {indentExpr v}"
+        return ()
+  -- Synthesize instances
+  for mvar in mvars, bi in bis do
+    if bi.isInstImplicit && !(← mvar.mvarId!.isAssigned) then
+      let type ← inferType mvar
+      unless (← synthesizeInstance mvar type) do
+        trace[grind.issues] "failed to synthesize instance when instantiating {← thm.origin.pp}{indentExpr type}"
+        return ()
+  let proof := mkAppN proof mvars
+  if (← mvars.allM (·.mvarId!.isAssigned)) then
+    addNewInstance thm.origin proof c.gen
+  else
+    let mvars ← mvars.filterM fun mvar => return !(← mvar.mvarId!.isAssigned)
+    if let some mvarBad ← mvars.findM? fun mvar => return !(← isProof mvar) then
+      trace[grind.issues] "failed to instantiate {← thm.origin.pp}, failed to instantiate non propositional argument with type{indentExpr (← inferType mvarBad)}"
+    let proof ← mkLambdaFVars (binderInfoForMVars := .default) mvars (← instantiateMVars proof)
+    addNewInstance thm.origin proof c.gen
+where
+  synthesizeInstance (x type : Expr) : MetaM Bool := do
+    let .some val ← trySynthInstance type | return false
+    isDefEq x val
+
+/-- Process choice stack until we don't have more choices to be processed. -/
+private def processChoices : M Unit := do
+  let maxGeneration ← getMaxGeneration
+  while !(← get).choiceStack.isEmpty do
+    checkSystem "ematch"
+    if (← checkMaxInstancesExceeded) then return ()
+    let c ← modifyGet fun s : State => (s.choiceStack.head!, { s with choiceStack := s.choiceStack.tail! })
+    if c.gen < maxGeneration then
+      match c.cnstrs with
+      | [] => instantiateTheorem c
+      | .match p e :: cnstrs => processMatch { c with cnstrs } p e
+      | .offset p k e :: cnstrs => processOffset { c with cnstrs } p k e
+      | .continue p :: cnstrs => processContinue { c with cnstrs } p
+
+private def main (p : Expr) (cnstrs : List Cnstr) : M Unit := do
+  let some apps := (← getThe Goal).appMap.find? p.toHeadIndex
+    | return ()
+  let numParams  := (← read).thm.numParams
+  let assignment := mkArray numParams unassigned
+  let useMT      := (← read).useMT
+  let gmt        := (← getThe Goal).gmt
+  for app in apps do
+    if (← checkMaxInstancesExceeded) then return ()
+    let n ← getENode app
+    if (n.heqProofs || n.isCongrRoot) &&
+       (!useMT || n.mt == gmt) then
+      if let some c ← matchArgs? { cnstrs, assignment, gen := n.generation } p app |>.run then
+        modify fun s => { s with choiceStack := [c] }
+        processChoices
+
+def ematchTheorem (thm : EMatchTheorem) : M Unit := do
+  if (← checkMaxInstancesExceeded) then return ()
+  withReader (fun ctx => { ctx with thm }) do
+    let ps := thm.patterns
+    match ps, (← read).useMT with
+    | [p],   _     => main p []
+    | p::ps, false => main p (ps.map (.continue ·))
+    | _::_,  true  => tryAll ps []
+    | _,     _     => unreachable!
+where
+  /--
+  When using the mod-time optimization with multi-patterns,
+  we must start ematching at each different pattern. That is,
+  if we have `[p₁, p₂, p₃]`, we must execute
+  - `main p₁ [.continue p₂, .continue p₃]`
+  - `main p₂ [.continue p₁, .continue p₃]`
+  - `main p₃ [.continue p₁, .continue p₂]`
+  -/
+  tryAll (ps : List Expr) (cs : List Cnstr) : M Unit := do
+    match ps with
+    | []    => return ()
+    | p::ps =>
+      main p (cs.reverse ++ (ps.map (.continue ·)))
+      tryAll ps (.continue p :: cs)
+
+def ematchTheorems (thms : PArray EMatchTheorem) : M Unit := do
+  thms.forM ematchTheorem
+
+end EMatch
+
+open EMatch
+
+/-- Performs one round of E-matching, and returns new instances. -/
+def ematch : GoalM Unit := do
+  let go (thms newThms : PArray EMatchTheorem) : EMatch.M Unit := do
+    withReader (fun ctx => { ctx with useMT := true }) <| ematchTheorems thms
+    withReader (fun ctx => { ctx with useMT := false }) <| ematchTheorems newThms
+  if (← checkMaxInstancesExceeded <||> checkMaxEmatchExceeded) then
+    return ()
+  else
+    go (← get).thms (← get).newThms |>.run'
+    modify fun s => { s with
+      thms         := s.thms ++ s.newThms
+      newThms      := {}
+      gmt          := s.gmt + 1
+      numEmatch    := s.numEmatch + 1
+    }
+
+/-- Performs one round of E-matching, and assert new instances. -/
+def ematchAndAssert? (goal : Goal) : GrindM (Option (List Goal)) := do
+  let numInstances := goal.numInstances
+  let goal ← GoalM.run' goal ematch
+  if goal.numInstances == numInstances then
+    return none
+  assertAll goal
+
+def ematchStar (goal : Goal) : GrindM (List Goal) := do
+  iterate goal ematchAndAssert?
+
+end Lean.Meta.Grind

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

@@ -0,0 +1,667 @@
+/-
+Copyright (c) 2024 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
+-/
+prelude
+import Init.Grind.Util
+import Init.Grind.Tactics
+import Lean.HeadIndex
+import Lean.PrettyPrinter
+import Lean.Util.FoldConsts
+import Lean.Util.CollectFVars
+import Lean.Meta.Basic
+import Lean.Meta.InferType
+import Lean.Meta.Eqns
+import Lean.Meta.Tactic.Grind.Util
+
+namespace Lean.Meta.Grind
+
+def mkOffsetPattern (pat : Expr) (k : Nat) : Expr :=
+  mkApp2 (mkConst ``Grind.offset) pat (mkRawNatLit k)
+
+private def detectOffsets (pat : Expr) : MetaM Expr := do
+  let pre (e : Expr) := do
+    if e == pat then
+      -- We only consider nested offset patterns
+      return .continue e
+    else match e with
+      | .letE .. | .lam .. | .forallE .. => return .done e
+      | _ =>
+        let some (e, k) ← isOffset? e
+          | return .continue e
+        if k == 0 then return .continue e
+        return .continue <| mkOffsetPattern e k
+  Core.transform pat (pre := pre)
+
+def isOffsetPattern? (pat : Expr) : Option (Expr × Nat) := Id.run do
+  let_expr Grind.offset pat k := pat | none
+  let .lit (.natVal k) := k | none
+  return some (pat, k)
+
+def preprocessPattern (pat : Expr) (normalizePattern := true) : MetaM Expr := do
+  let pat ← instantiateMVars pat
+  let pat ← unfoldReducible pat
+  let pat ← if normalizePattern then normalize pat else pure pat
+  let pat ← detectOffsets pat
+  let pat ← foldProjs pat
+  return pat
+
+inductive Origin where
+  /-- A global declaration in the environment. -/
+  | decl (declName : Name)
+  /-- A local hypothesis. -/
+  | fvar (fvarId : FVarId)
+  /--
+  A proof term provided directly to a call to `grind` where `ref`
+  is the provided grind argument. The `id` is a unique identifier for the call.
+  -/
+  | stx (id : Name) (ref : Syntax)
+  | other
+  deriving Inhabited, Repr
+
+/-- A unique identifier corresponding to the origin. -/
+def Origin.key : Origin → Name
+  | .decl declName => declName
+  | .fvar fvarId   => fvarId.name
+  | .stx id _      => id
+  | .other         => `other
+
+def Origin.pp [Monad m] [MonadEnv m] [MonadError m] (o : Origin) : m MessageData := do
+  match o with
+  | .decl declName => return MessageData.ofConst (← mkConstWithLevelParams declName)
+  | .fvar fvarId   => return mkFVar fvarId
+  | .stx _ ref     => return ref
+  | .other         => return "[unknown]"
+
+/-- A theorem for heuristic instantiation based on E-matching. -/
+structure EMatchTheorem where
+  /--
+  It stores universe parameter names for universe polymorphic proofs.
+  Recall that it is non-empty only when we elaborate an expression provided by the user.
+  When `proof` is just a constant, we can use the universe parameter names stored in the declaration.
+  -/
+  levelParams : Array Name
+  proof       : Expr
+  numParams   : Nat
+  patterns    : List Expr
+  /-- Contains all symbols used in `pattterns`. -/
+  symbols     : List HeadIndex
+  origin      : Origin
+  deriving Inhabited
+
+/-- Set of E-matching theorems. -/
+structure EMatchTheorems where
+  /-- The key is a symbol from `EMatchTheorem.symbols`. -/
+  private map : PHashMap Name (List EMatchTheorem) := {}
+  /-- Set of theorem names that have been inserted using `insert`. -/
+  private thmNames : PHashSet Name := {}
+  deriving Inhabited
+
+/--
+Inserts a `thm` with symbols `[s_1, ..., s_n]` to `s`.
+We add `s_1 -> { thm with symbols := [s_2, ..., s_n] }`.
+When `grind` internalizes a term containing symbol `s`, we
+process all theorems `thm` associated with key `s`.
+If their `thm.symbols` is empty, we say they are activated.
+Otherwise, we reinsert into `map`.
+-/
+def EMatchTheorems.insert (s : EMatchTheorems) (thm : EMatchTheorem) : EMatchTheorems := Id.run do
+  let .const declName :: syms := thm.symbols
+    | unreachable!
+  let thm := { thm with symbols := syms }
+  let { map, thmNames } := s
+  let thmNames := thmNames.insert thm.origin.key
+  if let some thms := map.find? declName then
+    return { map := map.insert declName (thm::thms), thmNames }
+  else
+    return { map := map.insert declName [thm], thmNames }
+
+/--
+Retrieves theorems from `s` associated with the given symbol. See `EMatchTheorem.insert`.
+The theorems are removed from `s`.
+-/
+@[inline]
+def EMatchTheorems.retrieve? (s : EMatchTheorems) (sym : Name) : Option (List EMatchTheorem × EMatchTheorems) :=
+  if let some thms := s.map.find? sym then
+    some (thms, { s with map := s.map.erase sym })
+  else
+    none
+
+/-- Returns `true` if `declName` is the name of a theorem that was inserted using `insert`. -/
+def EMatchTheorems.containsTheoremName (s : EMatchTheorems) (declName : Name) : Bool :=
+  s.thmNames.contains declName
+
+def EMatchTheorem.getProofWithFreshMVarLevels (thm : EMatchTheorem) : MetaM Expr := do
+  if thm.proof.isConst && thm.levelParams.isEmpty then
+    let declName := thm.proof.constName!
+    let info ← getConstInfo declName
+    if info.levelParams.isEmpty then
+      return thm.proof
+    else
+      mkConstWithFreshMVarLevels declName
+  else if thm.levelParams.isEmpty then
+    return thm.proof
+  else
+    let us ← thm.levelParams.mapM fun _ => mkFreshLevelMVar
+    return thm.proof.instantiateLevelParamsArray thm.levelParams us
+
+private builtin_initialize ematchTheoremsExt : SimpleScopedEnvExtension EMatchTheorem EMatchTheorems ←
+  registerSimpleScopedEnvExtension {
+    addEntry := EMatchTheorems.insert
+    initial  := {}
+  }
+
+-- TODO: create attribute?
+private def forbiddenDeclNames := #[``Eq, ``HEq, ``Iff, ``And, ``Or, ``Not]
+
+private def isForbidden (declName : Name) := forbiddenDeclNames.contains declName
+
+private def dontCare := mkConst (Name.mkSimple "[grind_dontcare]")
+
+def mkGroundPattern (e : Expr) : Expr :=
+  mkAnnotation `grind.ground_pat e
+
+def groundPattern? (e : Expr) : Option Expr :=
+  annotation? `grind.ground_pat e
+
+private def isGroundPattern (e : Expr) : Bool :=
+  groundPattern? e |>.isSome
+
+def isPatternDontCare (e : Expr) : Bool :=
+  e == dontCare
+
+private def isAtomicPattern (e : Expr) : Bool :=
+  e.isBVar || isPatternDontCare e || isGroundPattern e
+
+partial def ppPattern (pattern : Expr) : MessageData := Id.run do
+  if let some e := groundPattern? pattern then
+    return m!"`[{e}]"
+  else if isPatternDontCare pattern then
+    return m!"?"
+  else match pattern with
+    | .bvar idx => return m!"#{idx}"
+    | _ =>
+      let mut r := m!"{pattern.getAppFn}"
+      for arg in pattern.getAppArgs do
+        let mut argFmt ← ppPattern arg
+        if !isAtomicPattern arg then
+          argFmt := MessageData.paren argFmt
+        r := r ++ " " ++ argFmt
+      return r
+
+namespace NormalizePattern
+
+structure State where
+  symbols    : Array HeadIndex := #[]
+  symbolSet  : Std.HashSet HeadIndex := {}
+  bvarsFound : Std.HashSet Nat := {}
+
+abbrev M := StateRefT State MetaM
+
+private def saveSymbol (h : HeadIndex) : M Unit := do
+  unless (← get).symbolSet.contains h do
+    modify fun s => { s with symbols := s.symbols.push h, symbolSet := s.symbolSet.insert h }
+
+private def foundBVar (idx : Nat) : M Bool :=
+  return (← get).bvarsFound.contains idx
+
+private def saveBVar (idx : Nat) : M Unit := do
+  modify fun s => { s with bvarsFound := s.bvarsFound.insert idx }
+
+private def getPatternFn? (pattern : Expr) : Option Expr :=
+  if !pattern.isApp then
+    none
+  else match pattern.getAppFn with
+    | f@(.const declName _) => if isForbidden declName then none else some f
+    | f@(.fvar _) => some f
+    | _ => none
+
+/--
+Returns a bit-mask `mask` s.t. `mask[i]` is true if the the corresponding argument is
+- a type (that is not a proposition) or type former, or
+- a proof, or
+- an instance implicit argument
+
+When `mask[i]`, we say the corresponding argument is a "support" argument.
+-/
+def getPatternSupportMask (f : Expr) (numArgs : Nat) : MetaM (Array Bool) := do
+  forallBoundedTelescope (← inferType f) numArgs fun xs _ => do
+    xs.mapM fun x => do
+      if (← isProp x) then
+        return false
+      else if (← isTypeFormer x <||> isProof x) then
+        return true
+      else
+        return (← x.fvarId!.getDecl).binderInfo matches .instImplicit
+
+private partial def go (pattern : Expr) (root := false) : M Expr := do
+  if root && !pattern.hasLooseBVars then
+    throwError "invalid pattern, it does not have pattern variables"
+  if let some (e, k) := isOffsetPattern? pattern then
+    let e ← goArg e (isSupport := false)
+    if e == dontCare then
+      return dontCare
+    else
+      return mkOffsetPattern e k
+  let some f := getPatternFn? pattern
+    | throwError "invalid pattern, (non-forbidden) application expected{indentExpr pattern}"
+  assert! f.isConst || f.isFVar
+  saveSymbol f.toHeadIndex
+  let mut args := pattern.getAppArgs
+  let supportMask ← getPatternSupportMask f args.size
+  for i in [:args.size] do
+    let arg := args[i]!
+    let isSupport := supportMask[i]?.getD false
+    args := args.set! i (← goArg arg isSupport)
+  return mkAppN f args
+where
+  goArg (arg : Expr) (isSupport : Bool) : M Expr := do
+    if !arg.hasLooseBVars then
+      if arg.hasMVar then
+        pure dontCare
+      else
+        pure <| mkGroundPattern arg
+    else match arg with
+      | .bvar idx =>
+        if isSupport && (← foundBVar idx) then
+          pure dontCare
+        else
+          saveBVar idx
+          pure arg
+      | _ =>
+        if isSupport then
+          pure dontCare
+        else if let some _ := getPatternFn? arg then
+          go arg
+        else
+          pure dontCare
+
+def main (patterns : List Expr) : MetaM (List Expr × List HeadIndex × Std.HashSet Nat) := do
+  let (patterns, s) ← patterns.mapM go |>.run {}
+  return (patterns, s.symbols.toList, s.bvarsFound)
+
+def normalizePattern (e : Expr) : M Expr := do
+  go e
+
+end NormalizePattern
+
+/--
+Returns `true` if free variables in `type` are not in `thmVars` or are in `fvarsFound`.
+We use this function to check whether `type` is fully instantiated.
+-/
+private def checkTypeFVars (thmVars : FVarIdSet) (fvarsFound : FVarIdSet) (type : Expr) : Bool :=
+  let typeFVars := (collectFVars {} type).fvarIds
+  typeFVars.all fun fvarId => !thmVars.contains fvarId || fvarsFound.contains fvarId
+
+/--
+Given an type class instance type `instType`, returns true if free variables in input parameters
+1- are not in `thmVars`, or
+2- are in `fvarsFound`.
+Remark: `fvarsFound` is a subset of `thmVars`
+-/
+private def canBeSynthesized (thmVars : FVarIdSet) (fvarsFound : FVarIdSet) (instType : Expr) : MetaM Bool := do
+  forallTelescopeReducing instType fun xs type => type.withApp fun classFn classArgs => do
+    for x in xs do
+      unless checkTypeFVars thmVars fvarsFound (← inferType x) do return false
+    forallBoundedTelescope (← inferType classFn) type.getAppNumArgs fun params _ => do
+      for param in params, classArg in classArgs do
+        let paramType ← inferType param
+        if !paramType.isAppOf ``semiOutParam && !paramType.isAppOf ``outParam then
+          unless checkTypeFVars thmVars fvarsFound classArg do
+            return false
+      return true
+
+/--
+Auxiliary type for the `checkCoverage` function.
+-/
+inductive CheckCoverageResult where
+  | /-- `checkCoverage` succeeded -/
+    ok
+  | /--
+    `checkCoverage` failed because some of the theorem parameters are missing,
+    `pos` contains their positions
+    -/
+    missing (pos : List Nat)
+
+/--
+After we process a set of patterns, we obtain the set of de Bruijn indices in these patterns.
+We say they are pattern variables. This function checks whether the set of pattern variables is sufficient for
+instantiating the theorem with proof `thmProof`. The theorem has `numParams` parameters.
+The missing parameters:
+1- we may be able to infer them using type inference or type class synthesis, or
+2- they are propositions, and may become hypotheses of the instantiated theorem.
+
+For type class instance parameters, we must check whether the free variables in class input parameters are available.
+-/
+private def checkCoverage (thmProof : Expr) (numParams : Nat) (bvarsFound : Std.HashSet Nat) : MetaM CheckCoverageResult := do
+  if bvarsFound.size == numParams then return .ok
+  forallBoundedTelescope (← inferType thmProof) numParams fun xs _ => do
+    assert! numParams == xs.size
+    let patternVars := bvarsFound.toList.map fun bidx => xs[numParams - bidx - 1]!.fvarId!
+    -- `xs` as a `FVarIdSet`.
+    let thmVars : FVarIdSet := RBTree.ofList <| xs.toList.map (·.fvarId!)
+    -- Collect free variables occurring in `e`, and insert the ones that are in `thmVars` into `fvarsFound`
+    let update (fvarsFound : FVarIdSet) (e : Expr) : FVarIdSet :=
+      (collectFVars {} e).fvarIds.foldl (init := fvarsFound) fun s fvarId =>
+        if thmVars.contains fvarId then s.insert fvarId else s
+    -- Theorem variables found so far. We initialize with the variables occurring in patterns
+    -- Remark: fvarsFound is a subset of thmVars
+    let mut fvarsFound : FVarIdSet := RBTree.ofList patternVars
+    for patternVar in patternVars do
+      let type ← patternVar.getType
+      fvarsFound := update fvarsFound type
+    if fvarsFound.size == numParams then return .ok
+    -- Now, we keep traversing remaining variables and collecting
+    -- `processed` contains the variables we have already processed.
+    let mut processed : FVarIdSet := RBTree.ofList patternVars
+    let mut modified := false
+    repeat
+      modified := false
+      for x in xs do
+        let fvarId := x.fvarId!
+        unless processed.contains fvarId do
+          let xType ← inferType x
+          if fvarsFound.contains fvarId then
+            -- Collect free vars in `x`s type and mark as processed
+            fvarsFound := update fvarsFound xType
+            processed := processed.insert fvarId
+            modified := true
+          else if (← isProp xType) then
+            -- If `x` is a proposition, and all theorem variables in `x`s type have already been found
+            -- add it to `fvarsFound` and mark it as processed.
+            if checkTypeFVars thmVars fvarsFound xType then
+              fvarsFound := fvarsFound.insert fvarId
+              processed := processed.insert fvarId
+              modified := true
+          else if (← fvarId.getDecl).binderInfo matches .instImplicit then
+            -- If `x` is instance implicit, check whether
+            -- we have found all free variables needed to synthesize instance
+            if (← canBeSynthesized thmVars fvarsFound xType) then
+              fvarsFound := fvarsFound.insert fvarId
+              fvarsFound := update fvarsFound xType
+              processed := processed.insert fvarId
+              modified := true
+      if fvarsFound.size == numParams then
+        return .ok
+      if !modified then
+        break
+    let mut pos := #[]
+    for h : i in [:xs.size] do
+      let fvarId := xs[i].fvarId!
+      unless fvarsFound.contains fvarId do
+        pos := pos.push i
+    return .missing pos.toList
+
+/--
+Given a theorem with proof `proof` and `numParams` parameters, returns a message
+containing the parameters at positions `paramPos`.
+-/
+private def ppParamsAt (proof : Expr) (numParams : Nat) (paramPos : List Nat) : MetaM MessageData := do
+  forallBoundedTelescope (← inferType proof) numParams fun xs _ => do
+    let mut msg := m!""
+    let mut first := true
+    for h : i in [:xs.size] do
+      if paramPos.contains i then
+        let x := xs[i]
+        if first then first := false else msg := msg ++ "\n"
+        msg := msg ++ m!"{x} : {← inferType x}"
+    addMessageContextFull msg
+
+/--
+Creates an E-matching theorem for a theorem with proof `proof`, `numParams` parameters, and the given set of patterns.
+Pattern variables are represented using de Bruijn indices.
+-/
+def mkEMatchTheoremCore (origin : Origin) (levelParams : Array Name) (numParams : Nat) (proof : Expr) (patterns : List Expr) : MetaM EMatchTheorem := do
+  let (patterns, symbols, bvarFound) ← NormalizePattern.main patterns
+  trace[grind.ematch.pattern] "{MessageData.ofConst proof}: {patterns.map ppPattern}"
+  if let .missing pos ← checkCoverage proof numParams bvarFound then
+     let pats : MessageData := m!"{patterns.map ppPattern}"
+     throwError "invalid pattern(s) for `{← origin.pp}`{indentD pats}\nthe following theorem parameters cannot be instantiated:{indentD (← ppParamsAt proof numParams pos)}"
+  return {
+    proof, patterns, numParams, symbols
+    levelParams, origin
+  }
+
+private def getProofFor (declName : Name) : CoreM Expr := do
+  let .thmInfo info ← getConstInfo declName
+    | throwError "`{declName}` is not a theorem"
+  let us := info.levelParams.map mkLevelParam
+  return mkConst declName us
+
+/--
+Creates an E-matching theorem for `declName` with `numParams` parameters, and the given set of patterns.
+Pattern variables are represented using de Bruijn indices.
+-/
+def mkEMatchTheorem (declName : Name) (numParams : Nat) (patterns : List Expr) : MetaM EMatchTheorem := do
+  mkEMatchTheoremCore (.decl declName) #[] numParams (← getProofFor declName) patterns
+
+/--
+Given a theorem with proof `proof` and type of the form `∀ (a_1 ... a_n), lhs = rhs`,
+creates an E-matching pattern for it using `addEMatchTheorem n [lhs]`
+If `normalizePattern` is true, it applies the `grind` simplification theorems and simprocs to the pattern.
+-/
+def mkEMatchEqTheoremCore (origin : Origin) (levelParams : Array Name) (proof : Expr) (normalizePattern : Bool) (useLhs : Bool) : MetaM EMatchTheorem := do
+  let (numParams, patterns) ← forallTelescopeReducing (← inferType proof) fun xs type => do
+    let (lhs, rhs) ← match_expr type with
+      | Eq _ lhs rhs => pure (lhs, rhs)
+      | Iff lhs rhs => pure (lhs, rhs)
+      | HEq _ lhs _ rhs => pure (lhs, rhs)
+      | _ => throwError "invalid E-matching equality theorem, conclusion must be an equality{indentExpr type}"
+    let pat := if useLhs then lhs else rhs
+    let pat ← preprocessPattern pat normalizePattern
+    return (xs.size, [pat.abstract xs])
+  mkEMatchTheoremCore origin levelParams numParams proof patterns
+
+/--
+Given theorem with name `declName` and type of the form `∀ (a_1 ... a_n), lhs = rhs`,
+creates an E-matching pattern for it using `addEMatchTheorem n [lhs]`
+
+If `normalizePattern` is true, it applies the `grind` simplification theorems and simprocs to the
+pattern.
+-/
+def mkEMatchEqTheorem (declName : Name) (normalizePattern := true) (useLhs : Bool := true) : MetaM EMatchTheorem := do
+  mkEMatchEqTheoremCore (.decl declName) #[] (← getProofFor declName) normalizePattern useLhs
+
+/--
+Adds an E-matching theorem to the environment.
+See `mkEMatchTheorem`.
+-/
+def addEMatchTheorem (declName : Name) (numParams : Nat) (patterns : List Expr) : MetaM Unit := do
+  ematchTheoremsExt.add (← mkEMatchTheorem declName numParams patterns)
+
+/--
+Adds an E-matching equality theorem to the environment.
+See `mkEMatchEqTheorem`.
+-/
+def addEMatchEqTheorem (declName : Name) : MetaM Unit := do
+  ematchTheoremsExt.add (← mkEMatchEqTheorem declName)
+
+/-- Returns the E-matching theorems registered in the environment. -/
+def getEMatchTheorems : CoreM EMatchTheorems :=
+  return ematchTheoremsExt.getState (← getEnv)
+
+private inductive TheoremKind where
+  | eqLhs | eqRhs | eqBoth | fwd | bwd | default
+  deriving Inhabited, BEq
+
+private def TheoremKind.toAttribute : TheoremKind → String
+  | .eqLhs   => "[grind =]"
+  | .eqRhs   => "[grind =_]"
+  | .eqBoth  => "[grind _=_]"
+  | .fwd     => "[grind →]"
+  | .bwd     => "[grind ←]"
+  | .default => "[grind]"
+
+private def TheoremKind.explainFailure : TheoremKind → String
+  | .eqLhs   => "failed to find pattern in the left-hand side of the theorem's conclusion"
+  | .eqRhs   => "failed to find pattern in the right-hand side of the theorem's conclusion"
+  | .eqBoth  => unreachable! -- eqBoth is a macro
+  | .fwd     => "failed to find patterns in the antecedents of the theorem"
+  | .bwd     => "failed to find patterns in the theorem's conclusion"
+  | .default => "failed to find patterns"
+
+/-- Returns the types of `xs` that are propositions. -/
+private def getPropTypes (xs : Array Expr) : MetaM (Array Expr) :=
+  xs.filterMapM fun x => do
+    let type ← inferType x
+    if (← isProp type) then return some type else return none
+
+/-- State for the (pattern) `CollectorM` monad -/
+private structure Collector.State where
+  /-- Pattern found so far. -/
+  patterns  : Array Expr := #[]
+  done      : Bool := false
+
+private structure Collector.Context where
+  proof : Expr
+  xs    : Array Expr
+
+/-- Monad for collecting patterns for a theorem. -/
+private abbrev CollectorM := ReaderT Collector.Context $ StateRefT Collector.State NormalizePattern.M
+
+/-- Similar to `getPatternFn?`, but operates on expressions that do not contain loose de Bruijn variables. -/
+private def isPatternFnCandidate (f : Expr) : CollectorM Bool := do
+  match f with
+  | .const declName _ => return !isForbidden declName
+  | .fvar .. => return !(← read).xs.contains f
+  | _ => return false
+
+private def addNewPattern (p : Expr) : CollectorM Unit := do
+  trace[grind.ematch.pattern.search] "found pattern: {ppPattern p}"
+  let bvarsFound := (← getThe NormalizePattern.State).bvarsFound
+  let done := (← checkCoverage (← read).proof (← read).xs.size bvarsFound) matches .ok
+  if done then
+    trace[grind.ematch.pattern.search] "found full coverage"
+  modify fun s => { s with patterns := s.patterns.push p, done }
+
+private partial def collect (e : Expr) : CollectorM Unit := do
+  if (← get).done then return ()
+  match e with
+  | .app .. =>
+    let f := e.getAppFn
+    if (← isPatternFnCandidate f) then
+      let saved ← getThe NormalizePattern.State
+      try
+        trace[grind.ematch.pattern.search] "candidate: {e}"
+        let p := e.abstract (← read).xs
+        unless p.hasLooseBVars do
+          trace[grind.ematch.pattern.search] "skip, does not contain pattern variables"
+          return ()
+        let p ← NormalizePattern.normalizePattern p
+        if saved.bvarsFound.size < (← getThe NormalizePattern.State).bvarsFound.size then
+          addNewPattern p
+          return ()
+        trace[grind.ematch.pattern.search] "skip, no new variables covered"
+        -- restore state and continue search
+        set saved
+      catch _ =>
+        -- restore state and continue search
+        trace[grind.ematch.pattern.search] "skip, exception during normalization"
+        set saved
+    let args := e.getAppArgs
+    for arg in args, flag in (← NormalizePattern.getPatternSupportMask f args.size) do
+      unless flag do
+        collect arg
+  | .forallE _ d b _ =>
+    if (← pure e.isArrow <&&> isProp d <&&> isProp b) then
+      collect d
+      collect b
+  | _ => return ()
+
+private def collectPatterns? (proof : Expr) (xs : Array Expr) (searchPlaces : Array Expr) : MetaM (Option (List Expr × List HeadIndex)) := do
+  let go : CollectorM (Option (List Expr)) := do
+    for place in searchPlaces do
+      let place ← preprocessPattern place
+      collect place
+      if (← get).done then
+        return some ((← get).patterns.toList)
+    return none
+  let (some ps, s) ← go { proof, xs } |>.run' {} |>.run {}
+    | return none
+  return some (ps, s.symbols.toList)
+
+private def mkEMatchTheoremWithKind? (origin : Origin) (levelParams : Array Name) (proof : Expr) (kind : TheoremKind) : MetaM (Option EMatchTheorem) := do
+  if kind == .eqLhs then
+    return (← mkEMatchEqTheoremCore origin levelParams proof (normalizePattern := false) (useLhs := true))
+  else if kind == .eqRhs then
+    return (← mkEMatchEqTheoremCore origin levelParams proof (normalizePattern := false) (useLhs := false))
+  let type ← inferType proof
+  forallTelescopeReducing type fun xs type => do
+    let searchPlaces ← match kind with
+      | .fwd =>
+        let ps ← getPropTypes xs
+        if ps.isEmpty then
+          throwError "invalid `grind` forward theorem, theorem `{← origin.pp}` does not have proposional hypotheses"
+        pure ps
+      | .bwd => pure #[type]
+      | .default => pure <| #[type] ++ (← getPropTypes xs)
+      | _ => unreachable!
+    go xs searchPlaces
+where
+  go (xs : Array Expr) (searchPlaces : Array Expr) : MetaM (Option EMatchTheorem) := do
+    let some (patterns, symbols) ← collectPatterns? proof xs searchPlaces
+      | return none
+    let numParams := xs.size
+    trace[grind.ematch.pattern] "{← origin.pp}: {patterns.map ppPattern}"
+    return some {
+      proof, patterns, numParams, symbols
+      levelParams, origin
+    }
+
+private def getKind (stx : Syntax) : TheoremKind :=
+  if stx[1].isNone then
+    .default
+  else if stx[1][0].getKind == ``Parser.Attr.grindEq then
+    .eqLhs
+  else if stx[1][0].getKind == ``Parser.Attr.grindFwd then
+    .fwd
+  else if stx[1][0].getKind == ``Parser.Attr.grindEqRhs then
+    .eqRhs
+  else if stx[1][0].getKind == ``Parser.Attr.grindEqBoth then
+    .eqBoth
+  else
+    .bwd
+
+private def addGrindEqAttr (declName : Name) (attrKind : AttributeKind) (useLhs := true) : MetaM Unit := do
+  if (← getConstInfo declName).isTheorem then
+    ematchTheoremsExt.add (← mkEMatchEqTheorem declName (normalizePattern := true) (useLhs := useLhs)) attrKind
+  else if let some eqns ← getEqnsFor? declName then
+    unless useLhs do
+      throwError "`{declName}` is a definition, you must only use the left-hand side for extracting patterns"
+    for eqn in eqns do
+      ematchTheoremsExt.add (← mkEMatchEqTheorem eqn) attrKind
+  else
+    throwError "`[grind_eq]` attribute can only be applied to equational theorems or function definitions"
+
+private def addGrindAttr (declName : Name) (attrKind : AttributeKind) (thmKind : TheoremKind) : MetaM Unit := do
+  if thmKind == .eqLhs then
+    addGrindEqAttr declName attrKind (useLhs := true)
+  else if thmKind == .eqRhs then
+    addGrindEqAttr declName attrKind (useLhs := false)
+  else if thmKind == .eqBoth then
+    addGrindEqAttr declName attrKind (useLhs := true)
+    addGrindEqAttr declName attrKind (useLhs := false)
+  else if !(← getConstInfo declName).isTheorem then
+    addGrindEqAttr declName attrKind
+  else
+    let some thm ← mkEMatchTheoremWithKind? (.decl declName) #[] (← getProofFor declName) thmKind
+      | throwError "`@{thmKind.toAttribute} theorem {declName}` {thmKind.explainFailure}, consider using different options or the `grind_pattern` command"
+    ematchTheoremsExt.add thm attrKind
+
+builtin_initialize
+  registerBuiltinAttribute {
+    name := `grind
+    descr :=
+      "The `[grind_eq]` attribute is used to annotate equational theorems and functions.\
+      When applied to an equational theorem, it marks the theorem for use in heuristic instantiations by the `grind` tactic.\
+      When applied to a function, it automatically annotates the equational theorems associated with that function.\
+      The `grind` tactic utilizes annotated theorems to add instances of matching patterns into the local context during proof search.\
+      For example, if a theorem `@[grind_eq] theorem foo_idempotent : foo (foo x) = foo x` is annotated,\
+      `grind` will add an instance of this theorem to the local context whenever it encounters the pattern `foo (foo x)`."
+    applicationTime := .afterCompilation
+    add := fun declName stx attrKind => do
+      addGrindAttr declName attrKind (getKind stx) |>.run' {}
+  }
+
+end Lean.Meta.Grind

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

@@ -0,0 +1,34 @@
+/-
+Copyright (c) 2024 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
+-/
+prelude
+import Init.Grind.Lemmas
+import Lean.Meta.Tactic.Grind.Types
+import Lean.Meta.Tactic.Grind.Internalize
+import Lean.Meta.Tactic.Grind.Simp
+
+namespace Lean.Meta.Grind
+/--
+If `parent` is a projection-application `proj_i c`,
+check whether the root of the equivalence class containing `c` is a constructor-application `ctor ... a_i ...`.
+If so, internalize the term `proj_i (ctor ... a_i ...)` and add the equality `proj_i (ctor ... a_i ...) = a_i`.
+-/
+def propagateForallProp (parent : Expr) : GoalM Unit := do
+  let .forallE n p q bi := parent | return ()
+  trace[grind.debug.forallPropagator] "{parent}"
+  unless (← isEqTrue p) do return ()
+  trace[grind.debug.forallPropagator] "isEqTrue, {parent}"
+  let h₁ ← mkEqTrueProof p
+  let qh₁ := q.instantiate1 (mkApp2 (mkConst ``of_eq_true) p h₁)
+  let r ← simp qh₁
+  let q := mkLambda n bi p q
+  let q' := r.expr
+  internalize q' (← getGeneration parent)
+  trace[grind.debug.forallPropagator] "q': {q'} for{indentExpr parent}"
+  let h₂ ← r.getProof
+  let h := mkApp5 (mkConst ``Lean.Grind.forall_propagator) p q q' h₁ h₂
+  pushEq parent q' h
+
+end Lean.Meta.Grind

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

@@ -0,0 +1,139 @@
+/-
+Copyright (c) 2024 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
+-/
+prelude
+import Init.Grind.Util
+import Lean.Meta.LitValues
+import Lean.Meta.Match.MatcherInfo
+import Lean.Meta.Match.MatchEqsExt
+import Lean.Meta.Tactic.Grind.Types
+import Lean.Meta.Tactic.Grind.Util
+
+namespace Lean.Meta.Grind
+
+/-- Adds `e` to congruence table. -/
+def addCongrTable (e : Expr) : GoalM Unit := do
+  if let some { e := e' } := (← get).congrTable.find? { e } then
+    -- `f` and `g` must have the same type.
+    -- See paper: Congruence Closure in Intensional Type Theory
+    let f := e.getAppFn
+    let g := e'.getAppFn
+    unless isSameExpr f g do
+      unless (← hasSameType f g) do
+        trace[grind.issues] "found congruence between{indentExpr e}\nand{indentExpr e'}\nbut functions have different types"
+        return ()
+    trace[grind.debug.congr] "{e} = {e'}"
+    pushEqHEq e e' congrPlaceholderProof
+    let node ← getENode e
+    setENode e { node with congr := e' }
+  else
+    modify fun s => { s with congrTable := s.congrTable.insert { e } }
+
+private def updateAppMap (e : Expr) : GoalM Unit := do
+  let key := e.toHeadIndex
+  modify fun s => { s with
+    appMap := if let some es := s.appMap.find? key then
+      s.appMap.insert key (e :: es)
+    else
+      s.appMap.insert key [e]
+  }
+
+mutual
+/-- Internalizes the nested ground terms in the given pattern. -/
+private partial def internalizePattern (pattern : Expr) (generation : Nat) : GoalM Expr := do
+  if pattern.isBVar || isPatternDontCare pattern then
+    return pattern
+  else if let some e := groundPattern? pattern then
+    let e ← shareCommon (← canon (← normalizeLevels (← unfoldReducible e)))
+    internalize e generation
+    return mkGroundPattern e
+  else pattern.withApp fun f args => do
+    return mkAppN f (← args.mapM (internalizePattern · generation))
+
+private partial 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)) }
+  trace[grind.ematch] "activated `{thm.origin.key}`, {thm.patterns.map ppPattern}"
+  modify fun s => { s with newThms := s.newThms.push thm }
+
+/--
+If `Config.matchEqs` is set to `true`, and `f` is `match`-auxiliary function,
+adds its equations to `newThms`.
+-/
+private partial def addMatchEqns (f : Expr) (generation : Nat) : GoalM Unit := do
+  if !(← getConfig).matchEqs then return ()
+  let .const declName _ := f | return ()
+  if !(← isMatcher declName) then return ()
+  if (← get).matchEqNames.contains declName then return ()
+  modify fun s => { s with matchEqNames := s.matchEqNames.insert declName }
+  for eqn in (← Match.getEquationsFor declName).eqnNames do
+    -- We disable pattern normalization to prevent the `match`-expression to be reduced.
+    activateTheorem (← mkEMatchEqTheorem eqn (normalizePattern := false)) generation
+
+private partial def activateTheoremPatterns (fName : Name) (generation : Nat) : GoalM Unit := do
+  if let some (thms, thmMap) := (← get).thmMap.retrieve? fName then
+    modify fun s => { s with thmMap }
+    let appMap := (← get).appMap
+    for thm in thms do
+      let symbols := thm.symbols.filter fun sym => !appMap.contains sym
+      let thm := { thm with symbols }
+      match symbols with
+      | [] => activateTheorem thm generation
+      | _ =>
+        trace[grind.ematch] "reinsert `{thm.origin.key}`"
+        modify fun s => { s with thmMap := s.thmMap.insert thm }
+
+partial def internalize (e : Expr) (generation : Nat) : GoalM Unit := do
+  if (← alreadyInternalized e) then return ()
+  trace[grind.internalize] "{e}"
+  match e with
+  | .bvar .. => unreachable!
+  | .sort .. => return ()
+  | .fvar .. | .letE .. | .lam .. =>
+    mkENodeCore e (ctor := false) (interpreted := false) (generation := generation)
+  | .forallE _ d _ _ =>
+    mkENodeCore e (ctor := false) (interpreted := false) (generation := generation)
+    if (← isProp d <&&> isProp e) then
+      internalize d generation
+      registerParent e d
+      propagateUp e
+  | .lit .. | .const .. =>
+    mkENode e generation
+  | .mvar ..
+  | .mdata ..
+  | .proj .. =>
+    trace[grind.issues] "unexpected term during internalization{indentExpr e}"
+    mkENodeCore e (ctor := false) (interpreted := false) (generation := generation)
+  | .app .. =>
+    if (← isLitValue e) then
+      -- We do not want to internalize the components of a literal value.
+      mkENode e generation
+    else e.withApp fun f args => do
+      addMatchEqns f generation
+      if f.isConstOf ``Lean.Grind.nestedProof && args.size == 2 then
+        -- We only internalize the proposition. We can skip the proof because of
+        -- proof irrelevance
+        let c := args[0]!
+        internalize c generation
+        registerParent e c
+      else
+        if let .const fName _ := f then
+          activateTheoremPatterns fName generation
+        else
+          internalize f generation
+          registerParent e f
+        for h : i in [: args.size] do
+          let arg := args[i]
+          internalize arg generation
+          registerParent e arg
+      mkENode e generation
+      addCongrTable e
+      updateAppMap e
+      propagateUp e
+end
+
+end Lean.Meta.Grind

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

@@ -0,0 +1,154 @@
+/-
+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
+-/
+prelude
+import Init.Grind.Lemmas
+import Lean.Meta.Tactic.Assert
+import Lean.Meta.Tactic.Grind.Simp
+import Lean.Meta.Tactic.Grind.Types
+import Lean.Meta.Tactic.Grind.Cases
+import Lean.Meta.Tactic.Grind.Injection
+import Lean.Meta.Tactic.Grind.Core
+
+namespace Lean.Meta.Grind
+
+private inductive IntroResult where
+  | done
+  | newHyp (fvarId : FVarId) (goal : Goal)
+  | newDepHyp (goal : Goal)
+  | newLocal (fvarId : FVarId) (goal : Goal)
+  deriving Inhabited
+
+private def introNext (goal : Goal) (generation : Nat) : GrindM IntroResult := do
+  let target ← goal.mvarId.getType
+  if target.isArrow then
+    goal.mvarId.withContext do
+      let p := target.bindingDomain!
+      if !(← isProp p) then
+        let (fvarId, mvarId) ← goal.mvarId.intro1P
+        return .newLocal fvarId { goal with mvarId }
+      else
+        let tag ← goal.mvarId.getTag
+        let q := target.bindingBody!
+        -- TODO: keep applying simp/eraseIrrelevantMData/canon/shareCommon until no progress
+        let r ← simp p
+        let fvarId ← mkFreshFVarId
+        let lctx := (← getLCtx).mkLocalDecl fvarId target.bindingName! r.expr target.bindingInfo!
+        let mvarNew ← mkFreshExprMVarAt lctx (← getLocalInstances) q .syntheticOpaque tag
+        let mvarIdNew := mvarNew.mvarId!
+        mvarIdNew.withContext do
+          let h ← mkLambdaFVars #[mkFVar fvarId] mvarNew
+          match r.proof? with
+          | some he =>
+            let hNew := mkAppN (mkConst ``Lean.Grind.intro_with_eq) #[p, r.expr, q, he, h]
+            goal.mvarId.assign hNew
+            return .newHyp fvarId { goal with mvarId := mvarIdNew }
+          | none =>
+            -- `p` and `p'` are definitionally equal
+            goal.mvarId.assign h
+            return .newHyp fvarId { goal with mvarId := mvarIdNew }
+  else if target.isLet || target.isForall || target.isLetFun then
+    let (fvarId, mvarId) ← goal.mvarId.intro1P
+    mvarId.withContext do
+      let localDecl ← fvarId.getDecl
+      if (← isProp localDecl.type) then
+        -- Add a non-dependent copy
+        let mvarId ← mvarId.assert (← mkFreshUserName localDecl.userName) localDecl.type (mkFVar fvarId)
+        return .newDepHyp { goal with mvarId }
+      else
+        let goal := { goal with mvarId }
+        if target.isLet || target.isLetFun then
+          let v := (← fvarId.getDecl).value
+          let r ← simp v
+          let x ← shareCommon (mkFVar fvarId)
+          let goal ← GoalM.run' goal <| addNewEq x r.expr (← r.getProof) generation
+          return .newLocal fvarId goal
+        else
+          return .newLocal fvarId goal
+  else
+    return .done
+
+private def isCasesCandidate (type : Expr) : MetaM Bool := do
+  let .const declName _ := type.getAppFn | return false
+  isGrindCasesTarget declName
+
+private def applyCases? (goal : Goal) (fvarId : FVarId) : MetaM (Option (List Goal)) := goal.mvarId.withContext do
+  if (← isCasesCandidate (← fvarId.getType)) then
+    let mvarIds ← cases goal.mvarId (mkFVar fvarId)
+    return mvarIds.map fun mvarId => { goal with mvarId }
+  else
+    return none
+
+private def applyInjection? (goal : Goal) (fvarId : FVarId) : MetaM (Option Goal) := do
+  if let some mvarId ← injection? goal.mvarId fvarId then
+    return some { goal with mvarId }
+  else
+    return none
+
+/-- Introduce new hypotheses (and apply `by_contra`) until goal is of the form `... ⊢ False` -/
+partial def intros (goal : Goal) (generation : Nat) : GrindM (List Goal) := do
+  let rec go (goal : Goal) : StateRefT (Array Goal) GrindM Unit := do
+    if goal.inconsistent then
+      return ()
+    match (← introNext goal generation) with
+    | .done =>
+      if let some mvarId ← goal.mvarId.byContra? then
+        go { goal with mvarId }
+      else
+        modify fun s => s.push goal
+    | .newHyp fvarId goal =>
+      if let some goals ← applyCases? goal fvarId then
+        goals.forM go
+      else if let some goal ← applyInjection? goal fvarId then
+        go goal
+      else
+        go (← GoalM.run' goal <| addHypothesis fvarId generation)
+    | .newDepHyp goal =>
+      go goal
+    | .newLocal fvarId goal =>
+      if let some goals ← applyCases? goal fvarId then
+        goals.forM go
+      else
+        go goal
+  let (_, goals) ← (go goal).run #[]
+  return goals.toList
+
+/-- Asserts a new fact `prop` with proof `proof` to the given `goal`. -/
+def assertAt (goal : Goal) (proof : Expr) (prop : Expr) (generation : Nat) : GrindM (List Goal) := do
+  if (← isCasesCandidate prop) then
+    let mvarId ← goal.mvarId.assert (← mkFreshUserName `h) prop proof
+    let goal := { goal with mvarId }
+    intros goal generation
+  else
+    let goal ← GoalM.run' goal do
+      let r ← simp prop
+      let prop' := r.expr
+      let proof' ← mkEqMP (← r.getProof) proof
+      add prop' proof' generation
+    if goal.inconsistent then return [] else return [goal]
+
+/-- Asserts next fact in the `goal` fact queue. -/
+def assertNext? (goal : Goal) : GrindM (Option (List Goal)) := do
+  let some (fact, newFacts) := goal.newFacts.dequeue?
+    | return none
+  assertAt { goal with newFacts } fact.proof fact.prop fact.generation
+
+partial def iterate (goal : Goal) (f : Goal → GrindM (Option (List Goal))) : GrindM (List Goal) := do
+  go [goal] []
+where
+  go (todo : List Goal) (result : List Goal) : GrindM (List Goal) := do
+    match todo with
+    | [] => return result
+    | goal :: todo =>
+      if let some goalsNew ← f goal then
+        go (goalsNew ++ todo) result
+      else
+        go todo (goal :: result)
+
+/-- Asserts all facts in the `goal` fact queue. -/
+partial def assertAll (goal : Goal) : GrindM (List Goal) := do
+  iterate goal assertNext?
+
+end Lean.Meta.Grind

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

@@ -0,0 +1,109 @@
+/-
+Copyright (c) 2024 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
+-/
+prelude
+import Lean.Meta.Tactic.Grind.Types
+import Lean.Meta.Tactic.Grind.Proof
+
+namespace Lean.Meta.Grind
+
+/-!
+Debugging support code for checking basic invariants.
+-/
+
+private def checkEqc (root : ENode) : GoalM Unit := do
+  let mut size := 0
+  let mut curr := root.self
+  repeat
+    size := size + 1
+    -- The root of `curr` must be `root`
+    assert! isSameExpr (← getRoot curr) root.self
+    -- Check congruence root
+    if curr.isApp then
+      if let some { e } := (← get).congrTable.find? { e := curr } then
+        if (← hasSameType e.getAppFn curr.getAppFn) then
+          assert! isSameExpr e (← getCongrRoot curr)
+      else
+        assert! (← isCongrRoot curr)
+    -- If the equivalence class does not have HEq proofs, then the types must be definitionally equal.
+    unless root.heqProofs do
+      assert! (← hasSameType curr root.self)
+    -- Starting at `curr`, following the `target?` field leads to `root`.
+    let mut n := curr
+    repeat
+      if let some target ← getTarget? n then
+        n := target
+      else
+        break
+    assert! isSameExpr n root.self
+    -- Go to next element
+    curr ← getNext curr
+    if isSameExpr root.self curr then
+      break
+  -- The size of the equivalence class is correct.
+  assert! root.size == size
+
+private def checkParents (e : Expr) : GoalM Unit := do
+  if (← isRoot e) then
+    for parent in (← getParents e) do
+      let mut found := false
+      let checkChild (child : Expr) : GoalM Bool := do
+        let some childRoot ← getRoot? child | return false
+        return isSameExpr childRoot e
+      -- There is an argument `arg` s.t. root of `arg` is `e`.
+      for arg in parent.getAppArgs do
+        if (← checkChild arg) then
+          found := true
+          break
+      -- Recall that we have support for `Expr.forallE` propagation. See `ForallProp.lean`.
+      if let .forallE _ d _ _ := parent then
+        if (← checkChild d) then
+          found := true
+      unless found do
+        assert! (← checkChild parent.getAppFn)
+  else
+    -- All the parents are stored in the root of the equivalence class.
+    assert! (← getParents e).isEmpty
+
+private def checkPtrEqImpliesStructEq : GoalM Unit := do
+  let nodes ← getENodes
+  for h₁ : i in [: nodes.size] do
+    let n₁ := nodes[i]
+    for h₂ : j in [i+1 : nodes.size] do
+      let n₂ := nodes[j]
+      -- We don't have multiple nodes for the same expression
+      assert! !isSameExpr n₁.self n₂.self
+      -- and the two expressions must not be structurally equal
+      assert! !Expr.equal n₁.self n₂.self
+
+private def checkProofs : GoalM Unit := do
+  let eqcs ← getEqcs
+  for eqc in eqcs do
+    for a in eqc do
+      for b in eqc do
+        unless isSameExpr a b do
+          let p ← mkEqHEqProof a b
+          trace[grind.debug.proofs] "{a} = {b}"
+          check p
+          trace[grind.debug.proofs] "checked: {← inferType p}"
+
+/--
+Checks basic invariants if `grind.debug` is enabled.
+-/
+def checkInvariants (expensive := false) : GoalM Unit := do
+  if grind.debug.get (← getOptions) then
+    for (_, node) in (← get).enodes do
+      checkParents node.self
+      if isSameExpr node.self node.root then
+        checkEqc node
+    if expensive then
+      checkPtrEqImpliesStructEq
+  if expensive && grind.debug.proofs.get (← getOptions) then
+    checkProofs
+
+def Goal.checkInvariants (goal : Goal) (expensive := false) : GrindM Unit :=
+  discard <| GoalM.run' goal <| Grind.checkInvariants expensive
+
+end Lean.Meta.Grind

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

@@ -0,0 +1,86 @@
+/-
+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
+-/
+prelude
+import Init.Grind.Lemmas
+import Lean.Meta.Tactic.Util
+import Lean.Meta.Tactic.Grind.RevertAll
+import Lean.Meta.Tactic.Grind.PropagatorAttr
+import Lean.Meta.Tactic.Grind.Proj
+import Lean.Meta.Tactic.Grind.ForallProp
+import Lean.Meta.Tactic.Grind.Util
+import Lean.Meta.Tactic.Grind.Inv
+import Lean.Meta.Tactic.Grind.Intro
+import Lean.Meta.Tactic.Grind.EMatch
+import Lean.Meta.Tactic.Grind.SimpUtil
+
+namespace Lean.Meta.Grind
+
+def mkMethods (fallback : Fallback) : CoreM Methods := do
+  let builtinPropagators ← builtinPropagatorsRef.get
+  return {
+    fallback
+    propagateUp := fun e => do
+     propagateForallProp e
+     let .const declName _ := e.getAppFn | return ()
+     propagateProjEq e
+     if let some prop := builtinPropagators.up[declName]? then
+       prop e
+    propagateDown := fun e => do
+     let .const declName _ := e.getAppFn | return ()
+     if let some prop := builtinPropagators.down[declName]? then
+       prop e
+  }
+
+def GrindM.run (x : GrindM α) (mainDeclName : Name) (config : Grind.Config) (fallback : Fallback) : MetaM α := do
+  let scState := ShareCommon.State.mk _
+  let (falseExpr, scState) := ShareCommon.State.shareCommon scState (mkConst ``False)
+  let (trueExpr, scState)  := ShareCommon.State.shareCommon scState (mkConst ``True)
+  let simprocs ← Grind.getSimprocs
+  let simp ← Grind.getSimpContext
+  x (← mkMethods fallback).toMethodsRef { mainDeclName, config, simprocs, simp } |>.run' { scState, trueExpr, falseExpr }
+
+private def mkGoal (mvarId : MVarId) : GrindM Goal := do
+  let trueExpr ← getTrueExpr
+  let falseExpr ← getFalseExpr
+  let thmMap ← getEMatchTheorems
+  GoalM.run' { mvarId, thmMap } do
+    mkENodeCore falseExpr (interpreted := true) (ctor := false) (generation := 0)
+    mkENodeCore trueExpr (interpreted := true) (ctor := false) (generation := 0)
+
+private def initCore (mvarId : MVarId) : GrindM (List Goal) := do
+  mvarId.ensureProp
+  -- TODO: abstract metavars
+  mvarId.ensureNoMVar
+  let mvarId ← mvarId.clearAuxDecls
+  let mvarId ← mvarId.revertAll
+  let mvarId ← mvarId.unfoldReducible
+  let mvarId ← mvarId.betaReduce
+  let goals ← intros (← mkGoal mvarId) (generation := 0)
+  goals.forM (·.checkInvariants (expensive := true))
+  return goals.filter fun goal => !goal.inconsistent
+
+def all (goals : List Goal) (f : Goal → GrindM (List Goal)) : GrindM (List Goal) := do
+  goals.foldlM (init := []) fun acc goal => return acc ++ (← f goal)
+
+/-- A very simple strategy -/
+private def simple (goals : List Goal) : GrindM (List Goal) := do
+  all goals ematchStar
+
+def main (mvarId : MVarId) (config : Grind.Config) (mainDeclName : Name) (fallback : Fallback) : MetaM (List MVarId) := do
+  let go : GrindM (List MVarId) := do
+    let goals ← initCore mvarId
+    let goals ← simple goals
+    let goals ← goals.filterMapM fun goal => do
+      if goal.inconsistent then return none
+      let goal ← GoalM.run' goal fallback
+      if goal.inconsistent then return none
+      if (← goal.mvarId.isAssigned) then return none
+      return some goal
+    trace[grind.debug.final] "{← ppGoals goals}"
+    return goals.map (·.mvarId)
+  go.run mainDeclName config fallback
+
+end Lean.Meta.Grind

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

@@ -0,0 +1,66 @@
+/-
+Copyright (c) 2024 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
+-/
+prelude
+import Init.Grind.Util
+import Lean.Util.PtrSet
+import Lean.Meta.Basic
+import Lean.Meta.InferType
+
+namespace Lean.Meta.Grind
+
+unsafe def markNestedProofsImpl (e : Expr) : MetaM Expr := do
+  visit e |>.run' mkPtrMap
+where
+  visit (e : Expr) : StateRefT (PtrMap Expr Expr) MetaM Expr := do
+    if (← isProof e) then
+      if e.isAppOf ``Lean.Grind.nestedProof then
+        return e -- `e` is already marked
+      if let some r := (← get).find? e then
+        return r
+      let prop ← inferType e
+      let e' := mkApp2 (mkConst ``Lean.Grind.nestedProof) prop e
+      modify fun s => s.insert e e'
+      return e'
+    -- Remark: we have to process `Expr.proj` since we only
+    -- fold projections later during term internalization
+    unless e.isApp || e.isForall || e.isProj do
+      return e
+    -- Check whether it is cached
+    if let some r := (← get).find? e then
+      return r
+    let e' ← match e with
+      | .app .. => e.withApp fun f args => do
+        let mut modified := false
+        let mut args := args
+        for i in [:args.size] do
+          let arg := args[i]!
+          let arg' ← visit arg
+          unless ptrEq arg arg' do
+            args := args.set! i arg'
+            modified := true
+        if modified then
+          pure <| mkAppN f args
+        else
+          pure e
+      | .proj _ _ b =>
+        pure <| e.updateProj! (← visit b)
+      | .forallE _ d b _ =>
+        -- Recall that we have `ForallProp.lean`.
+        let d' ← visit d
+        let b' ← if b.hasLooseBVars then pure b else visit b
+        pure <| e.updateForallE! d' b'
+      | _ => unreachable!
+    modify fun s => s.insert e e'
+    return e'
+
+/--
+Wrap nested proofs `e` with `Lean.Grind.nestedProof`-applications.
+Recall that the congruence closure module has special support for `Lean.Grind.nestedProof`.
+-/
+def markNestedProofs (e : Expr) : MetaM Expr :=
+  unsafe markNestedProofsImpl e
+
+end Lean.Meta.Grind