chore: basic functionality tests for modify/alter

Makes `MessageData.ofConstName` available without needing to import the
pretty printer. Any code making use of `MessageData` can write `m!" ...
{.ofConstName n} ... "` to have the name print with hover information.
More error messages now have hover information.

* Now `.ofConstName` also has a boolean flag to make names print fully
qualified. Default: false.
* Now `.ofConstName` will sanitize names that aren't constants. It is OK
to use it in `"unknown constant '{.ofConstName constName}'"` errors.

Usability note: it is more user-friendly to have "has already been
declared" errors report the fully qualified name. For this, write
`m!"{.ofConstName n true} has already been declared"`.

.github/workflows/check-prelude.yml

@@ -11,7 +11,9 @@ jobs:
         with:
           # the default is to use a virtual merge commit between the PR and master: just use the PR
           ref: ${{ github.event.pull_request.head.sha }}
-          sparse-checkout: src/Lean
+          sparse-checkout: |
+            src/Lean
+            src/Std
       - name: Check Prelude
         run: |
           failed_files=""
@@ -19,8 +21,8 @@ jobs:
             if ! grep -q "^prelude$" "$file"; then
               failed_files="$failed_files$file\n"
             fi
-          done < <(find src/Lean -name '*.lean' -print0)
+          done < <(find src/Lean src/Std -name '*.lean' -print0)
           if [ -n "$failed_files" ]; then
             echo -e "The following files should use 'prelude':\n$failed_files"
             exit 1
-          fi
+          fi

.github/workflows/nix-ci.yml

@@ -96,7 +96,7 @@ jobs:
           nix build $NIX_BUILD_ARGS .#cacheRoots -o push-build
       - name: Test
         run: |
-          nix build --keep-failed $NIX_BUILD_ARGS .#test -o push-test || (ln -s /tmp/nix-build-*/source/src/build/ ./push-test; false)
+          nix build --keep-failed $NIX_BUILD_ARGS .#test -o push-test || (ln -s /tmp/nix-build-*/build/source/src/build ./push-test; false)
       - name: Test Summary
         uses: test-summary/action@v2
         with:

CODEOWNERS

@@ -4,14 +4,14 @@
 # Listed persons will automatically be asked by GitHub to review a PR touching these paths.
 # If multiple names are listed, a review by any of them is considered sufficient by default.
 
-/.github/ @Kha @semorrison
-/RELEASES.md @semorrison
+/.github/ @Kha @kim-em
+/RELEASES.md @kim-em
 /src/kernel/ @leodemoura
 /src/lake/ @tydeu
 /src/Lean/Compiler/ @leodemoura
 /src/Lean/Data/Lsp/ @mhuisi
-/src/Lean/Elab/Deriving/ @semorrison
-/src/Lean/Elab/Tactic/ @semorrison
+/src/Lean/Elab/Deriving/ @kim-em
+/src/Lean/Elab/Tactic/ @kim-em
 /src/Lean/Language/ @Kha
 /src/Lean/Meta/Tactic/ @leodemoura
 /src/Lean/Parser/ @Kha
@@ -19,7 +19,7 @@
 /src/Lean/PrettyPrinter/Delaborator/ @kmill
 /src/Lean/Server/ @mhuisi
 /src/Lean/Widget/ @Vtec234
-/src/Init/Data/ @semorrison
+/src/Init/Data/ @kim-em
 /src/Init/Data/Array/Lemmas.lean @digama0
 /src/Init/Data/List/Lemmas.lean @digama0
 /src/Init/Data/List/BasicAux.lean @digama0
@@ -45,3 +45,4 @@
 /src/Std/ @TwoFX
 /src/Std/Tactic/BVDecide/ @hargoniX
 /src/Lean/Elab/Tactic/BVDecide/ @hargoniX
+/src/Std/Sat/ @hargoniX

doc/make/msys2.md

@@ -15,6 +15,13 @@ Mode](https://docs.microsoft.com/en-us/windows/apps/get-started/enable-your-devi
 which will allow Lean to create symlinks that e.g. enable go-to-definition in
 the stdlib.
 
+## Installing the Windows SDK
+
+Install the Windows SDK from [Microsoft](https://developer.microsoft.com/en-us/windows/downloads/windows-sdk/).
+The oldest supported version is 10.0.18362.0. If you installed the Windows SDK to the default location,
+then there should be a directory with the version number at `C:\Program Files (x86)\Windows Kits\10\Include`.
+If there are multiple directories, only the highest version number matters.
+
 ## Installing dependencies
 
 [The official webpage of MSYS2][msys2] provides one-click installers.

doc/monads/applicatives.lean

@@ -138,8 +138,8 @@ definition:
 
 -/
 instance : Applicative List where
-  pure := List.pure
-  seq f x := List.bind f fun y => Functor.map y (x ())
+  pure := List.singleton
+  seq f x := List.flatMap f fun y => Functor.map y (x ())
 /-!
 
 Notice you can now sequence a _list_ of functions and a _list_ of items.

doc/monads/laws.lean

@@ -128,8 +128,8 @@ Applying the identity function through an applicative structure should not chang
 values or structure.  For example:
 -/
 instance : Applicative List where
-  pure := List.pure
-  seq f x := List.bind f fun y => Functor.map y (x ())
+  pure := List.singleton
+  seq f x := List.flatMap f fun y => Functor.map y (x ())
 
 #eval pure id <*> [1, 2, 3]  -- [1, 2, 3]
 /-!
@@ -235,8 +235,8 @@ structure or its values.
 Left identity is `x >>= pure = x` and is demonstrated by the following examples on a monadic `List`:
 -/
 instance : Monad List  where
-  pure := List.pure
-  bind := List.bind
+  pure := List.singleton
+  bind := List.flatMap
 
 def a := ["apple", "orange"]
 

doc/monads/monads.lean

@@ -192,8 +192,8 @@ implementation of `pure` and `bind`.
 
 -/
 instance : Monad List  where
-  pure := List.pure
-  bind := List.bind
+  pure := List.singleton
+  bind := List.flatMap
 /-!
 
 Like you saw with the applicative `seq` operator, the `bind` operator applies the given function

doc/setup.md

@@ -7,7 +7,7 @@ Platforms built & tested by our CI, available as binary releases via elan (see b
 * x86-64 Linux with glibc 2.27+
 * x86-64 macOS 10.15+
 * aarch64 (Apple Silicon) macOS 10.15+
-* x86-64 Windows 10+
+* x86-64 Windows 11 (any version), Windows 10 (version 1903 or higher), Windows Server 2022
 
 ### Tier 2
 

script/prepare-llvm-mingw.sh

@@ -31,14 +31,20 @@ cp /clang64/lib/{crtbegin,crtend,crt2,dllcrt2}.o stage1/lib/
 # runtime
 (cd llvm; cp --parents lib/clang/*/lib/*/libclang_rt.builtins* ../stage1)
 # further dependencies
-cp /clang64/lib/lib{m,bcrypt,mingw32,moldname,mingwex,msvcrt,pthread,advapi32,shell32,user32,kernel32,ucrtbase,psapi,iphlpapi,userenv,ws2_32,dbghelp,ole32}.* /clang64/lib/libgmp.a /clang64/lib/libuv.a llvm/lib/lib{c++,c++abi,unwind}.a stage1/lib/
+# Note: even though we're linking against libraries like `libbcrypt.a` which appear to be static libraries from the file name,
+# we're not actually linking statically against the code.
+# Rather, `libbcrypt.a` is an import library (see https://en.wikipedia.org/wiki/Dynamic-link_library#Import_libraries) that just
+# tells the compiler how to dynamically link against `bcrypt.dll` (which is located in the System32 folder).
+# This distinction is relevant specifically for `libicu.a`/`icu.dll` because there we want updates to the time zone database to
+# be delivered to users via Windows Update without having to recompile Lean or Lean programs.
+cp /clang64/lib/lib{m,bcrypt,mingw32,moldname,mingwex,msvcrt,pthread,advapi32,shell32,user32,kernel32,ucrtbase,psapi,iphlpapi,userenv,ws2_32,dbghelp,ole32,icu}.* /clang64/lib/libgmp.a /clang64/lib/libuv.a llvm/lib/lib{c++,c++abi,unwind}.a stage1/lib/
 echo -n " -DLEAN_STANDALONE=ON"
 echo -n " -DCMAKE_C_COMPILER=$PWD/stage1/bin/clang.exe -DCMAKE_C_COMPILER_WORKS=1 -DCMAKE_CXX_COMPILER=$PWD/llvm/bin/clang++.exe -DCMAKE_CXX_COMPILER_WORKS=1 -DLEAN_CXX_STDLIB='-lc++ -lc++abi'"
 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'"
-# when not using the above flags, link GMP dynamically/as usual
+# 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
 echo -n " -DAUTO_THREAD_FINALIZATION=OFF -DSTAGE0_AUTO_THREAD_FINALIZATION=OFF"

src/CMakeLists.txt

@@ -155,6 +155,10 @@ endif ()
 # We want explicit stack probes in huge Lean stack frames for robust stack overflow detection
 string(APPEND LEANC_EXTRA_FLAGS " -fstack-clash-protection")
 
+# This makes signed integer overflow guaranteed to match 2's complement.
+string(APPEND CMAKE_CXX_FLAGS " -fwrapv")
+string(APPEND LEANC_EXTRA_FLAGS " -fwrapv")
+
 if(NOT MULTI_THREAD)
   message(STATUS "Disabled multi-thread support, it will not be safe to run multiple threads in parallel")
   set(AUTO_THREAD_FINALIZATION OFF)
@@ -297,6 +301,23 @@ if(NOT LEAN_STANDALONE)
   string(APPEND LEAN_EXTRA_LINKER_FLAGS " ${LIBUV_LIBRARIES}")
 endif()
 
+# Windows SDK (for ICU)
+if(${CMAKE_SYSTEM_NAME} MATCHES "Windows")
+  # Pass 'tools' to skip MSVC version check (as MSVC/Visual Studio is not necessarily installed)
+  find_package(WindowsSDK REQUIRED COMPONENTS tools)
+
+  # This will give a semicolon-separated list of include directories
+  get_windowssdk_include_dirs(${WINDOWSSDK_LATEST_DIR} WINDOWSSDK_INCLUDE_DIRS)
+
+  # To successfully build against Windows SDK headers, the Windows SDK headers must have lower
+  # priority than other system headers, so use `-idirafter`. Unfortunately, CMake does not
+  # support this using `include_directories`.
+  string(REPLACE ";" "\" -idirafter \"" WINDOWSSDK_INCLUDE_DIRS "${WINDOWSSDK_INCLUDE_DIRS}")
+  string(APPEND CMAKE_CXX_FLAGS " -idirafter \"${WINDOWSSDK_INCLUDE_DIRS}\"")
+
+  string(APPEND LEAN_EXTRA_LINKER_FLAGS " -licu")
+endif()
+
 # ccache
 if(CCACHE AND NOT CMAKE_CXX_COMPILER_LAUNCHER AND NOT CMAKE_C_COMPILER_LAUNCHER)
   find_program(CCACHE_PATH ccache)
@@ -480,7 +501,7 @@ endif()
 # Git HASH
 if(USE_GITHASH)
   include(GetGitRevisionDescription)
-  get_git_head_revision(GIT_REFSPEC GIT_SHA1)
+  get_git_head_revision(GIT_REFSPEC GIT_SHA1 ALLOW_LOOKING_ABOVE_CMAKE_SOURCE_DIR)
   if(${GIT_SHA1} MATCHES "GITDIR-NOTFOUND")
     message(STATUS "Failed to read git_sha1")
     set(GIT_SHA1 "")

src/Init.lean

@@ -35,3 +35,4 @@ import Init.Ext
 import Init.Omega
 import Init.MacroTrace
 import Init.Grind
+import Init.While

src/Init/Control/Basic.lean

@@ -8,6 +8,28 @@ import Init.Core
 
 universe u v w
 
+/--
+A `ForIn'` instance, which handles `for h : x in c do`,
+can also handle `for x in x do` by ignoring `h`, and so provides a `ForIn` instance.
+-/
+instance (priority := low) instForInOfForIn' [ForIn' m ρ α d] : ForIn m ρ α where
+  forIn x b f := forIn' x b fun a _ => f a
+
+@[simp] theorem forIn'_eq_forIn [d : Membership α ρ] [ForIn' m ρ α d] {β} [Monad m] (x : ρ) (b : β)
+    (f : (a : α) → a ∈ x → β → m (ForInStep β)) (g : (a : α) → β → m (ForInStep β))
+    (h : ∀ a m b, f a m b = g a b) :
+    forIn' x b f = forIn x b g := by
+  simp [instForInOfForIn']
+  congr
+  apply funext
+  intro a
+  apply funext
+  intro m
+  apply funext
+  intro b
+  simp [h]
+  rfl
+
 @[reducible]
 def Functor.mapRev {f : Type u → Type v} [Functor f] {α β : Type u} : f α → (α → β) → f β :=
   fun a f => f <$> a

src/Init/Control/StateRef.lean

@@ -6,8 +6,7 @@ Authors: Leonardo de Moura, Sebastian Ullrich
 The State monad transformer using IO references.
 -/
 prelude
-import Init.System.IO
-import Init.Control.State
+import Init.System.ST
 
 def StateRefT' (ω : Type) (σ : Type) (m : Type → Type) (α : Type) : Type := ReaderT (ST.Ref ω σ) m α
 

src/Init/Core.lean

@@ -324,7 +324,6 @@ class ForIn' (m : Type u₁ → Type u₂) (ρ : Type u) (α : outParam (Type v)
 
 export ForIn' (forIn')
 
-
 /--
 Auxiliary type used to compile `do` notation. It is used when compiling a do block
 nested inside a combinator like `tryCatch`. It encodes the possible ways the

src/Init/Data.lean

@@ -19,6 +19,7 @@ import Init.Data.ByteArray
 import Init.Data.FloatArray
 import Init.Data.Fin
 import Init.Data.UInt
+import Init.Data.SInt
 import Init.Data.Float
 import Init.Data.Option
 import Init.Data.Ord

src/Init/Data/Array/Basic.lean

@@ -25,6 +25,8 @@ variable {α : Type u}
 
 namespace Array
 
+@[deprecated toList (since := "2024-10-13")] abbrev data := @toList
+
 /-! ### Preliminary theorems -/
 
 @[simp] theorem size_set (a : Array α) (i : Fin a.size) (v : α) : (set a i v).size = a.size :=
@@ -78,6 +80,42 @@ theorem ext' {as bs : Array α} (h : as.toList = bs.toList) : as = bs := by
 
 @[simp] theorem size_toArray (as : List α) : as.toArray.size = as.length := by simp [size]
 
+@[simp] theorem getElem_toList {a : Array α} {i : Nat} (h : i < a.size) : a.toList[i] = a[i] := rfl
+
+/-- `a ∈ as` is a predicate which asserts that `a` is in the array `as`. -/
+-- NB: This is defined as a structure rather than a plain def so that a lemma
+-- like `sizeOf_lt_of_mem` will not apply with no actual arrays around.
+structure Mem (as : Array α) (a : α) : Prop where
+  val : a ∈ as.toList
+
+instance : Membership α (Array α) where
+  mem := Mem
+
+theorem mem_def {a : α} {as : Array α} : a ∈ as ↔ a ∈ as.toList :=
+  ⟨fun | .mk h => h, Array.Mem.mk⟩
+
+@[simp] theorem getElem_mem {l : Array α} {i : Nat} (h : i < l.size) : l[i] ∈ l := by
+  rw [Array.mem_def, ← getElem_toList]
+  apply List.getElem_mem
+
+end Array
+
+namespace List
+
+@[simp] theorem toArray_toList (a : Array α) : a.toList.toArray = a := rfl
+
+@[simp] theorem getElem_toArray {a : List α} {i : Nat} (h : i < a.toArray.size) :
+    a.toArray[i] = a[i]'(by simpa using h) := rfl
+
+@[simp] theorem getElem?_toArray {a : List α} {i : Nat} : a.toArray[i]? = a[i]? := rfl
+
+@[simp] theorem getElem!_toArray [Inhabited α] {a : List α} {i : Nat} :
+    a.toArray[i]! = a[i]! := rfl
+
+end List
+
+namespace Array
+
 @[deprecated toList_toArray (since := "2024-09-09")] abbrev data_toArray := @toList_toArray
 
 @[deprecated Array.toList (since := "2024-09-10")] abbrev Array.data := @Array.toList
@@ -219,12 +257,15 @@ def swapAt! (a : Array α) (i : Nat) (v : α) : α × Array α :=
     have : Inhabited (α × Array α) := ⟨(v, a)⟩
     panic! ("index " ++ toString i ++ " out of bounds")
 
-def shrink (a : Array α) (n : Nat) : Array α :=
+/-- `take a n` returns the first `n` elements of `a`. -/
+def take (a : Array α) (n : Nat) : Array α :=
   let rec loop
     | 0,   a => a
     | n+1, a => loop n a.pop
   loop (a.size - n) a
 
+@[deprecated take (since := "2024-10-22")] abbrev shrink := @take
+
 @[inline]
 unsafe def modifyMUnsafe [Monad m] (a : Array α) (i : Nat) (f : α → m α) : m (Array α) := do
   if h : i < a.size then
@@ -291,6 +332,37 @@ protected def forIn {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m
 instance : ForIn m (Array α) α where
   forIn := Array.forIn
 
+/-- See comment at `forInUnsafe` -/
+@[inline] unsafe def forIn'Unsafe {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] (as : Array α) (b : β) (f : (a : α) → a ∈ as → β → m (ForInStep β)) : m β :=
+  let sz := as.usize
+  let rec @[specialize] loop (i : USize) (b : β) : m β := do
+    if i < sz then
+      let a := as.uget i lcProof
+      match (← f a lcProof b) with
+      | ForInStep.done  b => pure b
+      | ForInStep.yield b => loop (i+1) b
+    else
+      pure b
+  loop 0 b
+
+/-- Reference implementation for `forIn'` -/
+@[implemented_by Array.forIn'Unsafe]
+protected def forIn' {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] (as : Array α) (b : β) (f : (a : α) → a ∈ as → β → m (ForInStep β)) : m β :=
+  let rec loop (i : Nat) (h : i ≤ as.size) (b : β) : m β := do
+    match i, h with
+    | 0,   _ => pure b
+    | i+1, h =>
+      have h' : i < as.size            := Nat.lt_of_lt_of_le (Nat.lt_succ_self i) h
+      have : as.size - 1 < as.size     := Nat.sub_lt (Nat.zero_lt_of_lt h') (by decide)
+      have : as.size - 1 - i < as.size := Nat.lt_of_le_of_lt (Nat.sub_le (as.size - 1) i) this
+      match (← f as[as.size - 1 - i] (getElem_mem this) b) with
+      | ForInStep.done b  => pure b
+      | ForInStep.yield b => loop i (Nat.le_of_lt h') b
+  loop as.size (Nat.le_refl _) b
+
+instance : ForIn' m (Array α) α inferInstance where
+  forIn' := Array.forIn'
+
 /-- See comment at `forInUnsafe` -/
 @[inline]
 unsafe def foldlMUnsafe {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] (f : β → α → m β) (init : β) (as : Array α) (start := 0) (stop := as.size) : m β :=
@@ -396,20 +468,25 @@ def mapM {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] (f : α
   decreasing_by simp_wf; decreasing_trivial_pre_omega
   map 0 (mkEmpty as.size)
 
+/-- Variant of `mapIdxM` which receives the index as a `Fin as.size`. -/
 @[inline]
-def mapIdxM {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] (as : Array α) (f : Fin as.size → α → m β) : m (Array β) :=
+def mapFinIdxM {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m]
+    (as : Array α) (f : Fin as.size → α → m β) : m (Array β) :=
   let rec @[specialize] map (i : Nat) (j : Nat) (inv : i + j = as.size) (bs : Array β) : m (Array β) := do
     match i, inv with
     | 0,    _  => pure bs
     | i+1, inv =>
-      have : j < as.size := by
+      have j_lt : j < as.size := by
         rw [← inv, Nat.add_assoc, Nat.add_comm 1 j, Nat.add_comm]
         apply Nat.le_add_right
-      let idx : Fin as.size := ⟨j, this⟩
       have : i + (j + 1) = as.size := by rw [← inv, Nat.add_comm j 1, Nat.add_assoc]
-      map i (j+1) this (bs.push (← f idx (as.get idx)))
+      map i (j+1) this (bs.push (← f ⟨j, j_lt⟩ (as.get ⟨j, j_lt⟩)))
   map as.size 0 rfl (mkEmpty as.size)
 
+@[inline]
+def mapIdxM {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] (as : Array α) (f : Nat → α → m β) : m (Array β) :=
+  as.mapFinIdxM fun i a => f i a
+
 @[inline]
 def findSomeM? {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] (as : Array α) (f : α → m (Option β)) : m (Option β) := do
   for a in as do
@@ -515,8 +592,13 @@ def foldr {α : Type u} {β : Type v} (f : α → β → β) (init : β) (as : A
 def map {α : Type u} {β : Type v} (f : α → β) (as : Array α) : Array β :=
   Id.run <| as.mapM f
 
+/-- Variant of `mapIdx` which receives the index as a `Fin as.size`. -/
 @[inline]
-def mapIdx {α : Type u} {β : Type v} (as : Array α) (f : Fin as.size → α → β) : Array β :=
+def mapFinIdx {α : Type u} {β : Type v} (as : Array α) (f : Fin as.size → α → β) : Array β :=
+  Id.run <| as.mapFinIdxM f
+
+@[inline]
+def mapIdx {α : Type u} {β : Type v} (as : Array α) (f : Nat → α → β) : Array β :=
   Id.run <| as.mapIdxM f
 
 /-- Turns `#[a, b]` into `#[(a, 0), (b, 1)]`. -/
@@ -610,7 +692,7 @@ instance : HAppend (Array α) (List α) (Array α) := ⟨Array.appendList⟩
 def flatMapM [Monad m] (f : α → m (Array β)) (as : Array α) : m (Array β) :=
   as.foldlM (init := empty) fun bs a => do return bs ++ (← f a)
 
-@[deprecated concatMapM (since := "2024-10-16")] abbrev concatMapM := @flatMapM
+@[deprecated flatMapM (since := "2024-10-16")] abbrev concatMapM := @flatMapM
 
 @[inline]
 def flatMap (f : α → Array β) (as : Array α) : Array β :=
@@ -817,9 +899,15 @@ def split (as : Array α) (p : α → Bool) : Array α × Array α :=
 
 /-! ## Auxiliary functions used in metaprogramming.
 
-We do not intend to provide verification theorems for these functions.
+We do not currently intend to provide verification theorems for these functions.
 -/
 
+/- ### reduceOption -/
+
+/-- Drop `none`s from a Array, and replace each remaining `some a` with `a`. -/
+@[inline] def reduceOption (as : Array (Option α)) : Array α :=
+  as.filterMap id
+
 /-! ### eraseReps -/
 
 /--

src/Init/Data/Array/Bootstrap.lean

@@ -42,7 +42,7 @@ theorem foldrM_eq_reverse_foldlM_toList.aux [Monad m]
   unfold foldrM.fold
   match i with
   | 0 => simp [List.foldlM, List.take]
-  | i+1 => rw [← List.take_concat_get _ _ h]; simp [← (aux f arr · i)]; rfl
+  | i+1 => rw [← List.take_concat_get _ _ h]; simp [← (aux f arr · i)]
 
 theorem foldrM_eq_reverse_foldlM_toList [Monad m] (f : α → β → m β) (init : β) (arr : Array α) :
     arr.foldrM f init = arr.toList.reverse.foldlM (fun x y => f y x) init := by

src/Init/Data/Array/DecidableEq.lean

@@ -6,6 +6,8 @@ Authors: Leonardo de Moura
 prelude
 import Init.Data.Array.Basic
 import Init.Data.BEq
+import Init.Data.Nat.Lemmas
+import Init.Data.List.Nat.BEq
 import Init.ByCases
 
 namespace Array
@@ -26,6 +28,14 @@ theorem rel_of_isEqvAux
       subst hj'
       exact heqv.left
 
+theorem isEqvAux_of_rel (r : α → α → Bool) (a b : Array α) (hsz : a.size = b.size) (i : Nat) (hi : i ≤ a.size)
+    (w : ∀ j, (hj : j < i) → r (a[j]'(Nat.lt_of_lt_of_le hj hi)) (b[j]'(Nat.lt_of_lt_of_le hj (hsz ▸ hi)))) : Array.isEqvAux a b hsz r i hi := by
+  induction i with
+  | zero => simp [Array.isEqvAux]
+  | succ i ih =>
+    simp only [isEqvAux, Bool.and_eq_true]
+    exact ⟨w i (Nat.lt_add_one i), ih _ fun j hj => w j (Nat.lt_add_right 1 hj)⟩
+
 theorem rel_of_isEqv (r : α → α → Bool) (a b : Array α) :
     Array.isEqv a b r → ∃ h : a.size = b.size, ∀ (i : Nat) (h' : i < a.size), r (a[i]) (b[i]'(h ▸ h')) := by
   simp only [isEqv]
@@ -33,6 +43,29 @@ theorem rel_of_isEqv (r : α → α → Bool) (a b : Array α) :
   · exact fun h' => ⟨h, rel_of_isEqvAux r a b h a.size (Nat.le_refl ..) h'⟩
   · intro; contradiction
 
+theorem isEqv_iff_rel (a b : Array α) (r) :
+    Array.isEqv a b r ↔ ∃ h : a.size = b.size, ∀ (i : Nat) (h' : i < a.size), r (a[i]) (b[i]'(h ▸ h')) :=
+  ⟨rel_of_isEqv r a b, fun ⟨h, w⟩ => by
+    simp only [isEqv, ← h, ↓reduceDIte]
+    exact isEqvAux_of_rel r a b h a.size (by simp [h]) w⟩
+
+theorem isEqv_eq_decide (a b : Array α) (r) :
+    Array.isEqv a b r =
+      if h : a.size = b.size then decide (∀ (i : Nat) (h' : i < a.size), r (a[i]) (b[i]'(h ▸ h'))) else false := by
+  by_cases h : Array.isEqv a b r
+  · simp only [h, Bool.true_eq]
+    simp only [isEqv_iff_rel] at h
+    obtain ⟨h, w⟩ := h
+    simp [h, w]
+  · let h' := h
+    simp only [Bool.not_eq_true] at h
+    simp only [h, Bool.false_eq, dite_eq_right_iff, decide_eq_false_iff_not, Classical.not_forall,
+      Bool.not_eq_true]
+    simpa [isEqv_iff_rel] using h'
+
+@[simp] theorem isEqv_toList [BEq α] (a b : Array α) : (a.toList.isEqv b.toList r) = (a.isEqv b r) := by
+  simp [isEqv_eq_decide, List.isEqv_eq_decide]
+
 theorem eq_of_isEqv [DecidableEq α] (a b : Array α) (h : Array.isEqv a b (fun x y => x = y)) : a = b := by
   have ⟨h, h'⟩ := rel_of_isEqv (fun x y => x = y) a b h
   exact ext _ _ h (fun i lt _ => by simpa using h' i lt)
@@ -56,4 +89,22 @@ instance [DecidableEq α] : DecidableEq (Array α) :=
     | true  => isTrue (eq_of_isEqv a b h)
     | false => isFalse fun h' => by subst h'; rw [isEqv_self] at h; contradiction
 
+theorem beq_eq_decide [BEq α] (a b : Array α) :
+    (a == b) = if h : a.size = b.size then
+      decide (∀ (i : Nat) (h' : i < a.size), a[i] == b[i]'(h ▸ h')) else false := by
+  simp [BEq.beq, isEqv_eq_decide]
+
+@[simp] theorem beq_toList [BEq α] (a b : Array α) : (a.toList == b.toList) = (a == b) := by
+  simp [beq_eq_decide, List.beq_eq_decide]
+
 end Array
+
+namespace List
+
+@[simp] theorem isEqv_toArray [BEq α] (a b : List α) : (a.toArray.isEqv b.toArray r) = (a.isEqv b r) := by
+  simp [isEqv_eq_decide, Array.isEqv_eq_decide]
+
+@[simp] theorem beq_toArray [BEq α] (a b : List α) : (a.toArray == b.toArray) = (a == b) := by
+  simp [beq_eq_decide, Array.beq_eq_decide]
+
+end List

src/Init/Data/Array/GetLit.lean

@@ -41,6 +41,6 @@ where
   getLit_eq (as : Array α) (i : Nat) (h₁ : as.size = n) (h₂ : i < n) : as.getLit i h₁ h₂ = getElem as.toList i ((id (α := as.toList.length = n) h₁) ▸ h₂) :=
     rfl
   go (i : Nat) (hi : i ≤ as.size) : toListLitAux as n hsz i hi (as.toList.drop i) = as.toList := by
-    induction i <;> simp [getLit_eq, List.get_drop_eq_drop, toListLitAux, List.drop, *]
+    induction i <;> simp only [List.drop, toListLitAux, getLit_eq, List.get_drop_eq_drop, *]
 
 end Array

src/Init/Data/Array/Lemmas.lean

@@ -8,6 +8,8 @@ import Init.Data.Nat.Lemmas
 import Init.Data.List.Impl
 import Init.Data.List.Monadic
 import Init.Data.List.Range
+import Init.Data.List.Nat.TakeDrop
+import Init.Data.List.Nat.Modify
 import Init.Data.Array.Mem
 import Init.TacticsExtra
 
@@ -17,12 +19,9 @@ import Init.TacticsExtra
 
 namespace Array
 
-@[simp] theorem getElem_toList {a : Array α} {i : Nat} (h : i < a.size) : a.toList[i] = a[i] := rfl
-
 @[simp] theorem getElem_mk {xs : List α} {i : Nat} (h : i < xs.length) : (Array.mk xs)[i] = xs[i] := rfl
 
-theorem getElem_eq_getElem_toList {a : Array α} (h : i < a.size) : a[i] = a.toList[i] := by
-  by_cases i < a.size <;> (try simp [*]) <;> rfl
+theorem getElem_eq_getElem_toList {a : Array α} (h : i < a.size) : a[i] = a.toList[i] := rfl
 
 theorem getElem?_eq_getElem {a : Array α} {i : Nat} (h : i < a.size) : a[i]? = some a[i] :=
   getElem?_pos ..
@@ -43,21 +42,32 @@ theorem getElem?_eq_getElem?_toList (a : Array α) (i : Nat) : a[i]? = a.toList[
   rw [getElem?_eq]
   split <;> simp_all
 
-theorem get_push_lt (a : Array α) (x : α) (i : Nat) (h : i < a.size) :
+theorem getElem_push_lt (a : Array α) (x : α) (i : Nat) (h : i < a.size) :
     have : i < (a.push x).size := by simp [*, Nat.lt_succ_of_le, Nat.le_of_lt]
     (a.push x)[i] = a[i] := by
   simp only [push, getElem_eq_getElem_toList, List.concat_eq_append, List.getElem_append_left, h]
 
-@[simp] theorem get_push_eq (a : Array α) (x : α) : (a.push x)[a.size] = x := by
+@[simp] theorem getElem_push_eq (a : Array α) (x : α) : (a.push x)[a.size] = x := by
   simp only [push, getElem_eq_getElem_toList, List.concat_eq_append]
   rw [List.getElem_append_right] <;> simp [getElem_eq_getElem_toList, Nat.zero_lt_one]
 
-theorem get_push (a : Array α) (x : α) (i : Nat) (h : i < (a.push x).size) :
+theorem getElem_push (a : Array α) (x : α) (i : Nat) (h : i < (a.push x).size) :
     (a.push x)[i] = if h : i < a.size then a[i] else x := by
   by_cases h' : i < a.size
-  · simp [get_push_lt, h']
+  · simp [getElem_push_lt, h']
   · simp at h
-    simp [get_push_lt, Nat.le_antisymm (Nat.le_of_lt_succ h) (Nat.ge_of_not_lt h')]
+    simp [getElem_push_lt, Nat.le_antisymm (Nat.le_of_lt_succ h) (Nat.ge_of_not_lt h')]
+
+@[deprecated getElem_push (since := "2024-10-21")] abbrev get_push := @getElem_push
+@[deprecated getElem_push_lt (since := "2024-10-21")] abbrev get_push_lt := @getElem_push_lt
+@[deprecated getElem_push_eq (since := "2024-10-21")] abbrev get_push_eq := @getElem_push_eq
+
+@[simp] theorem get!_eq_getElem! [Inhabited α] (a : Array α) (i : Nat) : a.get! i = a[i]! := by
+  simp [getElem!_def, get!, getD]
+  split <;> rename_i h
+  · simp [getElem?_eq_getElem h]
+    rfl
+  · simp [getElem?_eq_none_iff.2 (by simpa using h)]
 
 end Array
 
@@ -74,12 +84,8 @@ We prefer to pull `List.toArray` outwards.
     (a.toArrayAux b).size = b.size + a.length := by
   simp [size]
 
-@[simp] theorem toArray_toList (a : Array α) : a.toList.toArray = a := rfl
-
-@[simp] theorem getElem_toArray {a : List α} {i : Nat} (h : i < a.toArray.size) :
-    a.toArray[i] = a[i]'(by simpa using h) := rfl
-
-@[simp] theorem getElem?_toArray {a : List α} {i : Nat} : a.toArray[i]? = a[i]? := rfl
+@[simp] theorem mem_toArray {a : α} {l : List α} : a ∈ l.toArray ↔ a ∈ l := by
+  simp [mem_def]
 
 @[simp] theorem push_toArray (l : List α) (a : α) : l.toArray.push a = (l ++ [a]).toArray := by
   apply ext'
@@ -90,6 +96,57 @@ We prefer to pull `List.toArray` outwards.
   funext a
   simp
 
+@[simp] theorem isEmpty_toArray (l : List α) : l.toArray.isEmpty = l.isEmpty := by
+  cases l <;> simp
+
+@[simp] theorem toArray_singleton (a : α) : (List.singleton a).toArray = singleton a := rfl
+
+@[simp] theorem back_toArray [Inhabited α] (l : List α) : l.toArray.back = l.getLast! := by
+  simp only [back, size_toArray, Array.get!_eq_getElem!, getElem!_toArray, getLast!_eq_getElem!]
+
+@[simp] theorem forIn_loop_toArray [Monad m] (l : List α) (f : α → β → m (ForInStep β)) (i : Nat)
+    (h : i ≤ l.length) (b : β) :
+    Array.forIn.loop l.toArray f i h b = (l.drop (l.length - i)).forIn b f := by
+  induction i generalizing l b with
+  | zero => simp [Array.forIn.loop]
+  | succ i ih =>
+    simp only [Array.forIn.loop, size_toArray, getElem_toArray, ih, forIn_eq_forIn]
+    rw [Nat.sub_add_eq, List.drop_sub_one (by omega), List.getElem?_eq_getElem (by omega)]
+    simp only [Option.toList_some, singleton_append, forIn_cons]
+    have t : l.length - 1 - i = l.length - i - 1 := by omega
+    simp only [t]
+    congr
+
+@[simp] theorem forIn_toArray [Monad m] (l : List α) (b : β) (f : α → β → m (ForInStep β)) :
+    forIn l.toArray b f = forIn l b f := by
+  change l.toArray.forIn b f = l.forIn b f
+  rw [Array.forIn, forIn_loop_toArray]
+  simp
+
+@[simp] theorem forIn'_loop_toArray [Monad m] (l : List α) (f : (a : α) → a ∈ l.toArray → β → m (ForInStep β)) (i : Nat)
+    (h : i ≤ l.length) (b : β) :
+    Array.forIn'.loop l.toArray f i h b =
+      forIn' (l.drop (l.length - i)) b (fun a m b => f a (by simpa using mem_of_mem_drop m) b) := by
+  induction i generalizing l b with
+  | zero =>
+    simp [Array.forIn'.loop]
+  | succ i ih =>
+    simp only [Array.forIn'.loop, size_toArray, getElem_toArray, ih, forIn_eq_forIn]
+    have t : drop (l.length - (i + 1)) l = l[l.length - i - 1] :: drop (l.length - i) l := by
+      simp only [Nat.sub_add_eq]
+      rw [List.drop_sub_one (by omega), List.getElem?_eq_getElem (by omega)]
+      simp only [Option.toList_some, singleton_append]
+    simp [t]
+    have t : l.length - 1 - i = l.length - i - 1 := by omega
+    simp only [t]
+    congr
+
+@[simp] theorem forIn'_toArray [Monad m] (l : List α) (b : β) (f : (a : α) → a ∈ l.toArray → β → m (ForInStep β)) :
+    forIn' l.toArray b f = forIn' l b (fun a m b => f a (mem_toArray.mpr m) b) := by
+  change Array.forIn' _ _ _ = List.forIn' _ _ _
+  rw [Array.forIn', forIn'_loop_toArray]
+  simp [List.forIn_eq_forIn]
+
 theorem foldrM_toArray [Monad m] (f : α → β → m β) (init : β) (l : List α) :
     l.toArray.foldrM f init = l.foldrM f init := by
   rw [foldrM_eq_reverse_foldlM_toList]
@@ -147,6 +204,9 @@ namespace Array
 
 @[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
@@ -155,6 +215,9 @@ namespace Array
 
 @[simp] theorem size_mk (as : List α) : (Array.mk as).size = as.length := by simp [size]
 
+@[simp] theorem isEmpty_toList {l : Array α} : l.toList.isEmpty = l.isEmpty := by
+  rcases l with ⟨_ | _⟩ <;> simp
+
 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 [foldrM_eq_reverse_foldlM_toList, -size_push]
@@ -231,9 +294,6 @@ theorem anyM_stop_le_start [Monad m] (p : α → m Bool) (as : Array α) (start
     (h : min stop as.size ≤ start) : anyM p as start stop = pure false := by
   rw [anyM_eq_anyM_loop, anyM.loop, dif_neg (Nat.not_lt.2 h)]
 
-theorem mem_def {a : α} {as : Array α} : a ∈ as ↔ a ∈ as.toList :=
-  ⟨fun | .mk h => h, Array.Mem.mk⟩
-
 @[simp] theorem not_mem_empty (a : α) : ¬(a ∈ #[]) := by
   simp [mem_def]
 
@@ -248,7 +308,7 @@ theorem size_uset (a : Array α) (v i h) : (uset a i v h).size = a.size := by si
 @[simp] theorem get_eq_getElem (a : Array α) (i : Fin _) : a.get i = a[i.1] := rfl
 
 theorem getElem?_lt
-    (a : Array α) {i : Nat} (h : i < a.size) : a[i]? = some (a[i]) := dif_pos h
+    (a : Array α) {i : Nat} (h : i < a.size) : a[i]? = some a[i] := dif_pos h
 
 theorem getElem?_ge
     (a : Array α) {i : Nat} (h : i ≥ a.size) : a[i]? = none := dif_neg (Nat.not_lt_of_le h)
@@ -271,8 +331,10 @@ theorem getD_get? (a : Array α) (i : Nat) (d : α) :
 
 theorem get!_eq_getD [Inhabited α] (a : Array α) : a.get! n = a.getD n default := rfl
 
-@[simp] theorem get!_eq_getElem? [Inhabited α] (a : Array α) (i : Nat) : a.get! i = (a.get? i).getD default := by
-  by_cases p : i < a.size <;> simp [getD_get?, get!_eq_getD, p]
+@[simp] theorem get!_eq_getElem? [Inhabited α] (a : Array α) (i : Nat) :
+    a.get! i = (a.get? i).getD default := by
+  by_cases p : i < a.size <;>
+  simp only [get!_eq_getD, getD_eq_get?, getD_get?, p, get?_eq_getElem?]
 
 /-! # set -/
 
@@ -352,8 +414,8 @@ theorem getElem_ofFn_go (f : Fin n → α) (i) {acc k}
     simp only [dif_pos hin]
     rw [getElem_ofFn_go f (i+1) _ hin (by simp [*]) (fun j hj => ?hacc)]
     cases (Nat.lt_or_eq_of_le <| Nat.le_of_lt_succ (by simpa using hj)) with
-    | inl hj => simp [get_push, hj, hacc j hj]
-    | inr hj => simp [get_push, *]
+    | inl hj => simp [getElem_push, hj, hacc j hj]
+    | inr hj => simp [getElem_push, *]
   else
     simp [hin, hacc k (Nat.lt_of_lt_of_le hki (Nat.le_of_not_lt (hi ▸ hin)))]
 termination_by n - i
@@ -421,18 +483,16 @@ theorem lt_of_getElem {x : α} {a : Array α} {idx : Nat} {hidx : idx < a.size}
     idx < a.size :=
   hidx
 
-theorem getElem_mem {l : Array α} {i : Nat} (h : i < l.size) : l[i] ∈ l := by
-  erw [Array.mem_def, getElem_eq_getElem_toList]
-  apply List.get_mem
-
 theorem getElem_fin_eq_getElem_toList (a : Array α) (i : Fin a.size) : a[i] = a.toList[i] := rfl
 
 @[simp] theorem ugetElem_eq_getElem (a : Array α) {i : USize} (h : i.toNat < a.size) :
   a[i] = a[i.toNat] := rfl
 
-theorem get?_len_le (a : Array α) (i : Nat) (h : a.size ≤ i) : a[i]? = none := by
+theorem getElem?_size_le (a : Array α) (i : Nat) (h : a.size ≤ i) : a[i]? = none := by
   simp [getElem?_neg, h]
 
+@[deprecated getElem?_size_le (since := "2024-10-21")] abbrev get?_len_le := @getElem?_size_le
+
 theorem getElem_mem_toList (a : Array α) (h : i < a.size) : a[i] ∈ a.toList := by
   simp only [getElem_eq_getElem_toList, List.getElem_mem]
 
@@ -440,35 +500,39 @@ theorem get?_eq_get?_toList (a : Array α) (i : Nat) : a.get? i = a.toList.get?
   simp [getElem?_eq_getElem?_toList]
 
 theorem get!_eq_get? [Inhabited α] (a : Array α) : a.get! n = (a.get? n).getD default := by
-  simp [get!_eq_getD]
+  simp only [get!_eq_getElem?, get?_eq_getElem?]
 
 theorem getElem?_eq_some_iff {as : Array α} : as[n]? = some a ↔ ∃ h : n < as.size, as[n] = a := by
   cases as
   simp [List.getElem?_eq_some_iff]
 
 @[simp] theorem back_eq_back? [Inhabited α] (a : Array α) : a.back = a.back?.getD default := by
-  simp [back, back?]
+  simp only [back, get!_eq_getElem?, get?_eq_getElem?, back?]
 
 @[simp] theorem back?_push (a : Array α) : (a.push x).back? = some x := by
   simp [back?, getElem?_eq_getElem?_toList]
 
 theorem back_push [Inhabited α] (a : Array α) : (a.push x).back = x := by simp
 
-theorem get?_push_lt (a : Array α) (x : α) (i : Nat) (h : i < a.size) :
+theorem getElem?_push_lt (a : Array α) (x : α) (i : Nat) (h : i < a.size) :
     (a.push x)[i]? = some a[i] := by
-  rw [getElem?_pos, get_push_lt]
+  rw [getElem?_pos, getElem_push_lt]
 
-theorem get?_push_eq (a : Array α) (x : α) : (a.push x)[a.size]? = some x := by
-  rw [getElem?_pos, get_push_eq]
+@[deprecated getElem?_push_lt (since := "2024-10-21")] abbrev get?_push_lt := @getElem?_push_lt
 
-theorem get?_push {a : Array α} : (a.push x)[i]? = if i = a.size then some x else a[i]? := by
+theorem getElem?_push_eq (a : Array α) (x : α) : (a.push x)[a.size]? = some x := by
+  rw [getElem?_pos, getElem_push_eq]
+
+@[deprecated getElem?_push_eq (since := "2024-10-21")] abbrev get?_push_eq := @getElem?_push_eq
+
+theorem getElem?_push {a : Array α} : (a.push x)[i]? = if i = a.size then some x else a[i]? := by
   match Nat.lt_trichotomy i a.size with
   | Or.inl g =>
     have h1 : i < a.size + 1 := by omega
     have h2 : i ≠ a.size := by omega
-    simp [getElem?_def, size_push, g, h1, h2, get_push_lt]
+    simp [getElem?_def, size_push, g, h1, h2, getElem_push_lt]
   | Or.inr (Or.inl heq) =>
-    simp [heq, getElem?_pos, get_push_eq]
+    simp [heq, getElem?_pos, getElem_push_eq]
   | Or.inr (Or.inr g) =>
     simp only [getElem?_def, size_push]
     have h1 : ¬ (i < a.size) := by omega
@@ -476,9 +540,13 @@ theorem get?_push {a : Array α} : (a.push x)[i]? = if i = a.size then some x el
     have h3 : i ≠ a.size := by omega
     simp [h1, h2, h3]
 
-@[simp] theorem get?_size {a : Array α} : a[a.size]? = none := by
+@[deprecated getElem?_push (since := "2024-10-21")] abbrev get?_push := @getElem?_push
+
+@[simp] theorem getElem?_size {a : Array α} : a[a.size]? = none := by
   simp only [getElem?_def, Nat.lt_irrefl, dite_false]
 
+@[deprecated getElem?_size (since := "2024-10-21")] abbrev get?_size := @getElem?_size
+
 @[simp] theorem toList_set (a : Array α) (i v) : (a.set i v).toList = a.toList.set i.1 v := rfl
 
 theorem get_set_eq (a : Array α) (i : Fin a.size) (v : α) :
@@ -528,6 +596,9 @@ theorem getElem?_swap (a : Array α) (i j : Fin a.size) (k : Nat) : (a.swap i j)
 @[simp] theorem swapAt_def (a : Array α) (i : Fin a.size) (v : α) :
     a.swapAt i v = (a[i.1], a.set i v) := rfl
 
+@[simp] theorem size_swapAt (a : Array α) (i : Fin a.size) (v : α) :
+    (a.swapAt i v).2.size = a.size := by simp [swapAt_def]
+
 @[simp]
 theorem swapAt!_def (a : Array α) (i : Nat) (v : α) (h : i < a.size) :
     a.swapAt! i v = (a[i], a.set ⟨i, h⟩ v) := by simp [swapAt!, h]
@@ -560,11 +631,11 @@ theorem eq_push_pop_back_of_size_ne_zero [Inhabited α] {as : Array α} (h : as.
   · simp [Nat.sub_add_cancel (Nat.zero_lt_of_ne_zero h)]
   · intros i h h'
     if hlt : i < as.pop.size then
-      rw [get_push_lt (h:=hlt), getElem_pop]
+      rw [getElem_push_lt (h:=hlt), getElem_pop]
     else
       have heq : i = as.pop.size :=
         Nat.le_antisymm (size_pop .. ▸ Nat.le_pred_of_lt h) (Nat.le_of_not_gt hlt)
-      cases heq; rw [get_push_eq, back, ←size_pop, get!_eq_getD, getD, dif_pos h]; rfl
+      cases heq; rw [getElem_push_eq, back, ←size_pop, get!_eq_getD, getD, dif_pos h]; rfl
 
 theorem eq_push_of_size_ne_zero {as : Array α} (h : as.size ≠ 0) :
     ∃ (bs : Array α) (c : α), as = bs.push c :=
@@ -642,6 +713,45 @@ 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 ▸ ‹_›)]
 
+/-! ### take -/
+
+@[simp] theorem size_take_loop (a : Array α) (n : Nat) : (take.loop n a).size = a.size - n := by
+  induction n generalizing a with
+  | zero => simp [take.loop]
+  | succ n ih =>
+    simp [take.loop, ih]
+    omega
+
+@[simp] theorem getElem_take_loop (a : Array α) (n : Nat) (i : Nat) (h : i < (take.loop n a).size) :
+    (take.loop n a)[i] = a[i]'(by simp at h; omega) := by
+  induction n generalizing a i with
+  | zero => simp [take.loop]
+  | succ n ih =>
+    simp [take.loop, ih]
+
+@[simp] theorem size_take (a : Array α) (n : Nat) : (a.take n).size = min n a.size  := by
+  simp [take]
+  omega
+
+@[simp] theorem getElem_take (a : Array α) (n : Nat) (i : Nat) (h : i < (a.take n).size) :
+    (a.take n)[i] = a[i]'(by simp at h; omega) := by
+  simp [take]
+
+@[simp] theorem toList_take (a : Array α) (n : Nat) : (a.take n).toList = a.toList.take n := by
+  apply List.ext_getElem <;> simp
+
+/-! ### forIn -/
+
+@[simp] theorem forIn_toList [Monad m] (as : Array α) (b : β) (f : α → β → m (ForInStep β)) :
+    forIn as.toList b f = forIn as b f := by
+  cases as
+  simp
+
+@[simp] theorem forIn'_toList [Monad m] (as : Array α) (b : β) (f : (a : α) → a ∈ as.toList → β → m (ForInStep β)) :
+    forIn' as.toList b f = forIn' as b (fun a m b => f a (mem_toList.mpr m) b) := by
+  cases as
+  simp
+
 /-! ### foldl / foldr -/
 
 @[simp] theorem foldlM_loop_empty [Monad m] (f : β → α → m β) (init : β) (i j : Nat) :
@@ -773,9 +883,9 @@ theorem map_induction (as : Array α) (f : α → β) (motive : Nat → Prop) (h
     · intro j h
       simp at h ⊢
       by_cases h' : j < size b
-      · rw [get_push]
+      · rw [getElem_push]
         simp_all
-      · rw [get_push, dif_neg h']
+      · rw [getElem_push, dif_neg h']
         simp only [show j = i by omega]
         exact (hs _ m).1
 
@@ -800,7 +910,7 @@ theorem map_spec (as : Array α) (f : α → β) (p : Fin as.size → β → Pro
     (as.push x).map f = (as.map f).push (f x) := by
   ext
   · simp
-  · simp only [getElem_map, get_push, size_map]
+  · simp only [getElem_map, getElem_push, size_map]
     split <;> rfl
 
 @[simp] theorem map_pop {f : α → β} {as : Array α} :
@@ -822,6 +932,12 @@ theorem getElem_modify {as : Array α} {x i} (h : i < (as.modify x f).size) :
   · simp only [Id.bind_eq, get_set _ _ _ (by simpa using h)]; split <;> simp [*]
   · rw [if_neg (mt (by rintro rfl; exact h) (by simp_all))]
 
+@[simp] theorem toList_modify (as : Array α) (f : α → α) :
+    (as.modify x f).toList = as.toList.modify f x := by
+  apply List.ext_getElem
+  · simp
+  · simp [getElem_modify, List.getElem_modify]
+
 theorem getElem_modify_self {as : Array α} {i : Nat} (f : α → α) (h : i < (as.modify i f).size) :
     (as.modify i f)[i] = f (as[i]'(by simpa using h)) := by
   simp [getElem_modify h]
@@ -831,6 +947,11 @@ theorem getElem_modify_of_ne {as : Array α} {i : Nat} (h : i ≠ j)
     (as.modify i f)[j] = as[j]'(by simpa using hj) := by
   simp [getElem_modify hj, h]
 
+theorem getElem?_modify {as : Array α} {i : Nat} {f : α → α} {j : Nat} :
+    (as.modify i f)[j]? = if i = j then as[j]?.map f else as[j]? := by
+  simp only [getElem?_def, size_modify, getElem_modify, Option.map_dif]
+  split <;> split <;> rfl
+
 /-! ### filter -/
 
 @[simp] theorem toList_filter (p : α → Bool) (l : Array α) :
@@ -892,7 +1013,7 @@ theorem filterMap_congr {as bs : Array α} (h : as = bs)
 
 theorem size_empty : (#[] : Array α).size = 0 := rfl
 
-theorem toList_empty : (#[] : Array α).toList = [] := rfl
+@[simp] theorem toList_empty : (#[] : Array α).toList = [] := rfl
 
 /-! ### append -/
 
@@ -924,18 +1045,38 @@ theorem getElem_append_right {as bs : Array α} {h : i < (as ++ bs).size} (hle :
   conv => rhs; rw [← List.getElem_append_right (h₁ := hle) (h₂ := h')]
   apply List.get_of_eq; rw [toList_append]
 
+theorem getElem?_append_left {as bs : Array α} {n : Nat} (hn : n < as.size) :
+    (as ++ bs)[n]? = as[n]? := by
+  have hn' : n < (as ++ bs).size := Nat.lt_of_lt_of_le hn <|
+    size_append .. ▸ Nat.le_add_right ..
+  simp_all [getElem?_eq_getElem, getElem_append]
+
+theorem getElem?_append_right {as bs : Array α} {n : Nat} (h : as.size ≤ n) :
+    (as ++ bs)[n]? = bs[n - as.size]? := by
+  cases as
+  cases bs
+  simp at h
+  simp [List.getElem?_append_right, h]
+
+theorem getElem?_append {as bs : Array α} {n : Nat} :
+    (as ++ bs)[n]? = if n < as.size then as[n]? else bs[n - as.size]? := by
+  split <;> rename_i h
+  · exact getElem?_append_left h
+  · exact getElem?_append_right (by simpa using h)
+
 @[simp] theorem append_nil (as : Array α) : as ++ #[] = as := by
   apply ext'; simp only [toList_append, toList_empty, List.append_nil]
 
 @[simp] theorem nil_append (as : Array α) : #[] ++ as = as := by
   apply ext'; simp only [toList_append, toList_empty, List.nil_append]
 
-theorem append_assoc (as bs cs : Array α) : as ++ bs ++ cs = as ++ (bs ++ cs) := by
+@[simp] theorem append_assoc (as bs cs : Array α) : as ++ bs ++ cs = as ++ (bs ++ cs) := by
   apply ext'; simp only [toList_append, List.append_assoc]
 
 /-! ### flatten -/
 
-@[simp] theorem toList_flatten {l : Array (Array α)} : l.flatten.toList = (l.toList.map toList).flatten := by
+@[simp] theorem toList_flatten {l : Array (Array α)} :
+    l.flatten.toList = (l.toList.map toList).flatten := by
   dsimp [flatten]
   simp only [foldl_eq_foldl_toList]
   generalize l.toList = l
@@ -1050,7 +1191,7 @@ theorem getElem_extract_loop_ge (as bs : Array α) (size start : Nat) (hge : i
       have h₂ : bs.size < (extract.loop as size (start+1) (bs.push as[start])).size := by
         rw [size_extract_loop]; apply Nat.lt_of_lt_of_le h₁; exact Nat.le_add_right ..
       have h : (extract.loop as size (start + 1) (push bs as[start]))[bs.size] = as[start] := by
-        rw [getElem_extract_loop_lt as (bs.push as[start]) size (start+1) h₁ h₂, get_push_eq]
+        rw [getElem_extract_loop_lt as (bs.push as[start]) size (start+1) h₁ h₂, getElem_push_eq]
       rw [h]; congr; rw [Nat.add_sub_cancel]
     else
       have hge : bs.size + 1 ≤ i := Nat.lt_of_le_of_ne hge hi
@@ -1077,6 +1218,14 @@ theorem getElem?_extract {as : Array α} {start stop : Nat} :
     · omega
   · rfl
 
+@[simp] theorem toList_extract (as : Array α) (start stop : Nat) :
+    (as.extract start stop).toList = (as.toList.drop start).take (stop - start) := by
+  apply List.ext_getElem
+  · simp only [length_toList, size_extract, List.length_take, List.length_drop]
+    omega
+  · intros n h₁ h₂
+    simp
+
 @[simp] theorem extract_all (as : Array α) : as.extract 0 as.size = as := by
   apply ext
   · rw [size_extract, Nat.min_self, Nat.sub_zero]
@@ -1246,7 +1395,7 @@ open Fin
       · assumption
 
 theorem getElem_swap' (a : Array α) (i j : Fin a.size) (k : Nat) (hk : k < a.size) :
-    (a.swap i j)[k]'(by simp_all) = if k = i then a[j] else if k = j then a[i]  else a[k] := by
+    (a.swap i j)[k]'(by simp_all) = if k = i then a[j] else if k = j then a[i] else a[k] := by
   split
   · simp_all only [getElem_swap_left]
   · split <;> simp_all
@@ -1256,7 +1405,7 @@ theorem getElem_swap (a : Array α) (i j : Fin a.size) (k : Nat) (hk : k < (a.sw
   apply getElem_swap'
 
 @[simp] theorem swap_swap (a : Array α) {i j : Fin a.size} :
-    (a.swap i j).swap ⟨i.1, (a.size_swap ..).symm ▸i.2⟩ ⟨j.1, (a.size_swap ..).symm ▸j.2⟩ = a := by
+    (a.swap i j).swap ⟨i.1, (a.size_swap ..).symm ▸ i.2⟩ ⟨j.1, (a.size_swap ..).symm ▸ j.2⟩ = a := by
   apply ext
   · simp only [size_swap]
   · intros
@@ -1286,9 +1435,6 @@ namespace List
 Our goal is to have `simp` "pull `List.toArray` outwards" as much as possible.
 -/
 
-@[simp] theorem mem_toArray {a : α} {l : List α} : a ∈ l.toArray ↔ a ∈ l := by
-  simp [mem_def]
-
 @[simp] theorem toListRev_toArray (l : List α) : l.toArray.toListRev = l.reverse := by
   simp
 
@@ -1297,6 +1443,10 @@ Our goal is to have `simp` "pull `List.toArray` outwards" as much as possible.
   apply ext'
   simp
 
+@[simp] theorem take_toArray (l : List α) (n : Nat) : l.toArray.take n = (l.take n).toArray := by
+  apply ext'
+  simp
+
 @[simp] theorem mapM_toArray [Monad m] [LawfulMonad m] (f : α → m β) (l : List α) :
     l.toArray.mapM f = List.toArray <$> l.mapM f := by
   simp only [← mapM'_eq_mapM, mapM_eq_foldlM]
@@ -1391,6 +1541,11 @@ theorem all_toArray (p : α → Bool) (l : List α) : l.toArray.all p = l.all p
   apply ext'
   simp
 
+@[simp] theorem modify_toArray (f : α → α) (l : List α) :
+    l.toArray.modify i f = (l.modify f i).toArray := by
+  apply ext'
+  simp
+
 @[simp] theorem filter_toArray' (p : α → Bool) (l : List α) (h : stop = l.toArray.size) :
     l.toArray.filter p 0 stop = (l.filter p).toArray := by
   subst h
@@ -1419,6 +1574,11 @@ theorem filterMap_toArray (f : α → Option β) (l : List α) :
   apply ext'
   simp
 
+@[simp] theorem toArray_extract (l : List α) (start stop : Nat) :
+    l.toArray.extract start stop = ((l.drop start).take (stop - start)).toArray := by
+  apply ext'
+  simp
+
 end List
 
 /-! ### Deprecations -/

src/Init/Data/Array/MapIdx.lean

@@ -9,56 +9,84 @@ import Init.Data.List.MapIdx
 
 namespace Array
 
-
-/-! ### mapIdx -/
+/-! ### mapFinIdx -/
 
 -- This could also be proved from `SatisfiesM_mapIdxM` in Batteries.
-theorem mapIdx_induction (as : Array α) (f : Fin as.size → α → β)
+theorem mapFinIdx_induction (as : Array α) (f : Fin as.size → α → β)
     (motive : Nat → Prop) (h0 : motive 0)
     (p : Fin as.size → β → Prop)
     (hs : ∀ i, motive i.1 → p i (f i as[i]) ∧ motive (i + 1)) :
-    motive as.size ∧ ∃ eq : (Array.mapIdx as f).size = as.size,
-      ∀ i h, p ⟨i, h⟩ ((Array.mapIdx as f)[i]) := by
+    motive as.size ∧ ∃ eq : (Array.mapFinIdx as f).size = as.size,
+      ∀ i h, p ⟨i, h⟩ ((Array.mapFinIdx as f)[i]) := by
   let rec go {bs i j h} (h₁ : j = bs.size) (h₂ : ∀ i h h', p ⟨i, h⟩ bs[i]) (hm : motive j) :
-    let arr : Array β := Array.mapIdxM.map (m := Id) as f i j h bs
+    let arr : Array β := Array.mapFinIdxM.map (m := Id) as f i j h bs
     motive as.size ∧ ∃ eq : arr.size = as.size, ∀ i h, p ⟨i, h⟩ arr[i] := by
-    induction i generalizing j bs with simp [mapIdxM.map]
+    induction i generalizing j bs with simp [mapFinIdxM.map]
     | zero =>
       have := (Nat.zero_add _).symm.trans h
       exact ⟨this ▸ hm, h₁ ▸ this, fun _ _ => h₂ ..⟩
     | succ i ih =>
       apply @ih (bs.push (f ⟨j, by omega⟩ as[j])) (j + 1) (by omega) (by simp; omega)
       · intro i i_lt h'
-        rw [get_push]
+        rw [getElem_push]
         split
         · apply h₂
         · simp only [size_push] at h'
           obtain rfl : i = j := by omega
           apply (hs ⟨i, by omega⟩ hm).1
       · exact (hs ⟨j, by omega⟩ hm).2
-  simp [mapIdx, mapIdxM]; exact go rfl nofun h0
+  simp [mapFinIdx, mapFinIdxM]; exact go rfl nofun h0
 
-theorem mapIdx_spec (as : Array α) (f : Fin as.size → α → β)
+theorem mapFinIdx_spec (as : Array α) (f : Fin as.size → α → β)
+    (p : Fin as.size → β → Prop) (hs : ∀ i, p i (f i as[i])) :
+    ∃ eq : (Array.mapFinIdx as f).size = as.size,
+      ∀ i h, p ⟨i, h⟩ ((Array.mapFinIdx as f)[i]) :=
+  (mapFinIdx_induction _ _ (fun _ => True) trivial p fun _ _ => ⟨hs .., trivial⟩).2
+
+@[simp] theorem size_mapFinIdx (a : Array α) (f : Fin a.size → α → β) : (a.mapFinIdx f).size = a.size :=
+  (mapFinIdx_spec (p := fun _ _ => True) (hs := fun _ => trivial)).1
+
+@[simp] theorem size_zipWithIndex (as : Array α) : as.zipWithIndex.size = as.size :=
+  Array.size_mapFinIdx _ _
+
+@[simp] theorem getElem_mapFinIdx (a : Array α) (f : Fin a.size → α → β) (i : Nat)
+    (h : i < (mapFinIdx a f).size) :
+    (a.mapFinIdx f)[i] = f ⟨i, by simp_all⟩ (a[i]'(by simp_all)) :=
+  (mapFinIdx_spec _ _ (fun i b => b = f i a[i]) fun _ => rfl).2 i _
+
+@[simp] theorem getElem?_mapFinIdx (a : Array α) (f : Fin a.size → α → β) (i : Nat) :
+    (a.mapFinIdx f)[i]? =
+      a[i]?.pbind fun b h => f ⟨i, (getElem?_eq_some_iff.1 h).1⟩ b := by
+  simp only [getElem?_def, size_mapFinIdx, getElem_mapFinIdx]
+  split <;> simp_all
+
+/-! ### mapIdx -/
+
+theorem mapIdx_induction (as : Array α) (f : Nat → α → β)
+    (motive : Nat → Prop) (h0 : motive 0)
+    (p : Fin as.size → β → Prop)
+    (hs : ∀ i, motive i.1 → p i (f i as[i]) ∧ motive (i + 1)) :
+    motive as.size ∧ ∃ eq : (Array.mapIdx as f).size = as.size,
+      ∀ i h, p ⟨i, h⟩ ((Array.mapIdx as f)[i]) :=
+  mapFinIdx_induction as (fun i a => f i a) motive h0 p hs
+
+theorem mapIdx_spec (as : Array α) (f : Nat → α → β)
     (p : Fin as.size → β → Prop) (hs : ∀ i, p i (f i as[i])) :
     ∃ eq : (Array.mapIdx as f).size = as.size,
       ∀ i h, p ⟨i, h⟩ ((Array.mapIdx as f)[i]) :=
   (mapIdx_induction _ _ (fun _ => True) trivial p fun _ _ => ⟨hs .., trivial⟩).2
 
-@[simp] theorem size_mapIdx (a : Array α) (f : Fin a.size → α → β) : (a.mapIdx f).size = a.size :=
+@[simp] theorem size_mapIdx (a : Array α) (f : Nat → α → β) : (a.mapIdx f).size = a.size :=
   (mapIdx_spec (p := fun _ _ => True) (hs := fun _ => trivial)).1
 
-@[simp] theorem size_zipWithIndex (as : Array α) : as.zipWithIndex.size = as.size :=
-  Array.size_mapIdx _ _
-
-@[simp] theorem getElem_mapIdx (a : Array α) (f : Fin a.size → α → β) (i : Nat)
+@[simp] theorem getElem_mapIdx (a : Array α) (f : Nat → α → β) (i : Nat)
     (h : i < (mapIdx a f).size) :
-    (a.mapIdx f)[i] = f ⟨i, by simp_all⟩ (a[i]'(by simp_all)) :=
-  (mapIdx_spec _ _ (fun i b => b = f i a[i]) fun _ => rfl).2 i _
+    (a.mapIdx f)[i] = f i (a[i]'(by simp_all)) :=
+  (mapIdx_spec _ _ (fun i b => b = f i a[i]) fun _ => rfl).2 i (by simp_all)
 
-@[simp] theorem getElem?_mapIdx (a : Array α) (f : Fin a.size → α → β) (i : Nat) :
+@[simp] theorem getElem?_mapIdx (a : Array α) (f : Nat → α → β) (i : Nat) :
     (a.mapIdx f)[i]? =
-      a[i]?.pbind fun b h => f ⟨i, (getElem?_eq_some_iff.1 h).1⟩ b := by
-  simp only [getElem?_def, size_mapIdx, getElem_mapIdx]
-  split <;> simp_all
+      a[i]?.map (f i) := by
+  simp [getElem?_def, size_mapIdx, getElem_mapIdx]
 
 end Array

src/Init/Data/Array/Mem.lean

@@ -10,15 +10,6 @@ import Init.Data.List.BasicAux
 
 namespace Array
 
-/-- `a ∈ as` is a predicate which asserts that `a` is in the array `as`. -/
--- NB: This is defined as a structure rather than a plain def so that a lemma
--- like `sizeOf_lt_of_mem` will not apply with no actual arrays around.
-structure Mem (as : Array α) (a : α) : Prop where
-  val : a ∈ as.toList
-
-instance : Membership α (Array α) where
-  mem := Mem
-
 theorem sizeOf_lt_of_mem [SizeOf α] {as : Array α} (h : a ∈ as) : sizeOf a < sizeOf as := by
   cases as with | _ as =>
   exact Nat.lt_trans (List.sizeOf_lt_of_mem h.val) (by simp_arith)

src/Init/Data/BitVec/Lemmas.lean

@@ -316,6 +316,12 @@ theorem getLsbD_ofNat (n : Nat) (x : Nat) (i : Nat) :
   simp [Nat.sub_sub_eq_min, Nat.min_eq_right]
   omega
 
+@[simp] theorem sub_add_bmod_cancel {x y : BitVec w} :
+    ((((2 ^ w : Nat) - y.toNat) : Int) + x.toNat).bmod (2 ^ w) =
+      ((x.toNat : Int) - y.toNat).bmod (2 ^ w) := by
+  rw [Int.sub_eq_add_neg, Int.add_assoc, Int.add_comm, Int.bmod_add_cancel, Int.add_comm,
+    Int.sub_eq_add_neg]
+
 private theorem lt_two_pow_of_le {x m n : Nat} (lt : x < 2 ^ m) (le : m ≤ n) : x < 2 ^ n :=
   Nat.lt_of_lt_of_le lt (Nat.pow_le_pow_of_le_right (by trivial : 0 < 2) le)
 
@@ -1056,7 +1062,7 @@ theorem not_eq_comm {x y : BitVec w} : ~~~ x = y ↔ x = ~~~ y := by
     BitVec.toFin (x <<< n) = Fin.ofNat' (2^w) (x.toNat <<< n) := rfl
 
 @[simp]
-theorem shiftLeft_zero_eq (x : BitVec w) : x <<< 0 = x := by
+theorem shiftLeft_zero (x : BitVec w) : x <<< 0 = x := by
   apply eq_of_toNat_eq
   simp
 
@@ -1226,7 +1232,11 @@ theorem ushiftRight_or_distrib (x y : BitVec w)  (n : Nat) :
   simp
 
 @[simp]
-theorem ushiftRight_zero_eq (x : BitVec w) : x >>> 0 = x := by
+theorem ushiftRight_zero (x : BitVec w) : x >>> 0 = x := by
+  simp [bv_toNat]
+
+@[simp]
+theorem zero_ushiftRight {n : Nat} : 0#w >>> n = 0#w := by
   simp [bv_toNat]
 
 /--
@@ -1381,6 +1391,10 @@ theorem msb_sshiftRight {n : Nat} {x : BitVec w} :
   ext i
   simp [getLsbD_sshiftRight]
 
+@[simp] theorem zero_sshiftRight {n : Nat} : (0#w).sshiftRight n = 0#w := by
+  ext i
+  simp [getLsbD_sshiftRight]
+
 theorem sshiftRight_add {x : BitVec w} {m n : Nat} :
     x.sshiftRight (m + n) = (x.sshiftRight m).sshiftRight n := by
   ext i
@@ -1903,6 +1917,31 @@ theorem toNat_shiftConcat_lt_of_lt {x : BitVec w} {b : Bool} {k : Nat}
   ext
   simp [getLsbD_concat]
 
+@[simp]
+theorem getMsbD_concat {i w : Nat} {b : Bool} {x : BitVec w} :
+    (x.concat b).getMsbD i = if i < w then x.getMsbD i else decide (i = w) && b := by
+  simp only [getMsbD_eq_getLsbD, Nat.add_sub_cancel, getLsbD_concat]
+  by_cases h₀ : i = w
+  · simp [h₀]
+  · by_cases h₁ : i < w
+    · simp [h₀, h₁, show ¬ w - i = 0 by omega, show i < w + 1 by omega, Nat.sub_sub, Nat.add_comm]
+    · simp only [show w - i = 0 by omega, ↓reduceIte, h₁, h₀, decide_False, Bool.false_and,
+        Bool.and_eq_false_imp, decide_eq_true_eq]
+      intro
+      omega
+
+@[simp]
+theorem msb_concat {w : Nat} {b : Bool} {x : BitVec w} :
+    (x.concat b).msb = if 0 < w then x.msb else b := by
+  simp only [BitVec.msb, getMsbD_eq_getLsbD, Nat.zero_lt_succ, decide_True, Nat.add_one_sub_one,
+    Nat.sub_zero, Bool.true_and]
+  by_cases h₀ : 0 < w
+  · simp only [Nat.lt_add_one, getLsbD_eq_getElem, getElem_concat, h₀, ↓reduceIte, decide_True,
+      Bool.true_and, ite_eq_right_iff]
+    intro
+    omega
+  · simp [h₀, show w = 0 by omega]
+
 /-! ### add -/
 
 theorem add_def {n} (x y : BitVec n) : x + y = .ofNat n (x.toNat + y.toNat) := rfl
@@ -1974,6 +2013,10 @@ theorem sub_def {n} (x y : BitVec n) : x - y = .ofNat n ((2^n - y.toNat) + x.toN
 @[simp] theorem toNat_sub {n} (x y : BitVec n) :
     (x - y).toNat = (((2^n - y.toNat) + x.toNat) % 2^n) := rfl
 
+@[simp, bv_toNat] theorem toInt_sub {x y : BitVec w} :
+    (x - y).toInt = (x.toInt - y.toInt).bmod (2 ^ w) := by
+  simp [toInt_eq_toNat_bmod, @Int.ofNat_sub y.toNat (2 ^ w) (by omega)]
+
 -- We prefer this lemma to `toNat_sub` for the `bv_toNat` simp set.
 -- For reasons we don't yet understand, unfolding via `toNat_sub` sometimes
 -- results in `omega` generating proof terms that are very slow in the kernel.
@@ -1996,6 +2039,8 @@ theorem ofNat_sub_ofNat {n} (x y : Nat) : BitVec.ofNat n x - BitVec.ofNat n y =
 
 @[simp] protected theorem sub_zero (x : BitVec n) : x - 0#n = x := by apply eq_of_toNat_eq ; simp
 
+@[simp] protected theorem zero_sub (x : BitVec n) : 0#n - x = -x := rfl
+
 @[simp] protected theorem sub_self (x : BitVec n) : x - x = 0#n := by
   apply eq_of_toNat_eq
   simp only [toNat_sub]
@@ -2008,18 +2053,8 @@ theorem ofNat_sub_ofNat {n} (x y : Nat) : BitVec.ofNat n x - BitVec.ofNat n y =
 
 theorem toInt_neg {x : BitVec w} :
     (-x).toInt = (-x.toInt).bmod (2 ^ w) := by
-  simp only [toInt_eq_toNat_bmod, toNat_neg, Int.ofNat_emod, Int.emod_bmod_congr]
-  rw [← Int.subNatNat_of_le (by omega), Int.subNatNat_eq_coe, Int.sub_eq_add_neg, Int.add_comm,
-    Int.bmod_add_cancel]
-  by_cases h : x.toNat < ((2 ^ w) + 1) / 2
-  · rw [Int.bmod_pos (x := x.toNat)]
-    all_goals simp only [toNat_mod_cancel']
-    norm_cast
-  · rw [Int.bmod_neg (x := x.toNat)]
-    · simp only [toNat_mod_cancel']
-      rw_mod_cast [Int.neg_sub, Int.sub_eq_add_neg, Int.add_comm, Int.bmod_add_cancel]
-    · norm_cast
-      simp_all
+  rw [← BitVec.zero_sub, toInt_sub]
+  simp [BitVec.toInt_ofNat]
 
 @[simp] theorem toFin_neg (x : BitVec n) :
     (-x).toFin = Fin.ofNat' (2^n) (2^n - x.toNat) :=
@@ -2113,6 +2148,8 @@ theorem not_neg (x : BitVec w) : ~~~(-x) = x + -1#w := by
 
 /-! ### abs -/
 
+theorem abs_eq (x : BitVec w) : x.abs = if x.msb then -x else x := by rfl
+
 @[simp, bv_toNat]
 theorem toNat_abs {x : BitVec w} : x.abs.toNat = if x.msb then 2^w - x.toNat else x.toNat := by
   simp only [BitVec.abs, neg_eq]
@@ -2149,18 +2186,23 @@ instance : Std.LawfulCommIdentity (fun (x y : BitVec w) => x * y) (1#w) where
   right_id := BitVec.mul_one
 
 @[simp]
-theorem BitVec.mul_zero {x : BitVec w} : x * 0#w = 0#w := by
+theorem mul_zero {x : BitVec w} : x * 0#w = 0#w := by
   apply eq_of_toNat_eq
   simp [toNat_mul]
 
-theorem BitVec.mul_add {x y z : BitVec w} :
+@[simp]
+theorem zero_mul {x : BitVec w} : 0#w * x = 0#w := by
+  apply eq_of_toNat_eq
+  simp [toNat_mul]
+
+theorem mul_add {x y z : BitVec w} :
     x * (y + z) = x * y + x * z := by
   apply eq_of_toNat_eq
   simp only [toNat_mul, toNat_add, Nat.add_mod_mod, Nat.mod_add_mod]
   rw [Nat.mul_mod, Nat.mod_mod (y.toNat + z.toNat),
     ← Nat.mul_mod, Nat.mul_add]
 
-theorem mul_succ {x y : BitVec w} : x * (y + 1#w) = x * y + x := by simp [BitVec.mul_add]
+theorem mul_succ {x y : BitVec w} : x * (y + 1#w) = x * y + x := by simp [mul_add]
 theorem succ_mul {x y : BitVec w} : (x + 1#w) * y = x * y + y := by simp [BitVec.mul_comm, BitVec.mul_add]
 
 theorem mul_two {x : BitVec w} : x * 2#w = x + x := by
@@ -2341,6 +2383,11 @@ theorem umod_eq_and {x y : BitVec 1} : x % y = x &&& (~~~y) := by
     rcases hy with rfl | rfl <;>
       rfl
 
+/-! ### smtUDiv -/
+
+theorem smtUDiv_eq (x y : BitVec w) : smtUDiv x y = if y = 0#w then allOnes w else x / y := by
+  simp [smtUDiv]
+
 /-! ### sdiv -/
 
 /-- Equation theorem for `sdiv` in terms of `udiv`. -/
@@ -2397,6 +2444,28 @@ theorem sdiv_self {x : BitVec w} :
       rcases x.msb with msb | msb <;> simp
     · rcases x.msb with msb | msb <;> simp [h]
 
+/-! ### smtSDiv -/
+
+theorem smtSDiv_eq (x y : BitVec w) : smtSDiv x y =
+  match x.msb, y.msb with
+  | false, false => smtUDiv x y
+  | false, true  => -(smtUDiv x (-y))
+  | true,  false => -(smtUDiv (-x) y)
+  | true,  true  => smtUDiv (-x) (-y) := by
+  rw [BitVec.smtSDiv]
+  rcases x.msb <;> rcases y.msb <;> simp
+
+/-! ### srem -/
+
+theorem srem_eq (x y : BitVec w) : srem x y =
+  match x.msb, y.msb with
+  | false, false => x % y
+  | false, true  => x % (-y)
+  | true,  false => - ((-x) % y)
+  | true,  true  => -((-x) % (-y)) := by
+  rw [BitVec.srem]
+  rcases x.msb <;> rcases y.msb <;> simp
+
 /-! ### smod -/
 
 /-- Equation theorem for `smod` in terms of `umod`. -/
@@ -2670,6 +2739,21 @@ theorem getElem_twoPow {i j : Nat} (h : j < w) : (twoPow w i)[j] = decide (j = i
   simp [eq_comm]
   omega
 
+@[simp]
+theorem getMsbD_twoPow {i j w: Nat} :
+    (twoPow w i).getMsbD j = (decide (i < w) && decide (j = w - i - 1)) := by
+  simp only [getMsbD_eq_getLsbD, getLsbD_twoPow]
+  by_cases h₀ : i < w <;> by_cases h₁ : j < w <;>
+  simp [h₀, h₁] <;> omega
+
+@[simp]
+theorem msb_twoPow {i w: Nat} :
+    (twoPow w i).msb = (decide (i < w) && decide (i = w - 1)) := by
+  simp only [BitVec.msb, getMsbD_eq_getLsbD, Nat.sub_zero, getLsbD_twoPow,
+    Bool.and_iff_right_iff_imp, Bool.and_eq_true, decide_eq_true_eq, and_imp]
+  intros
+  omega
+
 theorem and_twoPow (x : BitVec w) (i : Nat) :
     x &&& (twoPow w i) = if x.getLsbD i then twoPow w i else 0#w := by
   ext j
@@ -3160,4 +3244,10 @@ abbrev and_one_eq_zeroExtend_ofBool_getLsbD := @and_one_eq_setWidth_ofBool_getLs
 @[deprecated msb_sshiftRight (since := "2024-10-03")]
 abbrev sshiftRight_msb_eq_msb := @msb_sshiftRight
 
+@[deprecated shiftLeft_zero (since := "2024-10-27")]
+abbrev shiftLeft_zero_eq := @shiftLeft_zero
+
+@[deprecated ushiftRight_zero (since := "2024-10-27")]
+abbrev ushiftRight_zero_eq := @ushiftRight_zero
+
 end BitVec

src/Init/Data/Int/DivModLemmas.lean

@@ -1125,6 +1125,17 @@ theorem emod_add_bmod_congr (x : Int) (n : Nat) : Int.bmod (x%n + y) n = Int.bmo
   simp [Int.emod_def, Int.sub_eq_add_neg]
   rw [←Int.mul_neg, Int.add_right_comm,  Int.bmod_add_mul_cancel]
 
+@[simp]
+theorem emod_sub_bmod_congr (x : Int) (n : Nat) : Int.bmod (x%n - y) n = Int.bmod (x - y) n := by
+  simp only [emod_def, Int.sub_eq_add_neg]
+  rw [←Int.mul_neg, Int.add_right_comm,  Int.bmod_add_mul_cancel]
+
+@[simp]
+theorem sub_emod_bmod_congr (x : Int) (n : Nat) : Int.bmod (x - y%n) n = Int.bmod (x - y) n := by
+  simp only [emod_def]
+  rw [Int.sub_eq_add_neg, Int.neg_sub, Int.sub_eq_add_neg, ← Int.add_assoc, Int.add_right_comm,
+    Int.bmod_add_mul_cancel, Int.sub_eq_add_neg]
+
 @[simp]
 theorem emod_mul_bmod_congr (x : Int) (n : Nat) : Int.bmod (x%n * y) n = Int.bmod (x * y) n := by
   simp [Int.emod_def, Int.sub_eq_add_neg]
@@ -1140,9 +1151,28 @@ theorem bmod_add_bmod_congr : Int.bmod (Int.bmod x n + y) n = Int.bmod (x + y) n
     rw [Int.sub_eq_add_neg, Int.add_right_comm, ←Int.sub_eq_add_neg]
     simp
 
+@[simp]
+theorem bmod_sub_bmod_congr : Int.bmod (Int.bmod x n - y) n = Int.bmod (x - y) n := by
+  rw [Int.bmod_def x n]
+  split
+  next p =>
+    simp only [emod_sub_bmod_congr]
+  next p =>
+    rw [Int.sub_eq_add_neg, Int.sub_eq_add_neg, Int.add_right_comm, ←Int.sub_eq_add_neg, ← Int.sub_eq_add_neg]
+    simp [emod_sub_bmod_congr]
+
 @[simp] theorem add_bmod_bmod : Int.bmod (x + Int.bmod y n) n = Int.bmod (x + y) n := by
   rw [Int.add_comm x, Int.bmod_add_bmod_congr, Int.add_comm y]
 
+@[simp] theorem sub_bmod_bmod : Int.bmod (x - Int.bmod y n) n = Int.bmod (x - y) n := by
+  rw [Int.bmod_def y n]
+  split
+  next p =>
+    simp [sub_emod_bmod_congr]
+  next p =>
+    rw [Int.sub_eq_add_neg, Int.sub_eq_add_neg, Int.neg_add, Int.neg_neg, ← Int.add_assoc, ← Int.sub_eq_add_neg]
+    simp [sub_emod_bmod_congr]
+
 @[simp]
 theorem bmod_mul_bmod : Int.bmod (Int.bmod x n * y) n = Int.bmod (x * y) n := by
   rw [bmod_def x n]

src/Init/Data/List/Basic.lean

@@ -29,7 +29,7 @@ The operations are organized as follow:
 * Lexicographic ordering: `lt`, `le`, and instances.
 * Head and tail operators: `head`, `head?`, `headD?`, `tail`, `tail?`, `tailD`.
 * Basic operations:
-  `map`, `filter`, `filterMap`, `foldr`, `append`, `flatten`, `pure`, `bind`, `replicate`, and
+  `map`, `filter`, `filterMap`, `foldr`, `append`, `flatten`, `pure`, `flatMap`, `replicate`, and
   `reverse`.
 * Additional functions defined in terms of these: `leftpad`, `rightPad`, and `reduceOption`.
 * Operations using indexes: `mapIdx`.
@@ -38,7 +38,7 @@ The operations are organized as follow:
 * Sublists: `take`, `drop`, `takeWhile`, `dropWhile`, `partition`, `dropLast`,
   `isPrefixOf`, `isPrefixOf?`, `isSuffixOf`, `isSuffixOf?`, `Subset`, `Sublist`,
   `rotateLeft` and `rotateRight`.
-* Manipulating elements: `replace`, `insert`, `erase`, `eraseP`, `eraseIdx`.
+* Manipulating elements: `replace`, `insert`, `modify`, `erase`, `eraseP`, `eraseIdx`.
 * Finding elements: `find?`, `findSome?`, `findIdx`, `indexOf`, `findIdx?`, `indexOf?`,
  `countP`, `count`, and `lookup`.
 * Logic: `any`, `all`, `or`, and `and`.
@@ -122,6 +122,11 @@ protected def beq [BEq α] : List α → List α → Bool
   | a::as, b::bs => a == b && List.beq as bs
   | _,     _     => false
 
+@[simp] theorem beq_nil_nil [BEq α] : List.beq ([] : List α) ([] : List α) = true := rfl
+@[simp] theorem beq_cons_nil [BEq α] (a : α) (as : List α) : List.beq (a::as) [] = false := rfl
+@[simp] theorem beq_nil_cons [BEq α] (a : α) (as : List α) : List.beq [] (a::as) = false := rfl
+theorem beq_cons₂ [BEq α] (a b : α) (as bs : List α) : List.beq (a::as) (b::bs) = (a == b && List.beq as bs) := rfl
+
 instance [BEq α] : BEq (List α) := ⟨List.beq⟩
 
 instance [BEq α] [LawfulBEq α] : LawfulBEq (List α) where
@@ -1114,6 +1119,35 @@ theorem replace_cons [BEq α] {a : α} :
 @[inline] protected def insert [BEq α] (a : α) (l : List α) : List α :=
   if l.elem a then l else a :: l
 
+/-! ### modify -/
+
+/--
+Apply a function to the nth tail of `l`. Returns the input without
+using `f` if the index is larger than the length of the List.
+```
+modifyTailIdx f 2 [a, b, c] = [a, b] ++ f [c]
+```
+-/
+@[simp] def modifyTailIdx (f : List α → List α) : Nat → List α → List α
+  | 0, l => f l
+  | _+1, [] => []
+  | n+1, a :: l => a :: modifyTailIdx f n l
+
+/-- Apply `f` to the head of the list, if it exists. -/
+@[inline] def modifyHead (f : α → α) : List α → List α
+  | [] => []
+  | a :: l => f a :: l
+
+@[simp] theorem modifyHead_nil (f : α → α) : [].modifyHead f = [] := by rw [modifyHead]
+@[simp] theorem modifyHead_cons (a : α) (l : List α) (f : α → α) :
+    (a :: l).modifyHead f = f a :: l := by rw [modifyHead]
+
+/--
+Apply `f` to the nth element of the list, if it exists, replacing that element with the result.
+-/
+def modify (f : α → α) : Nat → List α → List α :=
+  modifyTailIdx (modifyHead f)
+
 /-! ### erase -/
 
 /--
@@ -1418,11 +1452,15 @@ def sum {α} [Add α] [Zero α] : List α → α :=
 @[simp] theorem sum_cons [Add α] [Zero α] {a : α} {l : List α} : (a::l).sum = a + l.sum := rfl
 
 /-- Sum of a list of natural numbers. -/
--- We intend to subsequently deprecate this in favor of `List.sum`.
+@[deprecated List.sum (since := "2024-10-17")]
 protected def _root_.Nat.sum (l : List Nat) : Nat := l.foldr (·+·) 0
 
-@[simp] theorem _root_.Nat.sum_nil : Nat.sum ([] : List Nat) = 0 := rfl
-@[simp] theorem _root_.Nat.sum_cons (a : Nat) (l : List Nat) :
+set_option linter.deprecated false in
+@[simp, deprecated sum_nil (since := "2024-10-17")]
+theorem _root_.Nat.sum_nil : Nat.sum ([] : List Nat) = 0 := rfl
+set_option linter.deprecated false in
+@[simp, deprecated sum_cons (since := "2024-10-17")]
+theorem _root_.Nat.sum_cons (a : Nat) (l : List Nat) :
     Nat.sum (a::l) = a + Nat.sum l := rfl
 
 /-! ### range -/

src/Init/Data/List/Control.lean

@@ -254,6 +254,8 @@ instance : ForIn m (List α) α where
 instance : ForIn' m (List α) α inferInstance where
   forIn' := List.forIn'
 
+@[simp] theorem forIn'_eq_forIn' [Monad m] : @List.forIn' α β m _ = forIn' := rfl
+
 @[simp] theorem forIn'_eq_forIn {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] (as : List α) (init : β) (f : α → β → m (ForInStep β)) : forIn' as init (fun a _ b => f a b) = forIn as init f := by
   simp [forIn', forIn, List.forIn, List.forIn']
   have : ∀ cs h, List.forIn'.loop cs (fun a _ b => f a b) as init h = List.forIn.loop f as init := by

src/Init/Data/List/Find.lean

@@ -595,15 +595,14 @@ theorem findIdx_eq {p : α → Bool} {xs : List α} {i : Nat} (h : i < xs.length
 
 theorem findIdx_append (p : α → Bool) (l₁ l₂ : List α) :
     (l₁ ++ l₂).findIdx p =
-      if ∃ x, x ∈ l₁ ∧ p x = true then l₁.findIdx p else l₂.findIdx p + l₁.length := by
+      if l₁.findIdx p < l₁.length then l₁.findIdx p else l₂.findIdx p + l₁.length := by
   induction l₁ with
   | nil => simp
   | cons x xs ih =>
     simp only [findIdx_cons, length_cons, cons_append]
     by_cases h : p x
     · simp [h]
-    · simp only [h, ih, cond_eq_if, Bool.false_eq_true, ↓reduceIte, mem_cons, exists_eq_or_imp,
-        false_or]
+    · simp only [h, ih, cond_eq_if, Bool.false_eq_true, ↓reduceIte, add_one_lt_add_one_iff]
       split <;> simp [Nat.add_assoc]
 
 theorem IsPrefix.findIdx_le {l₁ l₂ : List α} {p : α → Bool} (h : l₁ <+: l₂) :

src/Init/Data/List/Impl.lean

@@ -38,7 +38,7 @@ The following operations were already given `@[csimp]` replacements in `Init/Dat
 
 The following operations are given `@[csimp]` replacements below:
 `set`, `filterMap`, `foldr`, `append`, `bind`, `join`,
-`take`, `takeWhile`, `dropLast`, `replace`, `erase`, `eraseIdx`, `zipWith`,
+`take`, `takeWhile`, `dropLast`, `replace`, `modify`, `erase`, `eraseIdx`, `zipWith`,
 `enumFrom`, and `intercalate`.
 
 -/
@@ -197,6 +197,24 @@ The following operations are given `@[csimp]` replacements below:
     · simp [*]
     · intro h; rw [IH] <;> simp_all
 
+/-! ### modify -/
+
+/-- Tail-recursive version of `modify`. -/
+def modifyTR (f : α → α) (n : Nat) (l : List α) : List α := go l n #[] where
+  /-- Auxiliary for `modifyTR`: `modifyTR.go f l n acc = acc.toList ++ modify f n l`. -/
+  go : List α → Nat → Array α → List α
+  | [], _, acc => acc.toList
+  | a :: l, 0, acc => acc.toListAppend (f a :: l)
+  | a :: l, n+1, acc => go l n (acc.push a)
+
+theorem modifyTR_go_eq : ∀ l n, modifyTR.go f l n acc = acc.toList ++ modify f n l
+  | [], n => by cases n <;> simp [modifyTR.go, modify]
+  | a :: l, 0 => by simp [modifyTR.go, modify]
+  | a :: l, n+1 => by simp [modifyTR.go, modify, modifyTR_go_eq l]
+
+@[csimp] theorem modify_eq_modifyTR : @modify = @modifyTR := by
+  funext α f n l; simp [modifyTR, modifyTR_go_eq]
+
 /-! ### erase -/
 
 /-- Tail recursive version of `List.erase`. -/

src/Init/Data/List/Lemmas.lean

@@ -492,10 +492,6 @@ theorem getElem?_of_mem {a} {l : List α} (h : a ∈ l) : ∃ n : Nat, l[n]? = s
 theorem get?_of_mem {a} {l : List α} (h : a ∈ l) : ∃ n, l.get? n = some a :=
   let ⟨⟨n, _⟩, e⟩ := get_of_mem h; ⟨n, e ▸ get?_eq_get _⟩
 
-@[simp] theorem getElem_mem : ∀ {l : List α} {n} (h : n < l.length), l[n]'h ∈ l
-  | _ :: _, 0, _ => .head ..
-  | _ :: l, _+1, _ => .tail _ (getElem_mem (l := l) ..)
-
 theorem get_mem : ∀ (l : List α) n h, get l ⟨n, h⟩ ∈ l
   | _ :: _, 0, _ => .head ..
   | _ :: l, _+1, _ => .tail _ (get_mem l ..)
@@ -1047,9 +1043,6 @@ theorem get_cons_length (x : α) (xs : List α) (n : Nat) (h : n = xs.length) :
 
 @[simp] theorem getLast?_singleton (a : α) : getLast? [a] = a := rfl
 
-theorem getLast!_of_getLast? [Inhabited α] : ∀ {l : List α}, getLast? l = some a → getLast! l = a
-  | _ :: _, rfl => rfl
-
 theorem getLast?_eq_getLast : ∀ l h, @getLast? α l = some (getLast l h)
   | [], h => nomatch h rfl
   | _ :: _, _ => rfl
@@ -1083,6 +1076,21 @@ theorem getLast?_concat (l : List α) : getLast? (l ++ [a]) = some a := by
 theorem getLastD_concat (a b l) : @getLastD α (l ++ [b]) a = b := by
   rw [getLastD_eq_getLast?, getLast?_concat]; rfl
 
+/-! ### getLast! -/
+
+@[simp] theorem getLast!_nil [Inhabited α] : ([] : List α).getLast! = default := rfl
+
+theorem getLast!_of_getLast? [Inhabited α] : ∀ {l : List α}, getLast? l = some a → getLast! l = a
+  | _ :: _, rfl => rfl
+
+theorem getLast!_eq_getElem! [Inhabited α] {l : List α} : l.getLast! = l[l.length - 1]! := by
+  cases l with
+  | nil => simp
+  | cons _ _ =>
+    apply getLast!_of_getLast?
+    rw [getElem!_pos, getElem_cons_length (h := by simp)]
+    rfl
+
 /-! ## Head and tail -/
 
 /-! ### head -/

src/Init/Data/List/Monadic.lean

@@ -87,6 +87,68 @@ theorem mapM_eq_reverse_foldlM_cons [Monad m] [LawfulMonad m] (f : α → m β)
     (l₁ ++ l₂).forM f = (do l₁.forM f; l₂.forM f) := by
   induction l₁ <;> simp [*]
 
+/-! ### forIn' -/
+
+@[simp] theorem forIn'_nil [Monad m] (f : (a : α) → a ∈ [] → β → m (ForInStep β)) (b : β) : forIn' [] b f = pure b :=
+  rfl
+
+theorem forIn'_loop_congr [Monad m] {as bs : List α}
+    {f : (a' : α) → a' ∈ as → β → m (ForInStep β)}
+    {g : (a' : α) → a' ∈ bs → β → m (ForInStep β)}
+    {b : β} (ha : ∃ ys, ys ++ xs = as) (hb : ∃ ys, ys ++ xs = bs)
+    (h : ∀ a m m' b, f a m b = g a m' b) : forIn'.loop as f xs b ha = forIn'.loop bs g xs b hb  := by
+  induction xs generalizing b with
+  | nil => simp [forIn'.loop]
+  | cons a xs ih =>
+    simp only [forIn'.loop] at *
+    congr 1
+    · rw [h]
+    · funext s
+      obtain b | b := s
+      · rfl
+      · simp
+        rw [ih]
+
+@[simp] theorem forIn'_cons [Monad m] {a : α} {as : List α}
+    (f : (a' : α) → a' ∈ a :: as → β → m (ForInStep β)) (b : β) :
+    forIn' (a::as) b f = f a (mem_cons_self a as) b >>=
+      fun | ForInStep.done b => pure b | ForInStep.yield b => forIn' as b fun a' m b => f a' (mem_cons_of_mem a m) b := by
+  simp only [forIn', List.forIn', forIn'.loop]
+  congr 1
+  funext s
+  obtain b | b := s
+  · rfl
+  · apply forIn'_loop_congr
+    intros
+    rfl
+
+@[congr] theorem forIn'_congr [Monad m] {as bs : List α} (w : as = bs)
+    {b b' : β} (hb : b = b')
+    {f : (a' : α) → a' ∈ as → β → m (ForInStep β)}
+    {g : (a' : α) → a' ∈ bs → β → m (ForInStep β)}
+    (h : ∀ a m b, f a (by simpa [w] using m) b = g a m b) :
+    forIn' as b f = forIn' bs b' g := by
+  induction bs generalizing as b b' with
+  | nil =>
+    subst w
+    simp [hb, forIn'_nil]
+  | cons b bs ih =>
+    cases as with
+    | nil => simp at w
+    | cons a as =>
+      simp only [cons.injEq] at w
+      obtain ⟨rfl, rfl⟩ := w
+      simp only [forIn'_cons]
+      congr 1
+      · simp [h, hb]
+      · funext s
+        obtain b | b := s
+        · rfl
+        · simp
+          rw [ih rfl rfl]
+          intro a m b
+          exact h a (mem_cons_of_mem _ m) b
+
 /-! ### allM -/
 
 theorem allM_eq_not_anyM_not [Monad m] [LawfulMonad m] (p : α → m Bool) (as : List α) :

src/Init/Data/List/Nat.lean

@@ -12,3 +12,5 @@ import Init.Data.List.Nat.TakeDrop
 import Init.Data.List.Nat.Count
 import Init.Data.List.Nat.Erase
 import Init.Data.List.Nat.Find
+import Init.Data.List.Nat.BEq
+import Init.Data.List.Nat.Modify

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

@@ -0,0 +1,47 @@
+/-
+Copyright (c) 2024 Lean FRO All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Kim Morrison
+-/
+prelude
+import Init.Data.Nat.Lemmas
+import Init.Data.List.Basic
+
+namespace List
+
+/-! ### isEqv-/
+
+theorem isEqv_eq_decide (a b : List α) (r) :
+    isEqv a b r = if h : a.length = b.length then
+      decide (∀ (i : Nat) (h' : i < a.length), r (a[i]'(h ▸ h')) (b[i]'(h ▸ h'))) else false := by
+  induction a generalizing b with
+  | nil =>
+    cases b <;> simp
+  | cons a as ih =>
+    cases b with
+    | nil => simp
+    | cons b bs =>
+      simp only [isEqv, ih, length_cons, Nat.add_right_cancel_iff]
+      split <;> simp [Nat.forall_lt_succ_left']
+
+/-! ### beq -/
+
+theorem beq_eq_isEqv [BEq α] (a b : List α) : a.beq b = isEqv a b (· == ·) := by
+  induction a generalizing b with
+  | nil =>
+    cases b <;> simp
+  | cons a as ih =>
+    cases b with
+    | nil => simp
+    | cons b bs =>
+      simp only [beq_cons₂, ih, isEqv_eq_decide, length_cons, Nat.add_right_cancel_iff,
+        Nat.forall_lt_succ_left', getElem_cons_zero, getElem_cons_succ, Bool.decide_and,
+        Bool.decide_eq_true]
+      split <;> simp
+
+theorem beq_eq_decide [BEq α] (a b : List α) :
+    (a == b) = if h : a.length = b.length then
+      decide (∀ (i : Nat) (h' : i < a.length), a[i] == b[i]'(h ▸ h')) else false := by
+  simp [BEq.beq, beq_eq_isEqv, isEqv_eq_decide]
+
+end List

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

@@ -0,0 +1,295 @@
+/-
+Copyright (c) 2014 Parikshit Khanna. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Parikshit Khanna, Jeremy Avigad, Leonardo de Moura, Floris van Doorn, Mario Carneiro
+-/
+
+prelude
+import Init.Data.List.Nat.TakeDrop
+import Init.Data.List.Nat.Erase
+
+namespace List
+
+/-! ### modifyHead -/
+
+@[simp] theorem length_modifyHead {f : α → α} {l : List α} : (l.modifyHead f).length = l.length := by
+  cases l <;> simp [modifyHead]
+
+theorem modifyHead_eq_set [Inhabited α] (f : α → α) (l : List α) :
+    l.modifyHead f = l.set 0 (f (l[0]?.getD default)) := by cases l <;> simp [modifyHead]
+
+@[simp] theorem modifyHead_eq_nil_iff {f : α → α} {l : List α} :
+    l.modifyHead f = [] ↔ l = [] := by cases l <;> simp [modifyHead]
+
+@[simp] theorem modifyHead_modifyHead {l : List α} {f g : α → α} :
+    (l.modifyHead f).modifyHead g = l.modifyHead (g ∘ f) := by cases l <;> simp [modifyHead]
+
+theorem getElem_modifyHead {l : List α} {f : α → α} {n} (h : n < (l.modifyHead f).length) :
+    (l.modifyHead f)[n] = if h' : n = 0 then f (l[0]'(by simp at h; omega)) else l[n]'(by simpa using h) := by
+  cases l with
+  | nil => simp at h
+  | cons hd tl => cases n <;> simp
+
+@[simp] theorem getElem_modifyHead_zero {l : List α} {f : α → α} {h} :
+    (l.modifyHead f)[0] = f (l[0]'(by simpa using h)) := by simp [getElem_modifyHead]
+
+@[simp] theorem getElem_modifyHead_succ {l : List α} {f : α → α} {n} (h : n + 1 < (l.modifyHead f).length) :
+    (l.modifyHead f)[n + 1] = l[n + 1]'(by simpa using h) := by simp [getElem_modifyHead]
+
+theorem getElem?_modifyHead {l : List α} {f : α → α} {n} :
+    (l.modifyHead f)[n]? = if n = 0 then l[n]?.map f else l[n]? := by
+  cases l with
+  | nil => simp
+  | cons hd tl => cases n <;> simp
+
+@[simp] theorem getElem?_modifyHead_zero {l : List α} {f : α → α} :
+    (l.modifyHead f)[0]? = l[0]?.map f := by simp [getElem?_modifyHead]
+
+@[simp] theorem getElem?_modifyHead_succ {l : List α} {f : α → α} {n} :
+    (l.modifyHead f)[n + 1]? = l[n + 1]? := by simp [getElem?_modifyHead]
+
+@[simp] theorem head_modifyHead (f : α → α) (l : List α) (h) :
+    (l.modifyHead f).head h = f (l.head (by simpa using h)) := by
+  cases l with
+  | nil => simp at h
+  | cons hd tl => simp
+
+@[simp] theorem head?_modifyHead {l : List α} {f : α → α} :
+    (l.modifyHead f).head? = l.head?.map f := by cases l <;> simp
+
+@[simp] theorem tail_modifyHead {f : α → α} {l : List α} :
+    (l.modifyHead f).tail = l.tail := by cases l <;> simp
+
+@[simp] theorem take_modifyHead {f : α → α} {l : List α} {n} :
+    (l.modifyHead f).take n = (l.take n).modifyHead f := by
+  cases l <;> cases n <;> simp
+
+@[simp] theorem drop_modifyHead_of_pos {f : α → α} {l : List α} {n} (h : 0 < n) :
+    (l.modifyHead f).drop n = l.drop n := by
+  cases l <;> cases n <;> simp_all
+
+@[simp] theorem eraseIdx_modifyHead_zero {f : α → α} {l : List α} :
+    (l.modifyHead f).eraseIdx 0 = l.eraseIdx 0 := by cases l <;> simp
+
+@[simp] theorem eraseIdx_modifyHead_of_pos {f : α → α} {l : List α} {n} (h : 0 < n) :
+    (l.modifyHead f).eraseIdx n = (l.eraseIdx n).modifyHead f := by cases l <;> cases n <;> simp_all
+
+@[simp] theorem modifyHead_id : modifyHead (id : α → α) = id := by funext l; cases l <;> simp
+
+/-! ### modifyTailIdx -/
+
+@[simp] theorem modifyTailIdx_id : ∀ n (l : List α), l.modifyTailIdx id n = l
+  | 0, _ => rfl
+  | _+1, [] => rfl
+  | n+1, a :: l => congrArg (cons a) (modifyTailIdx_id n l)
+
+theorem eraseIdx_eq_modifyTailIdx : ∀ n (l : List α), eraseIdx l n = modifyTailIdx tail n l
+  | 0, l => by cases l <;> rfl
+  | _+1, [] => rfl
+  | _+1, _ :: _ => congrArg (cons _) (eraseIdx_eq_modifyTailIdx _ _)
+
+@[simp] theorem length_modifyTailIdx (f : List α → List α) (H : ∀ l, length (f l) = length l) :
+    ∀ n l, length (modifyTailIdx f n l) = length l
+  | 0, _ => H _
+  | _+1, [] => rfl
+  | _+1, _ :: _ => congrArg (·+1) (length_modifyTailIdx _ H _ _)
+
+theorem modifyTailIdx_add (f : List α → List α) (n) (l₁ l₂ : List α) :
+    modifyTailIdx f (l₁.length + n) (l₁ ++ l₂) = l₁ ++ modifyTailIdx f n l₂ := by
+  induction l₁ <;> simp [*, Nat.succ_add]
+
+theorem modifyTailIdx_eq_take_drop (f : List α → List α) (H : f [] = []) :
+    ∀ n l, modifyTailIdx f n l = take n l ++ f (drop n l)
+  | 0, _ => rfl
+  | _ + 1, [] => H.symm
+  | n + 1, b :: l => congrArg (cons b) (modifyTailIdx_eq_take_drop f H n l)
+
+theorem exists_of_modifyTailIdx (f : List α → List α) {n} {l : List α} (h : n ≤ l.length) :
+    ∃ l₁ l₂, l = l₁ ++ l₂ ∧ l₁.length = n ∧ modifyTailIdx f n l = l₁ ++ f l₂ :=
+  have ⟨_, _, eq, hl⟩ : ∃ l₁ l₂, l = l₁ ++ l₂ ∧ l₁.length = n :=
+    ⟨_, _, (take_append_drop n l).symm, length_take_of_le h⟩
+  ⟨_, _, eq, hl, hl ▸ eq ▸ modifyTailIdx_add (n := 0) ..⟩
+
+/-! ### modify -/
+
+@[simp] theorem modify_nil (f : α → α) (n) : [].modify f n = [] := by cases n <;> rfl
+
+@[simp] theorem modify_zero_cons (f : α → α) (a : α) (l : List α) :
+    (a :: l).modify f 0 = f a :: l := rfl
+
+@[simp] theorem modify_succ_cons (f : α → α) (a : α) (l : List α) (n) :
+    (a :: l).modify f (n + 1) = a :: l.modify f n := by rfl
+
+theorem modifyHead_eq_modify_zero (f : α → α) (l : List α) :
+    l.modifyHead f = l.modify f 0 := by cases l <;> simp
+
+@[simp] theorem modify_eq_nil_iff (f : α → α) (n) (l : List α) :
+    l.modify f n = [] ↔ l = [] := by cases l <;> cases n <;> simp
+
+theorem getElem?_modify (f : α → α) :
+    ∀ n (l : List α) m, (modify f n l)[m]? = (fun a => if n = m then f a else a) <$> l[m]?
+  | n, l, 0 => by cases l <;> cases n <;> simp
+  | n, [], _+1 => by cases n <;> rfl
+  | 0, _ :: l, m+1 => by cases h : l[m]? <;> simp [h, modify, m.succ_ne_zero.symm]
+  | n+1, a :: l, m+1 => by
+    simp only [modify_succ_cons, getElem?_cons_succ, Nat.reduceEqDiff, Option.map_eq_map]
+    refine (getElem?_modify f n l m).trans ?_
+    cases h' : l[m]? <;> by_cases h : n = m <;>
+      simp [h, if_pos, if_neg, Option.map, mt Nat.succ.inj, not_false_iff, h']
+
+@[simp] theorem length_modify (f : α → α) : ∀ n l, length (modify f n l) = length l :=
+  length_modifyTailIdx _ fun l => by cases l <;> rfl
+
+@[simp] theorem getElem?_modify_eq (f : α → α) (n) (l : List α) :
+    (modify f n l)[n]? = f <$> l[n]? := by
+  simp only [getElem?_modify, if_pos]
+
+@[simp] theorem getElem?_modify_ne (f : α → α) {m n} (l : List α) (h : m ≠ n) :
+    (modify f m l)[n]? = l[n]? := by
+  simp only [getElem?_modify, if_neg h, id_map']
+
+theorem getElem_modify (f : α → α) (n) (l : List α) (m) (h : m < (modify f n l).length) :
+    (modify f n l)[m] =
+      if n = m then f (l[m]'(by simp at h; omega)) else l[m]'(by simp at h; omega) := by
+  rw [getElem_eq_iff, getElem?_modify]
+  simp at h
+  simp [h]
+
+@[simp] theorem getElem_modify_eq (f : α → α) (n) (l : List α) (h) :
+    (modify f n l)[n] = f (l[n]'(by simpa using h)) := by simp [getElem_modify]
+
+@[simp] theorem getElem_modify_ne (f : α → α) {m n} (l : List α) (h : m ≠ n) (h') :
+    (modify f m l)[n] = l[n]'(by simpa using h') := by simp [getElem_modify, h]
+
+theorem modify_eq_self {f : α → α} {n} {l : List α} (h : l.length ≤ n) :
+    l.modify f n = l := by
+  apply ext_getElem
+  · simp
+  · intro m h₁ h₂
+    simp only [getElem_modify, ite_eq_right_iff]
+    intro h
+    omega
+
+theorem modify_modify_eq (f g : α → α) (n) (l : List α) :
+    (modify f n l).modify g n = modify (g ∘ f) n l := by
+  apply ext_getElem
+  · simp
+  · intro m h₁ h₂
+    simp only [getElem_modify, Function.comp_apply]
+    split <;> simp
+
+theorem modify_modify_ne (f g : α → α) {m n} (l : List α) (h : m ≠ n) :
+    (modify f m l).modify g n = (l.modify g n).modify f m := by
+  apply ext_getElem
+  · simp
+  · intro m' h₁ h₂
+    simp only [getElem_modify, getElem_modify_ne, h₂]
+    split <;> split <;> first | rfl | omega
+
+theorem modify_eq_set [Inhabited α] (f : α → α) (n) (l : List α) :
+    modify f n l = l.set n (f (l[n]?.getD default)) := by
+  apply ext_getElem
+  · simp
+  · intro m h₁ h₂
+    simp [getElem_modify, getElem_set, h₂]
+    split <;> rename_i h
+    · subst h
+      simp only [length_modify] at h₁
+      simp [h₁]
+    · rfl
+
+theorem modify_eq_take_drop (f : α → α) :
+    ∀ n l, modify f n l = take n l ++ modifyHead f (drop n l) :=
+  modifyTailIdx_eq_take_drop _ rfl
+
+theorem modify_eq_take_cons_drop {f : α → α} {n} {l : List α} (h : n < l.length) :
+    modify f n l = take n l ++ f l[n] :: drop (n + 1) l := by
+  rw [modify_eq_take_drop, drop_eq_getElem_cons h]; rfl
+
+theorem exists_of_modify (f : α → α) {n} {l : List α} (h : n < l.length) :
+    ∃ l₁ a l₂, l = l₁ ++ a :: l₂ ∧ l₁.length = n ∧ modify f n l = l₁ ++ f a :: l₂ :=
+  match exists_of_modifyTailIdx _ (Nat.le_of_lt h) with
+  | ⟨_, _::_, eq, hl, H⟩ => ⟨_, _, _, eq, hl, H⟩
+  | ⟨_, [], eq, hl, _⟩ => nomatch Nat.ne_of_gt h (eq ▸ append_nil _ ▸ hl)
+
+@[simp] theorem modify_id (n) (l : List α) : l.modify id n = l := by
+  simp [modify]
+
+theorem take_modify (f : α → α) (n m) (l : List α) :
+    (modify f m l).take n = (take n l).modify f m := by
+  induction n generalizing l m with
+  | zero => simp
+  | succ n ih =>
+    cases l with
+    | nil => simp
+    | cons hd tl =>
+      cases m with
+      | zero => simp
+      | succ m => simp [ih]
+
+theorem drop_modify_of_lt (f : α → α) (n m) (l : List α) (h : n < m) :
+    (modify f n l).drop m = l.drop m := by
+  apply ext_getElem
+  · simp
+  · intro m' h₁ h₂
+    simp only [getElem_drop, getElem_modify, ite_eq_right_iff]
+    intro h'
+    omega
+
+theorem drop_modify_of_ge (f : α → α) (n m) (l : List α) (h : n ≥ m) :
+    (modify f n l).drop m = modify f (n - m) (drop m l) := by
+  apply ext_getElem
+  · simp
+  · intro m' h₁ h₂
+    simp [getElem_drop, getElem_modify, ite_eq_right_iff]
+    split <;> split <;> first | rfl | omega
+
+theorem eraseIdx_modify_of_eq (f : α → α) (n) (l : List α) :
+    (modify f n l).eraseIdx n = l.eraseIdx n := by
+  apply ext_getElem
+  · simp [length_eraseIdx]
+  · intro m h₁ h₂
+    simp only [getElem_eraseIdx, getElem_modify]
+    split <;> split <;> first | rfl | omega
+
+theorem eraseIdx_modify_of_lt (f : α → α) (i j) (l : List α) (h : j < i) :
+    (modify f i l).eraseIdx j = (l.eraseIdx j).modify f (i - 1) := by
+  apply ext_getElem
+  · simp [length_eraseIdx]
+  · intro k h₁ h₂
+    simp only [getElem_eraseIdx, getElem_modify]
+    by_cases h' : i - 1 = k
+    repeat' split
+    all_goals (first | rfl | omega)
+
+theorem eraseIdx_modify_of_gt (f : α → α) (i j) (l : List α) (h : j > i) :
+    (modify f i l).eraseIdx j = (l.eraseIdx j).modify f i := by
+  apply ext_getElem
+  · simp [length_eraseIdx]
+  · intro k h₁ h₂
+    simp only [getElem_eraseIdx, getElem_modify]
+    by_cases h' : i = k
+    repeat' split
+    all_goals (first | rfl | omega)
+
+theorem modify_eraseIdx_of_lt (f : α → α) (i j) (l : List α) (h : j < i) :
+    (l.eraseIdx i).modify f j = (l.modify f j).eraseIdx i := by
+  apply ext_getElem
+  · simp [length_eraseIdx]
+  · intro k h₁ h₂
+    simp only [getElem_eraseIdx, getElem_modify]
+    by_cases h' : j = k + 1
+    repeat' split
+    all_goals (first | rfl | omega)
+
+theorem modify_eraseIdx_of_ge (f : α → α) (i j) (l : List α) (h : j ≥ i) :
+    (l.eraseIdx i).modify f j = (l.modify f (j + 1)).eraseIdx i := by
+  apply ext_getElem
+  · simp [length_eraseIdx]
+  · intro k h₁ h₂
+    simp only [getElem_eraseIdx, getElem_modify]
+    by_cases h' : j + 1 = k + 1
+    repeat' split
+    all_goals (first | rfl | omega)
+
+end List

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

@@ -187,6 +187,9 @@ theorem take_add (l : List α) (m n : Nat) : l.take (m + n) = l.take m ++ (l.dro
   · apply length_take_le
   · apply Nat.le_add_right
 
+theorem take_one {l : List α} : l.take 1 = l.head?.toList := by
+  induction l <;> simp
+
 theorem dropLast_take {n : Nat} {l : List α} (h : n < l.length) :
     (l.take n).dropLast = l.take (n - 1) := by
   simp only [dropLast_eq_take, length_take, Nat.le_of_lt h, Nat.min_eq_left, take_take, sub_le]
@@ -282,14 +285,14 @@ theorem mem_drop_iff_getElem {l : List α} {a : α} :
   · rintro ⟨i, hm, rfl⟩
     refine ⟨i, by simp; omega, by rw [getElem_drop]⟩
 
-theorem head?_drop (l : List α) (n : Nat) :
+@[simp] theorem head?_drop (l : List α) (n : Nat) :
     (l.drop n).head? = l[n]? := by
   rw [head?_eq_getElem?, getElem?_drop, Nat.add_zero]
 
-theorem head_drop {l : List α} {n : Nat} (h : l.drop n ≠ []) :
+@[simp] theorem head_drop {l : List α} {n : Nat} (h : l.drop n ≠ []) :
     (l.drop n).head h = l[n]'(by simp_all) := by
   have w : n < l.length := length_lt_of_drop_ne_nil h
-  simpa [getElem?_eq_getElem, h, w, head_eq_iff_head?_eq_some] using head?_drop l n
+  simp [getElem?_eq_getElem, h, w, head_eq_iff_head?_eq_some]
 
 theorem getLast?_drop {l : List α} : (l.drop n).getLast? = if l.length ≤ n then none else l.getLast? := by
   rw [getLast?_eq_getElem?, getElem?_drop]
@@ -300,7 +303,7 @@ theorem getLast?_drop {l : List α} : (l.drop n).getLast? = if l.length ≤ n th
     congr
     omega
 
-theorem getLast_drop {l : List α} (h : l.drop n ≠ []) :
+@[simp] theorem getLast_drop {l : List α} (h : l.drop n ≠ []) :
     (l.drop n).getLast h = l.getLast (ne_nil_of_length_pos (by simp at h; omega)) := by
   simp only [ne_eq, drop_eq_nil_iff] at h
   apply Option.some_inj.1
@@ -449,6 +452,26 @@ theorem reverse_drop {l : List α} {n : Nat} :
     rw [w, take_zero, drop_of_length_le, reverse_nil]
     omega
 
+theorem take_add_one {l : List α} {n : Nat} :
+    l.take (n + 1) = l.take n ++ l[n]?.toList := by
+  simp [take_add, take_one]
+
+theorem drop_eq_getElem?_toList_append {l : List α} {n : Nat} :
+    l.drop n = l[n]?.toList ++ l.drop (n + 1) := by
+  induction l generalizing n with
+  | nil => simp
+  | cons hd tl ih =>
+    cases n
+    · simp
+    · simp only [drop_succ_cons, getElem?_cons_succ]
+      rw [ih]
+
+theorem drop_sub_one {l : List α} {n : Nat} (h : 0 < n) :
+    l.drop (n - 1) = l[n - 1]?.toList ++ l.drop n := by
+  rw [drop_eq_getElem?_toList_append]
+  congr
+  omega
+
 /-! ### findIdx -/
 
 theorem false_of_mem_take_findIdx {xs : List α} {p : α → Bool} (h : x ∈ xs.take (xs.findIdx p)) :

src/Init/Data/Nat/Lemmas.lean

@@ -32,6 +32,77 @@ namespace Nat
 @[simp] theorem exists_add_one_eq : (∃ n, n + 1 = a) ↔ 0 < a :=
   ⟨fun ⟨n, h⟩ => by omega, fun h => ⟨a - 1, by omega⟩⟩
 
+/-- Dependent variant of `forall_lt_succ_right`. -/
+theorem forall_lt_succ_right' {p : (m : Nat) → (m < n + 1) → Prop} :
+    (∀ m (h : m < n + 1), p m h) ↔ (∀ m (h : m < n), p m (by omega)) ∧ p n (by omega) := by
+  simp only [Nat.lt_succ_iff, Nat.le_iff_lt_or_eq]
+  constructor
+  · intro w
+    constructor
+    · intro m h
+      exact w _ (.inl h)
+    · exact w _ (.inr rfl)
+  · rintro w m (h|rfl)
+    · exact w.1 _ h
+    · exact w.2
+
+/-- See `forall_lt_succ_right'` for a variant where `p` takes the bound as an argument. -/
+theorem forall_lt_succ_right {p : Nat → Prop} :
+    (∀ m, m < n + 1 → p m) ↔ (∀ m, m < n → p m) ∧ p n := by
+  simpa using forall_lt_succ_right' (p := fun m _ => p m)
+
+/-- Dependent variant of `forall_lt_succ_left`. -/
+theorem forall_lt_succ_left' {p : (m : Nat) → (m < n + 1) → Prop} :
+    (∀ m (h : m < n + 1), p m h) ↔ p 0 (by omega) ∧ (∀ m (h : m < n), p (m + 1) (by omega)) := by
+  constructor
+  · intro w
+    constructor
+    · exact w 0 (by omega)
+    · intro m h
+      exact w (m + 1) (by omega)
+  · rintro ⟨h₀, h₁⟩ m h
+    cases m with
+    | zero => exact h₀
+    | succ m => exact h₁ m (by omega)
+
+/-- See `forall_lt_succ_left'` for a variant where `p` takes the bound as an argument. -/
+theorem forall_lt_succ_left {p : Nat → Prop} :
+    (∀ m, m < n + 1 → p m) ↔ p 0 ∧ (∀ m, m < n → p (m + 1)) := by
+  simpa using forall_lt_succ_left' (p := fun m _ => p m)
+
+/-- Dependent variant of `exists_lt_succ_right`. -/
+theorem exists_lt_succ_right' {p : (m : Nat) → (m < n + 1) → Prop} :
+    (∃ m, ∃ (h : m < n + 1), p m h) ↔ (∃ m, ∃ (h : m < n), p m (by omega)) ∨ p n (by omega) := by
+  simp only [Nat.lt_succ_iff, Nat.le_iff_lt_or_eq]
+  constructor
+  · rintro ⟨m, (h|rfl), w⟩
+    · exact .inl ⟨m, h, w⟩
+    · exact .inr w
+  · rintro (⟨m, h, w⟩ | w)
+    · exact ⟨m, by omega, w⟩
+    · exact ⟨n, by omega, w⟩
+
+/-- See `exists_lt_succ_right'` for a variant where `p` takes the bound as an argument. -/
+theorem exists_lt_succ_right {p : Nat → Prop} :
+    (∃ m, m < n + 1 ∧ p m) ↔ (∃ m, m < n ∧ p m) ∨ p n := by
+  simpa using exists_lt_succ_right' (p := fun m _ => p m)
+
+/-- Dependent variant of `exists_lt_succ_left`. -/
+theorem exists_lt_succ_left' {p : (m : Nat) → (m < n + 1) → Prop} :
+    (∃ m, ∃ (h : m < n + 1), p m h) ↔ p 0 (by omega) ∨ (∃ m, ∃ (h : m < n), p (m + 1) (by omega)) := by
+  constructor
+  · rintro ⟨_|m, h, w⟩
+    · exact .inl w
+    · exact .inr ⟨m, by omega, w⟩
+  · rintro (w|⟨m, h, w⟩)
+    · exact ⟨0, by omega, w⟩
+    · exact ⟨m + 1, by omega, w⟩
+
+/-- See `exists_lt_succ_left'` for a variant where `p` takes the bound as an argument. -/
+theorem exists_lt_succ_left {p : Nat → Prop} :
+    (∃ m, m < n + 1 ∧ p m) ↔ p 0 ∨ (∃ m, m < n ∧ p (m + 1)) := by
+  simpa using exists_lt_succ_left' (p := fun m _ => p m)
+
 /-! ## add -/
 
 protected theorem add_add_add_comm (a b c d : Nat) : (a + b) + (c + d) = (a + c) + (b + d) := by
@@ -802,6 +873,10 @@ theorem le_log2 (h : n ≠ 0) : k ≤ n.log2 ↔ 2 ^ k ≤ n := by
 theorem log2_lt (h : n ≠ 0) : n.log2 < k ↔ n < 2 ^ k := by
   rw [← Nat.not_le, ← Nat.not_le, le_log2 h]
 
+@[simp]
+theorem log2_two_pow : (2 ^ n).log2 = n := by
+  apply Nat.eq_of_le_of_lt_succ <;> simp [le_log2, log2_lt, NeZero.ne, Nat.pow_lt_pow_iff_right]
+
 theorem log2_self_le (h : n ≠ 0) : 2 ^ n.log2 ≤ n := (le_log2 h).1 (Nat.le_refl _)
 
 theorem lt_log2_self : n < 2 ^ (n.log2 + 1) :=

src/Init/Data/Option/Basic.lean

@@ -4,9 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Leonardo de Moura, Mario Carneiro
 -/
 prelude
-import Init.Core
 import Init.Control.Basic
-import Init.Coe
 
 namespace Option
 

src/Init/Data/Option/List.lean

@@ -11,4 +11,28 @@ namespace Option
 @[simp] theorem mem_toList {a : α} {o : Option α} : a ∈ o.toList ↔ a ∈ o := by
   cases o <;> simp [eq_comm]
 
+@[simp] theorem forIn'_none [Monad m] (b : β) (f : (a : α) → a ∈ none → β → m (ForInStep β)) :
+    forIn' none b f = pure b := by
+  rfl
+
+@[simp] theorem forIn'_some [Monad m] (a : α) (b : β) (f : (a' : α) → a' ∈ some a → β → m (ForInStep β)) :
+    forIn' (some a) b f = bind (f a rfl b) (fun | .done r | .yield r => pure r) := by
+  rfl
+
+@[simp] theorem forIn_none [Monad m] (b : β) (f : α → β → m (ForInStep β)) :
+    forIn none b f = pure b := by
+  rfl
+
+@[simp] theorem forIn_some [Monad m] (a : α) (b : β) (f : α → β → m (ForInStep β)) :
+    forIn (some a) b f = bind (f a b) (fun | .done r | .yield r => pure r) := by
+  rfl
+
+@[simp] theorem forIn'_toList [Monad m] (o : Option α) (b : β) (f : (a : α) → a ∈ o.toList → β → m (ForInStep β)) :
+    forIn' o.toList b f = forIn' o b fun a m b => f a (by simpa using m) b := by
+  cases o <;> rfl
+
+@[simp] theorem forIn_toList [Monad m] (o : Option α) (b : β) (f : α → β → m (ForInStep β)) :
+    forIn o.toList b f = forIn o b f := by
+  cases o <;> rfl
+
 end Option

src/Init/Data/Repr.lean

@@ -5,10 +5,6 @@ Author: Leonardo de Moura
 -/
 prelude
 import Init.Data.Format.Basic
-import Init.Data.Int.Basic
-import Init.Data.Nat.Div
-import Init.Data.UInt.BasicAux
-import Init.Control.Id
 open Sum Subtype Nat
 
 open Std

src/Init/Data/SInt.lean

@@ -0,0 +1,11 @@
+/-
+Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Henrik Böving
+-/
+prelude
+import Init.Data.SInt.Basic
+
+/-!
+This module contains the definitions and basic theory about signed fixed width integer types.
+-/

src/Init/Data/SInt/Basic.lean

@@ -0,0 +1,116 @@
+/-
+Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Henrik Böving
+-/
+prelude
+import Init.Data.UInt.Basic
+
+/-!
+This module contains the definition of signed fixed width integer types as well as basic arithmetic
+and bitwise operations on top of it.
+-/
+
+
+/--
+The type of signed 8-bit integers. This type has special support in the
+compiler to make it actually 8 bits rather than wrapping a `Nat`.
+-/
+structure Int8 where
+  /--
+  Obtain the `UInt8` that is 2's complement equivalent to the `Int8`.
+  -/
+  toUInt8 : UInt8
+
+/-- The size of type `Int8`, that is, `2^8 = 256`. -/
+abbrev Int8.size : Nat := 256
+
+/--
+Obtain the `BitVec` that contains the 2's complement representation of the `Int8`.
+-/
+@[inline] def Int8.toBitVec (x : Int8) : BitVec 8 := x.toUInt8.toBitVec
+
+@[extern "lean_int8_of_int"]
+def Int8.ofInt (i : @& Int) : Int8 := ⟨⟨BitVec.ofInt 8 i⟩⟩
+@[extern "lean_int8_of_int"]
+def Int8.ofNat (n : @& Nat) : Int8 := ⟨⟨BitVec.ofNat 8 n⟩⟩
+abbrev Int.toInt8 := Int8.ofInt
+abbrev Nat.toInt8 := Int8.ofNat
+@[extern "lean_int8_to_int"]
+def Int8.toInt (i : Int8) : Int := i.toBitVec.toInt
+@[inline] def Int8.toNat (i : Int8) : Nat := i.toInt.toNat
+@[extern "lean_int8_neg"]
+def Int8.neg (i : Int8) : Int8 := ⟨⟨-i.toBitVec⟩⟩
+
+instance : ToString Int8 where
+  toString i := toString i.toInt
+
+instance : OfNat Int8 n := ⟨Int8.ofNat n⟩
+instance : Neg Int8 where
+  neg := Int8.neg
+
+@[extern "lean_int8_add"]
+def Int8.add (a b : Int8) : Int8 := ⟨⟨a.toBitVec + b.toBitVec⟩⟩
+@[extern "lean_int8_sub"]
+def Int8.sub (a b : Int8) : Int8 := ⟨⟨a.toBitVec - b.toBitVec⟩⟩
+@[extern "lean_int8_mul"]
+def Int8.mul (a b : Int8) : Int8 := ⟨⟨a.toBitVec * b.toBitVec⟩⟩
+@[extern "lean_int8_div"]
+def Int8.div (a b : Int8) : Int8 := ⟨⟨BitVec.sdiv a.toBitVec b.toBitVec⟩⟩
+@[extern "lean_int8_mod"]
+def Int8.mod (a b : Int8) : Int8 := ⟨⟨BitVec.smod a.toBitVec b.toBitVec⟩⟩
+@[extern "lean_int8_land"]
+def Int8.land (a b : Int8) : Int8 := ⟨⟨a.toBitVec &&& b.toBitVec⟩⟩
+@[extern "lean_int8_lor"]
+def Int8.lor (a b : Int8) : Int8 := ⟨⟨a.toBitVec ||| b.toBitVec⟩⟩
+@[extern "lean_int8_xor"]
+def Int8.xor (a b : Int8) : Int8 := ⟨⟨a.toBitVec ^^^ b.toBitVec⟩⟩
+@[extern "lean_int8_shift_left"]
+def Int8.shiftLeft (a b : Int8) : Int8 := ⟨⟨a.toBitVec <<< (mod b 8).toBitVec⟩⟩
+@[extern "lean_int8_shift_right"]
+def Int8.shiftRight (a b : Int8) : Int8 := ⟨⟨BitVec.sshiftRight' a.toBitVec (mod b 8).toBitVec⟩⟩
+@[extern "lean_int8_complement"]
+def Int8.complement (a : Int8) : Int8 := ⟨⟨~~~a.toBitVec⟩⟩
+
+@[extern "lean_int8_dec_eq"]
+def Int8.decEq (a b : Int8) : Decidable (a = b) :=
+  match a, b with
+  | ⟨n⟩, ⟨m⟩ =>
+    if h : n = m then
+      isTrue <| h ▸ rfl
+    else
+      isFalse (fun h' => Int8.noConfusion h' (fun h' => absurd h' h))
+
+def Int8.lt (a b : Int8) : Prop := a.toBitVec.slt b.toBitVec
+def Int8.le (a b : Int8) : Prop := a.toBitVec.sle b.toBitVec
+
+instance : Inhabited Int8 where
+  default := 0
+
+instance : Add Int8         := ⟨Int8.add⟩
+instance : Sub Int8         := ⟨Int8.sub⟩
+instance : Mul Int8         := ⟨Int8.mul⟩
+instance : Mod Int8         := ⟨Int8.mod⟩
+instance : Div Int8         := ⟨Int8.div⟩
+instance : LT Int8          := ⟨Int8.lt⟩
+instance : LE Int8          := ⟨Int8.le⟩
+instance : Complement Int8  := ⟨Int8.complement⟩
+instance : AndOp Int8       := ⟨Int8.land⟩
+instance : OrOp Int8        := ⟨Int8.lor⟩
+instance : Xor Int8         := ⟨Int8.xor⟩
+instance : ShiftLeft Int8   := ⟨Int8.shiftLeft⟩
+instance : ShiftRight Int8  := ⟨Int8.shiftRight⟩
+instance : DecidableEq Int8 := Int8.decEq
+
+@[extern "lean_int8_dec_lt"]
+def Int8.decLt (a b : Int8) : Decidable (a < b) :=
+  inferInstanceAs (Decidable (a.toBitVec.slt b.toBitVec))
+
+@[extern "lean_int8_dec_le"]
+def Int8.decLe (a b : Int8) : Decidable (a ≤ b) :=
+  inferInstanceAs (Decidable (a.toBitVec.sle b.toBitVec))
+
+instance (a b : Int8) : Decidable (a < b) := Int8.decLt a b
+instance (a b : Int8) : Decidable (a ≤ b) := Int8.decLe a b
+instance : Max Int8 := maxOfLe
+instance : Min Int8 := minOfLe

src/Init/Data/String/Basic.lean

@@ -6,7 +6,6 @@ Author: Leonardo de Moura, Mario Carneiro
 prelude
 import Init.Data.List.Basic
 import Init.Data.Char.Basic
-import Init.Data.Option.Basic
 
 universe u
 

src/Init/Data/ToString/Basic.lean

@@ -4,14 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Author: Leonardo de Moura
 -/
 prelude
-import Init.Data.String.Basic
-import Init.Data.UInt.BasicAux
-import Init.Data.Nat.Div
 import Init.Data.Repr
-import Init.Data.Int.Basic
-import Init.Data.Format.Basic
-import Init.Control.Id
-import Init.Control.Option
+import Init.Data.Option.Basic
+
 open Sum Subtype Nat
 
 open Std

src/Init/GetElem.lean

@@ -144,22 +144,26 @@ instance (priority := low) [GetElem coll idx elem valid] [∀ xs i, Decidable (v
     LawfulGetElem coll idx elem valid where
 
 theorem getElem?_pos [GetElem? cont idx elem dom] [LawfulGetElem cont idx elem dom]
-    (c : cont) (i : idx) (h : dom c i) [Decidable (dom c i)] : c[i]? = some (c[i]'h) := by
+    (c : cont) (i : idx) (h : dom c i) : c[i]? = some (c[i]'h) := by
+  have : Decidable (dom c i) := .isTrue h
   rw [getElem?_def]
   exact dif_pos h
 
 theorem getElem?_neg [GetElem? cont idx elem dom] [LawfulGetElem cont idx elem dom]
-    (c : cont) (i : idx) (h : ¬dom c i) [Decidable (dom c i)] : c[i]? = none := by
+    (c : cont) (i : idx) (h : ¬dom c i) : c[i]? = none := by
+  have : Decidable (dom c i) := .isFalse h
   rw [getElem?_def]
   exact dif_neg h
 
 theorem getElem!_pos [GetElem? cont idx elem dom] [LawfulGetElem cont idx elem dom]
-    [Inhabited elem] (c : cont) (i : idx) (h : dom c i) [Decidable (dom c i)] :
+    [Inhabited elem] (c : cont) (i : idx) (h : dom c i) :
     c[i]! = c[i]'h := by
+  have : Decidable (dom c i) := .isTrue h
   simp [getElem!_def, getElem?_def, h]
 
 theorem getElem!_neg [GetElem? cont idx elem dom] [LawfulGetElem cont idx elem dom]
-    [Inhabited elem] (c : cont) (i : idx) (h : ¬dom c i) [Decidable (dom c i)] : c[i]! = default := by
+    [Inhabited elem] (c : cont) (i : idx) (h : ¬dom c i) : c[i]! = default := by
+  have : Decidable (dom c i) := .isFalse h
   simp [getElem!_def, getElem?_def, h]
 
 namespace Fin
@@ -203,6 +207,10 @@ instance : GetElem (List α) Nat α fun as i => i < as.length where
 
 @[deprecated (since := "2024-06-12")] abbrev cons_getElem_succ := @getElem_cons_succ
 
+@[simp] theorem getElem_mem : ∀ {l : List α} {n} (h : n < l.length), l[n]'h ∈ l
+  | _ :: _, 0, _ => .head ..
+  | _ :: l, _+1, _ => .tail _ (getElem_mem (l := l) ..)
+
 theorem get_drop_eq_drop (as : List α) (i : Nat) (h : i < as.length) : as[i] :: as.drop (i+1) = as.drop i :=
   match as, i with
   | _::_, 0   => rfl

src/Init/Notation.lean

@@ -341,16 +341,19 @@ macro_rules | `($x == $y) => `(binrel_no_prop% BEq.beq $x $y)
 notation:50 a:50 " ∉ " b:50 => ¬ (a ∈ b)
 
 @[inherit_doc] infixr:67 " :: " => List.cons
-@[inherit_doc HOrElse.hOrElse] syntax:20 term:21 " <|> " term:20 : term
-@[inherit_doc HAndThen.hAndThen] syntax:60 term:61 " >> " term:60 : term
-@[inherit_doc] infixl:55  " >>= " => Bind.bind
-@[inherit_doc] notation:60 a:60 " <*> " b:61 => Seq.seq a fun _ : Unit => b
-@[inherit_doc] notation:60 a:60 " <* " b:61 => SeqLeft.seqLeft a fun _ : Unit => b
-@[inherit_doc] notation:60 a:60 " *> " b:61 => SeqRight.seqRight a fun _ : Unit => b
 @[inherit_doc] infixr:100 " <$> " => Functor.map
+@[inherit_doc] infixl:55  " >>= " => Bind.bind
+@[inherit_doc HOrElse.hOrElse]   syntax:20 term:21 " <|> " term:20 : term
+@[inherit_doc HAndThen.hAndThen] syntax:60 term:61 " >> " term:60 : term
+@[inherit_doc Seq.seq]           syntax:60 term:60 " <*> " term:61 : term
+@[inherit_doc SeqLeft.seqLeft]   syntax:60 term:60 " <* " term:61 : term
+@[inherit_doc SeqRight.seqRight] syntax:60 term:60 " *> " term:61 : term
 
 macro_rules | `($x <|> $y) => `(binop_lazy% HOrElse.hOrElse $x $y)
 macro_rules | `($x >> $y)  => `(binop_lazy% HAndThen.hAndThen $x $y)
+macro_rules | `($x <*> $y) => `(Seq.seq $x fun _ : Unit => $y)
+macro_rules | `($x <* $y)  => `(SeqLeft.seqLeft $x fun _ : Unit => $y)
+macro_rules | `($x *> $y)  => `(SeqRight.seqRight $x fun _ : Unit => $y)
 
 namespace Lean
 

src/Init/NotationExtra.lean

@@ -10,6 +10,7 @@ import Init.Data.ToString.Basic
 import Init.Data.Array.Subarray
 import Init.Conv
 import Init.Meta
+import Init.While
 
 namespace Lean
 
@@ -168,9 +169,9 @@ end Lean
   | _                => throw ()
 
 @[app_unexpander sorryAx] def unexpandSorryAx : Lean.PrettyPrinter.Unexpander
-  | `($(_) _)   => `(sorry)
-  | `($(_) _ _) => `(sorry)
-  | _           => throw ()
+  | `($(_) $_)    => `(sorry)
+  | `($(_) $_ $_) => `(sorry)
+  | _             => throw ()
 
 @[app_unexpander Eq.ndrec] def unexpandEqNDRec : Lean.PrettyPrinter.Unexpander
   | `($(_) $m $h) => `($h ▸ $m)
@@ -344,42 +345,6 @@ syntax (name := solveTactic) "solve" withPosition((ppDedent(ppLine) colGe "| " t
 macro_rules
   | `(tactic| solve $[| $ts]* ) => `(tactic| focus first $[| ($ts); done]*)
 
-/-! # `repeat` and `while` notation -/
-
-inductive Loop where
-  | mk
-
-@[inline]
-partial def Loop.forIn {β : Type u} {m : Type u → Type v} [Monad m] (_ : Loop) (init : β) (f : Unit → β → m (ForInStep β)) : m β :=
-  let rec @[specialize] loop (b : β) : m β := do
-    match ← f () b with
-      | ForInStep.done b  => pure b
-      | ForInStep.yield b => loop b
-  loop init
-
-instance : ForIn m Loop Unit where
-  forIn := Loop.forIn
-
-syntax "repeat " doSeq : doElem
-
-macro_rules
-  | `(doElem| repeat $seq) => `(doElem| for _ in Loop.mk do $seq)
-
-syntax "while " ident " : " termBeforeDo " do " doSeq : doElem
-
-macro_rules
-  | `(doElem| while $h : $cond do $seq) => `(doElem| repeat if $h : $cond then $seq else break)
-
-syntax "while " termBeforeDo " do " doSeq : doElem
-
-macro_rules
-  | `(doElem| while $cond do $seq) => `(doElem| repeat if $cond then $seq else break)
-
-syntax "repeat " doSeq ppDedent(ppLine) "until " term : doElem
-
-macro_rules
-  | `(doElem| repeat $seq until $cond) => `(doElem| repeat do $seq:doSeq; if $cond then break)
-
 macro:50 e:term:51 " matches " p:sepBy1(term:51, " | ") : term =>
   `(((match $e:term with | $[$p:term]|* => true | _ => false) : Bool))
 

src/Init/System/FilePath.lean

@@ -5,8 +5,6 @@ Authors: Leonardo de Moura, Sebastian Ullrich
 -/
 prelude
 import Init.System.Platform
-import Init.Data.String.Basic
-import Init.Data.Repr
 import Init.Data.ToString.Basic
 
 namespace System

src/Init/System/IO.lean

@@ -4,13 +4,9 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Luke Nelson, Jared Roesch, Leonardo de Moura, Sebastian Ullrich, Mac Malone
 -/
 prelude
-import Init.Control.Reader
-import Init.Data.String
-import Init.Data.ByteArray
 import Init.System.IOError
 import Init.System.FilePath
 import Init.System.ST
-import Init.Data.ToString.Macro
 import Init.Data.Ord
 
 open System

src/Init/System/IOError.lean

@@ -5,10 +5,7 @@ Authors: Simon Hudon
 -/
 
 prelude
-import Init.Core
-import Init.Data.UInt.Basic
 import Init.Data.ToString.Basic
-import Init.Data.String.Basic
 
 /--
 Imitate the structure of IOErrorType in Haskell:

src/Init/Tactics.lean

@@ -495,7 +495,7 @@ macro (name := rwSeq) "rw " c:(config)? s:rwRuleSeq l:(location)? : tactic =>
     `(tactic| (rewrite $(c)? [$rs,*] $(l)?; with_annotate_state $rbrak (try (with_reducible rfl))))
   | _ => Macro.throwUnsupported
 
-/-- `rwa` calls `rw`, then closes any remaining goals using `assumption`. -/
+/-- `rwa` is short-hand for `rw; assumption`. -/
 macro "rwa " rws:rwRuleSeq loc:(location)? : tactic =>
   `(tactic| (rw $rws:rwRuleSeq $[$loc:location]?; assumption))
 
@@ -1490,6 +1490,11 @@ have been simplified by using the modifier `↓`. Here is an example
 @[simp↓] theorem not_and_eq (p q : Prop) : (¬ (p ∧ q)) = (¬p ∨ ¬q) :=
 ```
 
+You can instruct the simplifier to rewrite the lemma from right-to-left:
+```lean
+attribute @[simp ←] and_assoc
+```
+
 When multiple simp theorems are applicable, the simplifier uses the one with highest priority.
 The equational theorems of function are applied at very low priority (100 and below).
 If there are several with the same priority, it is uses the "most recent one". Example:
@@ -1501,7 +1506,7 @@ If there are several with the same priority, it is uses the "most recent one". E
   cases d <;> rfl
 ```
 -/
-syntax (name := simp) "simp" (Tactic.simpPre <|> Tactic.simpPost)? (ppSpace prio)? : attr
+syntax (name := simp) "simp" (Tactic.simpPre <|> Tactic.simpPost)? patternIgnore("← " <|> "<- ")? (ppSpace prio)? : attr
 
 /--
 Theorems tagged with the `grind_norm` attribute are used by the `grind` tactic normalizer/pre-processor.

src/Init/While.lean

@@ -0,0 +1,51 @@
+/-
+Copyright (c) 2020 Microsoft Corporation. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Leonardo de Moura
+-/
+prelude
+import Init.Core
+
+/-!
+# Notation for `while` and `repeat` loops.
+-/
+
+namespace Lean
+
+/-! # `repeat` and `while` notation -/
+
+inductive Loop where
+  | mk
+
+@[inline]
+partial def Loop.forIn {β : Type u} {m : Type u → Type v} [Monad m] (_ : Loop) (init : β) (f : Unit → β → m (ForInStep β)) : m β :=
+  let rec @[specialize] loop (b : β) : m β := do
+    match ← f () b with
+      | ForInStep.done b  => pure b
+      | ForInStep.yield b => loop b
+  loop init
+
+instance : ForIn m Loop Unit where
+  forIn := Loop.forIn
+
+syntax "repeat " doSeq : doElem
+
+macro_rules
+  | `(doElem| repeat $seq) => `(doElem| for _ in Loop.mk do $seq)
+
+syntax "while " ident " : " termBeforeDo " do " doSeq : doElem
+
+macro_rules
+  | `(doElem| while $h : $cond do $seq) => `(doElem| repeat if $h : $cond then $seq else break)
+
+syntax "while " termBeforeDo " do " doSeq : doElem
+
+macro_rules
+  | `(doElem| while $cond do $seq) => `(doElem| repeat if $cond then $seq else break)
+
+syntax "repeat " doSeq ppDedent(ppLine) "until " term : doElem
+
+macro_rules
+  | `(doElem| repeat $seq until $cond) => `(doElem| repeat do $seq:doSeq; if $cond then break)
+
+end Lean

src/Lean/Class.lean

@@ -87,7 +87,7 @@ def hasOutParams (env : Environment) (declName : Name) : Bool :=
   incorrect. This transformation would be counterintuitive to users since
   we would implicitly treat these regular parameters as `outParam`s.
 -/
-private partial def checkOutParam (i : Nat) (outParamFVarIds : Array FVarId) (outParams : Array Nat) (type : Expr) : Except String (Array Nat) :=
+private partial def checkOutParam (i : Nat) (outParamFVarIds : Array FVarId) (outParams : Array Nat) (type : Expr) : Except MessageData (Array Nat) :=
   match type with
   | .forallE _ d b bi =>
     let addOutParam (_ : Unit) :=
@@ -102,7 +102,7 @@ private partial def checkOutParam (i : Nat) (outParamFVarIds : Array FVarId) (ou
         /- See issue #1852 for a motivation for `bi.isInstImplicit` -/
         addOutParam ()
       else
-        Except.error s!"invalid class, parameter #{i+1} depends on `outParam`, but it is not an `outParam`"
+        Except.error m!"invalid class, parameter #{i+1} depends on `outParam`, but it is not an `outParam`"
     else
       checkOutParam (i+1) outParamFVarIds outParams b
   | _ => return outParams
@@ -149,13 +149,13 @@ and it must be the name of constant in `env`.
 `declName` must be a inductive datatype or axiom.
 Recall that all structures are inductive datatypes.
 -/
-def addClass (env : Environment) (clsName : Name) : Except String Environment := do
+def addClass (env : Environment) (clsName : Name) : Except MessageData Environment := do
   if isClass env clsName then
-    throw s!"class has already been declared '{clsName}'"
+    throw m!"class has already been declared '{.ofConstName clsName true}'"
   let some decl := env.find? clsName
-    | throw s!"unknown declaration '{clsName}'"
+    | throw m!"unknown declaration '{clsName}'"
   unless decl matches .inductInfo .. | .axiomInfo .. do
-    throw s!"invalid 'class', declaration '{clsName}' must be inductive datatype, structure, or constant"
+    throw m!"invalid 'class', declaration '{.ofConstName clsName}' must be inductive datatype, structure, or constant"
   let outParams ← checkOutParam 0 #[] #[] decl.type
   return classExtension.addEntry env { name := clsName, outParams }
 

src/Lean/Compiler/LCNF/PullLetDecls.lean

@@ -46,7 +46,7 @@ partial def withCheckpoint (x : PullM Code) : PullM Code := do
     else
       return c
   let (c, keep) := go toPullSizeSaved (← read).included |>.run #[]
-  modify fun s => { s with toPull := s.toPull.shrink toPullSizeSaved ++ keep }
+  modify fun s => { s with toPull := s.toPull.take toPullSizeSaved ++ keep }
   return c
 
 def attachToPull (c : Code) : PullM Code := do

src/Lean/Declaration.lean

@@ -369,8 +369,13 @@ def RecursorVal.getFirstIndexIdx (v : RecursorVal) : Nat :=
 def RecursorVal.getFirstMinorIdx (v : RecursorVal) : Nat :=
   v.numParams + v.numMotives
 
-def RecursorVal.getInduct (v : RecursorVal) : Name :=
-  v.name.getPrefix
+/-- The inductive type of the major argument of the recursor. -/
+def RecursorVal.getMajorInduct (v : RecursorVal) : Name :=
+  go v.getMajorIdx v.type
+where
+  go
+  | 0, e => e.bindingDomain!.getAppFn.constName!
+  | n+1, e => go n e.bindingBody!
 
 inductive QuotKind where
   | type  -- `Quot`
@@ -467,6 +472,10 @@ def isInductive : ConstantInfo → Bool
   | inductInfo _ => true
   | _            => false
 
+def isTheorem : ConstantInfo → Bool
+  | thmInfo _ => true
+  | _         => false
+
 def inductiveVal! : ConstantInfo → InductiveVal
   | .inductInfo val => val
   | _ => panic! "Expected a `ConstantInfo.inductInfo`."

src/Lean/Elab/App.lean

@@ -1150,7 +1150,7 @@ private partial def findMethod? (env : Environment) (structName fieldName : Name
     | some _ => some (structName, fullNamePrv)
     | none   =>
       if isStructure env structName then
-        (getParentStructures env structName).findSome? fun parentStructName => findMethod? env parentStructName fieldName
+        (getStructureSubobjects env structName).findSome? fun parentStructName => findMethod? env parentStructName fieldName
       else
         none
 

src/Lean/Elab/BuiltinCommand.lean

@@ -12,16 +12,18 @@ import Lean.Elab.Eval
 import Lean.Elab.Command
 import Lean.Elab.Open
 import Lean.Elab.SetOption
+import Init.System.Platform
 
 namespace Lean.Elab.Command
 
 @[builtin_command_elab moduleDoc] def elabModuleDoc : CommandElab := fun stx => do
-   match stx[1] with
-   | Syntax.atom _ val =>
-     let doc := val.extract 0 (val.endPos - ⟨2⟩)
-     let range ← Elab.getDeclarationRange stx
-     modifyEnv fun env => addMainModuleDoc env ⟨doc, range⟩
-   | _ => throwErrorAt stx "unexpected module doc string{indentD stx[1]}"
+  match stx[1] with
+  | Syntax.atom _ val =>
+    let doc := val.extract 0 (val.endPos - ⟨2⟩)
+    let some range ← Elab.getDeclarationRange? stx
+      | return  -- must be from partial syntax, ignore
+    modifyEnv fun env => addMainModuleDoc env ⟨doc, range⟩
+  | _ => throwErrorAt stx "unexpected module doc string{indentD stx[1]}"
 
 private def addScope (isNewNamespace : Bool) (isNoncomputable : Bool) (header : String) (newNamespace : Name) : CommandElabM Unit := do
   modify fun s => { s with
@@ -341,7 +343,7 @@ def failIfSucceeds (x : CommandElabM Unit) : CommandElabM Unit := do
     if let .none ← findDeclarationRangesCore? declName then
       -- this is only relevant for declarations added without a declaration range
       -- in particular `Quot.mk` et al which are added by `init_quot`
-      addAuxDeclarationRanges declName stx id
+      addDeclarationRangesFromSyntax declName stx id
     addDocString declName (← getDocStringText doc)
   | _ => throwUnsupportedSyntax
 
@@ -403,6 +405,16 @@ def failIfSucceeds (x : CommandElabM Unit) : CommandElabM Unit := do
       includedVars := sc.includedVars.filter (!omittedVars.contains ·) }
   | _ => throwUnsupportedSyntax
 
+@[builtin_command_elab version] def elabVersion : CommandElab := fun _ => do
+  let mut target := System.Platform.target
+  if target.isEmpty then target := "unknown"
+  -- Only one should be set, but good to know if multiple are set in error.
+  let platforms :=
+    (if System.Platform.isWindows then [" Windows"] else [])
+    ++ (if System.Platform.isOSX then [" macOS"] else [])
+    ++ (if System.Platform.isEmscripten then [" Emscripten"] else [])
+  logInfo m!"Lean {Lean.versionString}\nTarget: {target}{String.join platforms}"
+
 @[builtin_command_elab Parser.Command.exit] def elabExit : CommandElab := fun _ =>
   logWarning "using 'exit' to interrupt Lean"
 

src/Lean/Elab/BuiltinEvalCommand.lean

@@ -136,7 +136,7 @@ private def mkFormat (e : Expr) : MetaM Expr := do
     if eval.derive.repr.get (← getOptions) then
       if let .const name _ := (← whnf (← inferType e)).getAppFn then
         try
-          trace[Elab.eval] "Attempting to derive a 'Repr' instance for '{MessageData.ofConstName name}'"
+          trace[Elab.eval] "Attempting to derive a 'Repr' instance for '{.ofConstName name}'"
           liftCommandElabM do applyDerivingHandlers ``Repr #[name] none
           resetSynthInstanceCache
           return ← mkRepr e
@@ -201,9 +201,9 @@ unsafe def elabEvalCoreUnsafe (bang : Bool) (tk term : Syntax) (expectedType? :
           discard <| withLocalDeclD `x ty fun x => mkT x
         catch _ =>
           throw ex
-        throwError m!"unable to synthesize '{MessageData.ofConstName ``MonadEval}' instance \
+        throwError m!"unable to synthesize '{.ofConstName ``MonadEval}' instance \
           to adapt{indentExpr (← inferType e)}\n\
-          to '{MessageData.ofConstName ``IO}' or '{MessageData.ofConstName ``CommandElabM}'."
+          to '{.ofConstName ``IO}' or '{.ofConstName ``CommandElabM}'."
       addAndCompileExprForEval declName r (allowSorry := bang)
       -- `evalConst` may emit IO, but this is collected by `withIsolatedStreams` below.
       let r ← toMessageData <$> evalConst t declName

src/Lean/Elab/Calc.lean

@@ -10,10 +10,11 @@ namespace Lean.Elab.Term
 open Meta
 
 /--
-  Decompose `e` into `(r, a, b)`.
+Decompose `e` into `(r, a, b)`.
 
-  Remark: it assumes the last two arguments are explicit. -/
-def getCalcRelation? (e : Expr) : MetaM (Option (Expr × Expr × Expr)) :=
+Remark: it assumes the last two arguments are explicit.
+-/
+def getCalcRelation? (e : Expr) : MetaM (Option (Expr × Expr × Expr)) := do
   if e.getAppNumArgs < 2 then
     return none
   else
@@ -68,56 +69,102 @@ where
     | .node i k as => return .node i k (← as.mapM go)
     | _ => set false; return t
 
-def getCalcFirstStep (step0 : TSyntax ``calcFirstStep) : TermElabM (TSyntax ``calcStep) :=
+/-- View of a `calcStep`. -/
+structure CalcStepView where
+  ref : Syntax
+  /-- A relation term like `a ≤ b` -/
+  term : Term
+  /-- A proof of `term` -/
+  proof : Term
+  deriving Inhabited
+
+def mkCalcFirstStepView (step0 : TSyntax ``calcFirstStep) : TermElabM CalcStepView :=
   withRef step0 do
   match step0  with
-  | `(calcFirstStep| $term:term) =>
-    `(calcStep| $term = _ := rfl)
-  | `(calcFirstStep| $term := $proof) =>
-    `(calcStep| $term := $proof)
+  | `(calcFirstStep| $term:term)      => return { ref := step0, term := ← `($term = _), proof := ← ``(rfl)}
+  | `(calcFirstStep| $term := $proof) => return { ref := step0, term, proof}
   | _ => throwUnsupportedSyntax
 
-def getCalcSteps (steps : TSyntax ``calcSteps) : TermElabM (Array (TSyntax ``calcStep)) :=
+def mkCalcStepViews (steps : TSyntax ``calcSteps) : TermElabM (Array CalcStepView) :=
   match steps with
   | `(calcSteps|
         $step0:calcFirstStep
         $rest*) => do
-    let step0 ← getCalcFirstStep step0
-    pure (#[step0] ++ rest)
-  | _ => unreachable!
+    let mut steps := #[← mkCalcFirstStepView step0]
+    for step in rest do
+      let `(calcStep| $term := $proof) := step | throwUnsupportedSyntax
+      steps := steps.push { ref := step, term, proof }
+    return steps
+  | _ => throwUnsupportedSyntax
 
-def elabCalcSteps (steps : TSyntax ``calcSteps) : TermElabM Expr := do
+def elabCalcSteps (steps : Array CalcStepView) : TermElabM (Expr × Expr) := do
   let mut result? := none
   let mut prevRhs? := none
-  for step in ← getCalcSteps steps do
-    let `(calcStep| $pred := $proofTerm) := step | unreachable!
+  for step in steps do
     let type ← elabType <| ← do
       if let some prevRhs := prevRhs? then
-        annotateFirstHoleWithType pred (← inferType prevRhs)
+        annotateFirstHoleWithType step.term (← inferType prevRhs)
       else
-        pure pred
+        pure step.term
     let some (_, lhs, rhs) ← getCalcRelation? type |
-      throwErrorAt pred "invalid 'calc' step, relation expected{indentExpr type}"
+      throwErrorAt step.term "invalid 'calc' step, relation expected{indentExpr type}"
     if let some prevRhs := prevRhs? then
       unless (← isDefEqGuarded lhs prevRhs) do
-        throwErrorAt pred "invalid 'calc' step, left-hand-side is{indentD m!"{lhs} : {← inferType lhs}"}\nprevious right-hand-side is{indentD m!"{prevRhs} : {← inferType prevRhs}"}" -- "
-    let proof ← withFreshMacroScope do elabTermEnsuringType proofTerm type
+        throwErrorAt step.term "\
+          invalid 'calc' step, left-hand side is{indentD m!"{lhs} : {← inferType lhs}"}\n\
+          but previous right-hand side is{indentD m!"{prevRhs} : {← inferType prevRhs}"}"
+    let proof ← withFreshMacroScope do elabTermEnsuringType step.proof type
     result? := some <| ← do
       if let some (result, resultType) := result? then
         synthesizeSyntheticMVarsUsingDefault
-        withRef pred do mkCalcTrans result resultType proof type
+        withRef step.term do mkCalcTrans result resultType proof type
       else
         pure (proof, type)
     prevRhs? := rhs
-  return result?.get!.1
+  synthesizeSyntheticMVarsUsingDefault
+  return result?.get!
+
+def throwCalcFailure (steps : Array CalcStepView) (expectedType result : Expr) : MetaM α := do
+  let resultType := (← instantiateMVars (← inferType result)).headBeta
+  let some (r, lhs, rhs) ← getCalcRelation? resultType | unreachable!
+  if let some (er, elhs, erhs) ← getCalcRelation? expectedType then
+    if ← isDefEqGuarded r er then
+      let mut failed := false
+      unless ← isDefEqGuarded lhs elhs do
+        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}"}"
+        failed := true
+      unless ← isDefEqGuarded rhs erhs do
+        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}"}"
+        failed := true
+      if failed then
+        throwAbortTerm
+  throwTypeMismatchError "'calc' expression" expectedType resultType result
+
+/-!
+Warning! It is *very* tempting to try to improve `calc` so that it makes use of the expected type
+to unify with the LHS and RHS.
+Two people have already re-implemented `elabCalcSteps` trying to do so and then reverted the changes,
+not being aware of examples like https://github.com/leanprover/lean4/issues/2073
+
+The problem is that the expected type might need to be unfolded to get an accurate LHS and RHS.
+(Consider `≤` vs `≥`. Users expect to be able to use `calc` to prove `≥` using chained `≤`!)
+Furthermore, the types of the LHS and RHS do not need to be the same (consider `x ∈ S` as a relation),
+so we also cannot use the expected LHS and RHS as type hints.
+-/
 
 /-- Elaborator for the `calc` term mode variant. -/
 @[builtin_term_elab Lean.calc]
-def elabCalc : TermElab := fun stx expectedType? => do
-  let steps : TSyntax ``calcSteps := ⟨stx[1]⟩
-  let result ← elabCalcSteps steps
-  synthesizeSyntheticMVarsUsingDefault
-  let result ← ensureHasType expectedType? result
-  return result
+def elabCalc : TermElab
+  | `(calc%$tk $steps:calcSteps), expectedType? => withRef tk do
+    let steps ← mkCalcStepViews steps
+    let (result, _) ← elabCalcSteps steps
+    ensureHasTypeWithErrorMsgs expectedType? result
+      (mkImmedErrorMsg := fun _ => throwCalcFailure steps)
+      (mkErrorMsg := fun _ => throwCalcFailure steps)
+  | _, _ => throwUnsupportedSyntax
 
 end Lean.Elab.Term

src/Lean/Elab/Command.lean

@@ -711,21 +711,54 @@ def addUnivLevel (idStx : Syntax) : CommandElabM Unit := withRef idStx do
   else
     modifyScope fun scope => { scope with levelNames := id :: scope.levelNames }
 
-def expandDeclId (declId : Syntax) (modifiers : Modifiers) : CommandElabM ExpandDeclIdResult := do
-  let currNamespace ← getCurrNamespace
-  let currLevelNames ← getLevelNames
-  let r ← Elab.expandDeclId currNamespace currLevelNames declId modifiers
-  for id in (← (← getScope).varDecls.flatMapM getBracketedBinderIds) do
-    if id == r.shortName then
-      throwError "invalid declaration name '{r.shortName}', there is a section variable with the same name"
-  return r
-
 end Elab.Command
 
 open Elab Command MonadRecDepth
 
+private def liftCommandElabMCore (cmd : CommandElabM α) (throwOnError : Bool) : CoreM α := do
+  let s : Core.State ← get
+  let ctx : Core.Context ← read
+  let (a, commandState) ←
+    cmd.run {
+      fileName := ctx.fileName
+      fileMap := ctx.fileMap
+      currRecDepth := ctx.currRecDepth
+      currMacroScope := ctx.currMacroScope
+      ref := ctx.ref
+      tacticCache? := none
+      snap? := none
+      cancelTk? := ctx.cancelTk?
+      suppressElabErrors := ctx.suppressElabErrors
+    } |>.run {
+      env := s.env
+      nextMacroScope := s.nextMacroScope
+      maxRecDepth := ctx.maxRecDepth
+      ngen := s.ngen
+      scopes := [{ header := "", opts := ctx.options }]
+      infoState.enabled := s.infoState.enabled
+    }
+  modify fun coreState => { coreState with
+    env := commandState.env
+    nextMacroScope := commandState.nextMacroScope
+    ngen := commandState.ngen
+    traceState.traces := coreState.traceState.traces ++ commandState.traceState.traces
+  }
+  if throwOnError then
+    if let some err := commandState.messages.toArray.find? (·.severity matches .error) then
+      throwError err.data
+  modify fun coreState => { coreState with
+    infoState.trees := coreState.infoState.trees.append commandState.infoState.trees
+    messages := coreState.messages ++ commandState.messages
+  }
+  return a
+
 /--
-Lifts an action in `CommandElabM` into `CoreM`, updating the traces and the environment.
+Lifts an action in `CommandElabM` into `CoreM`, updating the environment,
+messages, info trees, traces, the name generator, and macro scopes.
+The action is run in a context with an empty message log, empty trace state, and empty info trees.
+
+If `throwOnError` is true, then if the command produces an error message, it is converted into an exception.
+In this case, info trees and messages are not carried over.
 
 Commands that modify the processing of subsequent commands,
 such as `open` and `namespace` commands,
@@ -738,27 +771,9 @@ to reset the instance cache.
 While the `modifyEnv` function for `MetaM` clears its caches entirely,
 `liftCommandElabM` has no way to reset these caches.
 -/
-def liftCommandElabM (cmd : CommandElabM α) : CoreM α := do
-  let (a, commandState) ←
-    cmd.run {
-      fileName := ← getFileName
-      fileMap := ← getFileMap
-      ref := ← getRef
-      tacticCache? := none
-      snap? := none
-      cancelTk? := (← read).cancelTk?
-    } |>.run {
-      env := ← getEnv
-      maxRecDepth := ← getMaxRecDepth
-      scopes := [{ header := "", opts := ← getOptions }]
-    }
-  modify fun coreState => { coreState with
-    traceState.traces := coreState.traceState.traces ++ commandState.traceState.traces
-    env := commandState.env
-  }
-  if let some err := commandState.messages.toArray.find? (·.severity matches .error) then
-    throwError err.data
-  pure a
+def liftCommandElabM (cmd : CommandElabM α) (throwOnError : Bool := true) : CoreM α := do
+  -- `observing` ensures that if `cmd` throws an exception we still thread state back to `CoreM`.
+  MonadExcept.ofExcept (← liftCommandElabMCore (observing cmd) throwOnError)
 
 /--
 Given a command elaborator `cmd`, returns a new command elaborator that

src/Lean/Elab/DeclModifiers.lean

@@ -25,19 +25,19 @@ def checkNotAlreadyDeclared {m} [Monad m] [MonadEnv m] [MonadError m] [MonadInfo
   if env.contains declName then
     addInfo declName
     match privateToUserName? declName with
-    | none          => throwError "'{declName}' has already been declared"
-    | some declName => throwError "private declaration '{declName}' has already been declared"
+    | none          => throwError "'{.ofConstName declName true}' has already been declared"
+    | some declName => throwError "private declaration '{.ofConstName declName true}' has already been declared"
   if isReservedName env declName then
     throwError "'{declName}' is a reserved name"
   if env.contains (mkPrivateName env declName) then
     addInfo (mkPrivateName env declName)
-    throwError "a private declaration '{declName}' has already been declared"
+    throwError "a private declaration '{.ofConstName declName true}' has already been declared"
   match privateToUserName? declName with
   | none => pure ()
   | some declName =>
     if env.contains declName then
       addInfo declName
-      throwError "a non-private declaration '{declName}' has already been declared"
+      throwError "a non-private declaration '{.ofConstName declName true}' has already been declared"
 
 /-- Declaration visibility modifier. That is, whether a declaration is regular, protected or private. -/
 inductive Visibility where
@@ -57,6 +57,8 @@ inductive RecKind where
 
 /-- Flags and data added to declarations (eg docstrings, attributes, `private`, `unsafe`, `partial`, ...). -/
 structure Modifiers where
+  /-- Input syntax, used for adjusting declaration range (unless missing) -/
+  stx             : TSyntax ``Parser.Command.declModifiers := ⟨.missing⟩
   docString?      : Option String := none
   visibility      : Visibility := Visibility.regular
   isNoncomputable : Bool := false
@@ -121,16 +123,16 @@ section Methods
 variable [Monad m] [MonadEnv m] [MonadResolveName m] [MonadError m] [MonadMacroAdapter m] [MonadRecDepth m] [MonadTrace m] [MonadOptions m] [AddMessageContext m] [MonadLog m] [MonadInfoTree m] [MonadLiftT IO m]
 
 /-- Elaborate declaration modifiers (i.e., attributes, `partial`, `private`, `protected`, `unsafe`, `noncomputable`, doc string)-/
-def elabModifiers (stx : Syntax) : m Modifiers := do
-  let docCommentStx := stx[0]
-  let attrsStx      := stx[1]
-  let visibilityStx := stx[2]
-  let noncompStx    := stx[3]
-  let unsafeStx     := stx[4]
+def elabModifiers (stx : TSyntax ``Parser.Command.declModifiers) : m Modifiers := do
+  let docCommentStx := stx.raw[0]
+  let attrsStx      := stx.raw[1]
+  let visibilityStx := stx.raw[2]
+  let noncompStx    := stx.raw[3]
+  let unsafeStx     := stx.raw[4]
   let recKind       :=
-    if stx[5].isNone then
+    if stx.raw[5].isNone then
       RecKind.default
-    else if stx[5][0].getKind == ``Parser.Command.partial then
+    else if stx.raw[5][0].getKind == ``Parser.Command.partial then
       RecKind.partial
     else
       RecKind.nonrec
@@ -148,7 +150,7 @@ def elabModifiers (stx : Syntax) : m Modifiers := do
     | none       => pure #[]
     | some attrs => elabDeclAttrs attrs
   return {
-    docString?, visibility, recKind, attrs,
+    stx, docString?, visibility, recKind, attrs,
     isUnsafe        := !unsafeStx.isNone
     isNoncomputable := !noncompStx.isNone
   }

src/Lean/Elab/Declaration.lean

@@ -102,14 +102,16 @@ def elabAxiom (modifiers : Modifiers) (stx : Syntax) : CommandElabM Unit := do
   -- leading_parser "axiom " >> declId >> declSig
   let declId             := stx[1]
   let (binders, typeStx) := expandDeclSig stx[2]
-  let scopeLevelNames ← getLevelNames
-  let ⟨_, declName, allUserLevelNames⟩ ← expandDeclId declId modifiers
-  addDeclarationRanges declName stx
-  runTermElabM fun vars =>
+  runTermElabM fun vars => do
+    let scopeLevelNames ← Term.getLevelNames
+    let ⟨shortName, declName, allUserLevelNames⟩ ← Term.expandDeclId (← getCurrNamespace) scopeLevelNames declId modifiers
+    addDeclarationRangesForBuiltin declName modifiers.stx stx
+    Term.withAutoBoundImplicitForbiddenPred (fun n => shortName == n) do
     Term.withDeclName declName <| Term.withLevelNames allUserLevelNames <| Term.elabBinders binders.getArgs fun xs => do
       Term.applyAttributesAt declName modifiers.attrs AttributeApplicationTime.beforeElaboration
       let type ← Term.elabType typeStx
       Term.synthesizeSyntheticMVarsNoPostponing
+      let xs ← Term.addAutoBoundImplicits xs
       let type ← instantiateMVars type
       let type ← mkForallFVars xs type
       let type ← mkForallFVars vars type (usedOnly := true)
@@ -135,63 +137,6 @@ def elabAxiom (modifiers : Modifiers) (stx : Syntax) : CommandElabM Unit := do
           compileDecl decl
         Term.applyAttributesAt declName modifiers.attrs AttributeApplicationTime.afterCompilation
 
-/-
-leading_parser "inductive " >> declId >> optDeclSig >> optional ("where" <|> ":=") >> many ctor
-leading_parser atomic (group ("class " >> "inductive ")) >> declId >> optDeclSig >> optional ("where" <|> ":=") >> many ctor >> optDeriving
--/
-private def inductiveSyntaxToView (modifiers : Modifiers) (decl : Syntax) : CommandElabM InductiveView := do
-  checkValidInductiveModifier modifiers
-  let (binders, type?) := expandOptDeclSig decl[2]
-  let declId           := decl[1]
-  let ⟨name, declName, levelNames⟩ ← expandDeclId declId modifiers
-  addDeclarationRanges declName decl
-  let ctors      ← decl[4].getArgs.mapM fun ctor => withRef ctor do
-    -- def ctor := leading_parser optional docComment >> "\n| " >> declModifiers >> rawIdent >> optDeclSig
-    let mut ctorModifiers ← elabModifiers ctor[2]
-    if let some leadingDocComment := ctor[0].getOptional? then
-      if ctorModifiers.docString?.isSome then
-        logErrorAt leadingDocComment "duplicate doc string"
-      ctorModifiers := { ctorModifiers with docString? := TSyntax.getDocString ⟨leadingDocComment⟩ }
-    if ctorModifiers.isPrivate && modifiers.isPrivate then
-      throwError "invalid 'private' constructor in a 'private' inductive datatype"
-    if ctorModifiers.isProtected && modifiers.isPrivate then
-      throwError "invalid 'protected' constructor in a 'private' inductive datatype"
-    checkValidCtorModifier ctorModifiers
-    let ctorName := ctor.getIdAt 3
-    let ctorName := declName ++ ctorName
-    let ctorName ← withRef ctor[3] <| applyVisibility ctorModifiers.visibility ctorName
-    let (binders, type?) := expandOptDeclSig ctor[4]
-    addDocString' ctorName ctorModifiers.docString?
-    addAuxDeclarationRanges ctorName ctor ctor[3]
-    return { ref := ctor, modifiers := ctorModifiers, declName := ctorName, binders := binders, type? := type? : CtorView }
-  let computedFields ← (decl[5].getOptional?.map (·[1].getArgs) |>.getD #[]).mapM fun cf => withRef cf do
-    return { ref := cf, modifiers := cf[0], fieldId := cf[1].getId, type := ⟨cf[3]⟩, matchAlts := ⟨cf[4]⟩ }
-  let classes ← liftCoreM <| getOptDerivingClasses decl[6]
-  if decl[3][0].isToken ":=" then
-    -- https://github.com/leanprover/lean4/issues/5236
-    withRef decl[0] <| Linter.logLintIf Linter.linter.deprecated decl[3]
-      "'inductive ... :=' has been deprecated in favor of 'inductive ... where'."
-  return {
-    ref             := decl
-    shortDeclName   := name
-    derivingClasses := classes
-    declId, modifiers, declName, levelNames
-    binders, type?, ctors
-    computedFields
-  }
-
-private def classInductiveSyntaxToView (modifiers : Modifiers) (decl : Syntax) : CommandElabM InductiveView :=
-  inductiveSyntaxToView modifiers decl
-
-def elabInductive (modifiers : Modifiers) (stx : Syntax) : CommandElabM Unit := do
-  let v ← inductiveSyntaxToView modifiers stx
-  elabInductiveViews #[v]
-
-def elabClassInductive (modifiers : Modifiers) (stx : Syntax) : CommandElabM Unit := do
-  let modifiers := modifiers.addAttr { name := `class }
-  let v ← classInductiveSyntaxToView modifiers stx
-  elabInductiveViews #[v]
-
 /--
 Macro that expands a declaration with a complex name into an explicit `namespace` block.
 Implementing this step as a macro means that reuse checking is handled by `elabCommand`.
@@ -214,34 +159,22 @@ def elabDeclaration : CommandElab := fun stx => do
     -- only case implementing incrementality currently
     elabMutualDef #[stx]
   else withoutCommandIncrementality true do
+    let modifiers : TSyntax ``Parser.Command.declModifiers := ⟨stx[0]⟩
     if declKind == ``Lean.Parser.Command.«axiom» then
-      let modifiers ← elabModifiers stx[0]
+      let modifiers ← elabModifiers modifiers
       elabAxiom modifiers decl
     else if declKind == ``Lean.Parser.Command.«inductive» then
-      let modifiers ← elabModifiers stx[0]
+      let modifiers ← elabModifiers modifiers
       elabInductive modifiers decl
     else if declKind == ``Lean.Parser.Command.classInductive then
-      let modifiers ← elabModifiers stx[0]
+      let modifiers ← elabModifiers modifiers
       elabClassInductive modifiers decl
     else if declKind == ``Lean.Parser.Command.«structure» then
-      let modifiers ← elabModifiers stx[0]
+      let modifiers ← elabModifiers modifiers
       elabStructure modifiers decl
     else
       throwError "unexpected declaration"
 
-/-- Return true if all elements of the mutual-block are inductive declarations. -/
-private def isMutualInductive (stx : Syntax) : Bool :=
-  stx[1].getArgs.all fun elem =>
-    let decl     := elem[1]
-    let declKind := decl.getKind
-    declKind == `Lean.Parser.Command.inductive
-
-private def elabMutualInductive (elems : Array Syntax) : CommandElabM Unit := do
-  let views ← elems.mapM fun stx => do
-     let modifiers ← elabModifiers stx[0]
-     inductiveSyntaxToView modifiers stx[1]
-  elabInductiveViews views
-
 /-- Return true if all elements of the mutual-block are definitions/theorems/abbrevs. -/
 private def isMutualDef (stx : Syntax) : Bool :=
   stx[1].getArgs.all fun elem =>
@@ -399,7 +332,7 @@ def elabMutual : CommandElab := fun stx => do
       -- We need to add `id`'s ranges *before* elaborating `initFn` (and then `id` itself) as
       -- otherwise the info context created by `with_decl_name` will be incomplete and break the
       -- call hierarchy
-      addDeclarationRanges fullId defStx
+      addDeclarationRangesForBuiltin fullId ⟨defStx.raw[0]⟩ defStx.raw[1]
       elabCommand (← `(
         $[unsafe%$unsafe?]? def initFn : IO $type := with_decl_name% $(mkIdent fullId) do $doSeq
         $defStx:command))

src/Lean/Elab/DeclarationRange.lean

@@ -11,12 +11,14 @@ import Lean.Data.Lsp.Utf16
 
 namespace Lean.Elab
 
-def getDeclarationRange [Monad m] [MonadFileMap m] (stx : Syntax) : m DeclarationRange := do
+def getDeclarationRange? [Monad m] [MonadFileMap m] (stx : Syntax) : m (Option DeclarationRange) := do
+  let some range := stx.getRange?
+    | return none
   let fileMap ← getFileMap
-  let pos    := stx.getPos?.getD 0
-  let endPos := stx.getTailPos?.getD pos |> fileMap.toPosition
-  let pos    := pos |> fileMap.toPosition
-  return {
+  --let range := fileMap.utf8RangeToLspRange
+  let pos    := fileMap.toPosition range.start
+  let endPos := fileMap.toPosition range.stop
+  return some {
     pos          := pos
     charUtf16    := fileMap.leanPosToLspPos pos |>.character
     endPos       := endPos
@@ -47,25 +49,31 @@ def getDeclarationSelectionRef (stx : Syntax) : Syntax :=
     else
       stx[0]
 
+/--
+Derives and adds declaration ranges from given syntax trees. If `rangeStx` does not have a range,
+nothing is added. If `selectionRangeStx` does not have a range, it is defaulted to that of
+`rangeStx`.
+-/
+def addDeclarationRangesFromSyntax [Monad m] [MonadEnv m] [MonadFileMap m] (declName : Name)
+    (rangeStx : Syntax) (selectionRangeStx : Syntax := .missing) : m Unit := do
+  -- may fail on partial syntax, ignore in that case
+  let some range ← getDeclarationRange? rangeStx | return
+  let selectionRange ← (·.getD range) <$> getDeclarationRange? selectionRangeStx
+  Lean.addDeclarationRanges declName { range, selectionRange }
 
 /--
-  Store the `range` and `selectionRange` for `declName` where `stx` is the whole syntax object describing `declName`.
-  This method is for the builtin declarations only.
-  User-defined commands should use `Lean.addDeclarationRanges` to store this information for their commands. -/
-def addDeclarationRanges [Monad m] [MonadEnv m] [MonadFileMap m] (declName : Name) (stx : Syntax) : m Unit := do
-  if stx.getKind == ``Parser.Command.«example» then
-    return ()
-  else
-    Lean.addDeclarationRanges declName {
-      range          := (← getDeclarationRange stx)
-      selectionRange := (← getDeclarationRange (getDeclarationSelectionRef stx))
-    }
+Stores the `range` and `selectionRange` for `declName` where `modsStx` is the modifier part and
+`cmdStx` the remaining part of the syntax tree for `declName`.
 
-/-- Auxiliary method for recording ranges for auxiliary declarations (e.g., fields, nested declarations, etc. -/
-def addAuxDeclarationRanges [Monad m] [MonadEnv m] [MonadFileMap m] (declName : Name) (stx : Syntax) (header : Syntax) : m Unit := do
-  Lean.addDeclarationRanges declName {
-    range          := (← getDeclarationRange stx)
-    selectionRange := (← getDeclarationRange header)
-  }
+This method is for the builtin declarations only. User-defined commands should use
+`Lean.Elab.addDeclarationRangesFromSyntax` or `Lean.addDeclarationRanges` to store this information
+for their commands.
+-/
+def addDeclarationRangesForBuiltin [Monad m] [MonadEnv m] [MonadFileMap m] (declName : Name)
+    (modsStx : TSyntax ``Parser.Command.declModifiers) (declStx : Syntax) : m Unit := do
+  if declStx.getKind == ``Parser.Command.«example» then
+    return ()
+  let stx := mkNullNode #[modsStx, declStx]
+  addDeclarationRangesFromSyntax declName stx (getDeclarationSelectionRef declStx)
 
 end Lean.Elab

src/Lean/Elab/Deriving/TypeName.lean

@@ -14,7 +14,7 @@ private def deriveTypeNameInstance (declNames : Array Name) : CommandElabM Bool
   for declName in declNames do
     let cinfo ← getConstInfo declName
     unless cinfo.levelParams.isEmpty do
-      throwError m!"{mkConst declName} has universe level parameters"
+      throwError m!"{.ofConstName declName} has universe level parameters"
     elabCommand <| ← withFreshMacroScope `(
       unsafe def instImpl : TypeName @$(mkCIdent declName) := .mk _ $(quote declName)
       @[implemented_by instImpl] opaque inst : TypeName @$(mkCIdent declName)

src/Lean/Elab/Frontend.lean

@@ -102,7 +102,7 @@ partial def IO.processCommandsIncrementally (inputCtx : Parser.InputContext)
 where
   go initialSnap t commands :=
     let snap := t.get
-    let commands := commands.push snap.data.stx
+    let commands := commands.push snap.data
     if let some next := snap.nextCmdSnap? then
       go initialSnap next.task commands
     else
@@ -111,13 +111,15 @@ where
       let messages := toSnapshotTree initialSnap
         |>.getAll.map (·.diagnostics.msgLog)
         |>.foldl (· ++ ·) {}
-      let trees := toSnapshotTree initialSnap
-        |>.getAll.map (·.infoTree?) |>.filterMap id |>.toPArray'
+      -- In contrast to messages, we should collect info trees only from the top-level command
+      -- snapshots as they subsume any info trees reported incrementally by their children.
+      let trees := commands.map (·.finishedSnap.get.infoTree?) |>.filterMap id |>.toPArray'
       return {
         commandState := { snap.data.finishedSnap.get.cmdState with messages, infoState.trees := trees }
         parserState := snap.data.parserState
         cmdPos := snap.data.parserState.pos
-        inputCtx, initialSnap, commands
+        commands := commands.map (·.stx)
+        inputCtx, initialSnap
       }
 
 def IO.processCommands (inputCtx : Parser.InputContext) (parserState : Parser.ModuleParserState)
@@ -143,7 +145,7 @@ def runFrontend
     : IO (Environment × Bool) := do
   let startTime := (← IO.monoNanosNow).toFloat / 1000000000
   let inputCtx := Parser.mkInputContext input fileName
-  let opts := Language.Lean.internal.cmdlineSnapshots.set opts true
+  let opts := Language.Lean.internal.cmdlineSnapshots.setIfNotSet opts true
   let ctx := { inputCtx with }
   let processor := Language.Lean.process
   let snap ← processor (fun _ => pure <| .ok { mainModuleName, opts, trustLevel }) none ctx

src/Lean/Elab/Inductive.lean

@@ -18,6 +18,7 @@ import Lean.Elab.ComputedFields
 import Lean.Elab.DefView
 import Lean.Elab.DeclUtil
 import Lean.Elab.Deriving.Basic
+import Lean.Elab.DeclarationRange
 
 namespace Lean.Elab.Command
 open Meta
@@ -79,10 +80,56 @@ structure ElabHeaderResult where
   view       : InductiveView
   lctx       : LocalContext
   localInsts : LocalInstances
+  levelNames : List Name
   params     : Array Expr
   type       : Expr
   deriving Inhabited
 
+/-
+leading_parser "inductive " >> declId >> optDeclSig >> optional ("where" <|> ":=") >> many ctor
+leading_parser atomic (group ("class " >> "inductive ")) >> declId >> optDeclSig >> optional ("where" <|> ":=") >> many ctor >> optDeriving
+-/
+private def inductiveSyntaxToView (modifiers : Modifiers) (decl : Syntax) : TermElabM InductiveView := do
+  checkValidInductiveModifier modifiers
+  let (binders, type?) := expandOptDeclSig decl[2]
+  let declId           := decl[1]
+  let ⟨name, declName, levelNames⟩ ← Term.expandDeclId (← getCurrNamespace) (← Term.getLevelNames) declId modifiers
+  addDeclarationRangesForBuiltin declName modifiers.stx decl
+  let ctors      ← decl[4].getArgs.mapM fun ctor => withRef ctor do
+    -- def ctor := leading_parser optional docComment >> "\n| " >> declModifiers >> rawIdent >> optDeclSig
+    let mut ctorModifiers ← elabModifiers ⟨ctor[2]⟩
+    if let some leadingDocComment := ctor[0].getOptional? then
+      if ctorModifiers.docString?.isSome then
+        logErrorAt leadingDocComment "duplicate doc string"
+      ctorModifiers := { ctorModifiers with docString? := TSyntax.getDocString ⟨leadingDocComment⟩ }
+    if ctorModifiers.isPrivate && modifiers.isPrivate then
+      throwError "invalid 'private' constructor in a 'private' inductive datatype"
+    if ctorModifiers.isProtected && modifiers.isPrivate then
+      throwError "invalid 'protected' constructor in a 'private' inductive datatype"
+    checkValidCtorModifier ctorModifiers
+    let ctorName := ctor.getIdAt 3
+    let ctorName := declName ++ ctorName
+    let ctorName ← withRef ctor[3] <| applyVisibility ctorModifiers.visibility ctorName
+    let (binders, type?) := expandOptDeclSig ctor[4]
+    addDocString' ctorName ctorModifiers.docString?
+    addDeclarationRangesFromSyntax ctorName ctor ctor[3]
+    return { ref := ctor, modifiers := ctorModifiers, declName := ctorName, binders := binders, type? := type? : CtorView }
+  let computedFields ← (decl[5].getOptional?.map (·[1].getArgs) |>.getD #[]).mapM fun cf => withRef cf do
+    return { ref := cf, modifiers := cf[0], fieldId := cf[1].getId, type := ⟨cf[3]⟩, matchAlts := ⟨cf[4]⟩ }
+  let classes ← getOptDerivingClasses decl[6]
+  if decl[3][0].isToken ":=" then
+    -- https://github.com/leanprover/lean4/issues/5236
+    withRef decl[0] <| Linter.logLintIf Linter.linter.deprecated decl[3]
+      "'inductive ... :=' has been deprecated in favor of 'inductive ... where'."
+  return {
+    ref             := decl
+    shortDeclName   := name
+    derivingClasses := classes
+    declId, modifiers, declName, levelNames
+    binders, type?, ctors
+    computedFields
+  }
+
 private partial def elabHeaderAux (views : Array InductiveView) (i : Nat) (acc : Array ElabHeaderResult) : TermElabM (Array ElabHeaderResult) :=
   Term.withAutoBoundImplicitForbiddenPred (fun n => views.any (·.shortDeclName == n)) do
     if h : i < views.size then
@@ -94,7 +141,8 @@ private partial def elabHeaderAux (views : Array InductiveView) (i : Nat) (acc :
           let type := mkSort u
           Term.synthesizeSyntheticMVarsNoPostponing
           Term.addAutoBoundImplicits' params type fun params type => do
-            return acc.push { lctx := (← getLCtx), localInsts := (← getLocalInstances), params, type, view }
+            let levelNames ← Term.getLevelNames
+            return acc.push { lctx := (← getLCtx), localInsts := (← getLocalInstances), levelNames, params, type, view }
         | some typeStx =>
           let (type, _) ← Term.withAutoBoundImplicit do
             let type ← Term.elabType typeStx
@@ -105,7 +153,8 @@ private partial def elabHeaderAux (views : Array InductiveView) (i : Nat) (acc :
             return (← mkForallFVars indices type, indices.size)
           Term.addAutoBoundImplicits' params type fun params type => do
             trace[Elab.inductive] "header params: {params}, type: {type}"
-            return acc.push { lctx := (← getLCtx), localInsts := (← getLocalInstances), params, type, view }
+            let levelNames ← Term.getLevelNames
+            return acc.push { lctx := (← getLCtx), localInsts := (← getLocalInstances), levelNames, params, type, view }
       elabHeaderAux views (i+1) acc
     else
       return acc
@@ -123,13 +172,20 @@ private def checkUnsafe (rs : Array ElabHeaderResult) : TermElabM Unit := do
     unless r.view.modifiers.isUnsafe == isUnsafe do
       throwErrorAt r.view.ref "invalid inductive type, cannot mix unsafe and safe declarations in a mutually inductive datatypes"
 
-private def checkLevelNames (views : Array InductiveView) : TermElabM Unit := do
+private def InductiveView.checkLevelNames (views : Array InductiveView) : TermElabM Unit := do
   if views.size > 1 then
     let levelNames := views[0]!.levelNames
     for view in views do
       unless view.levelNames == levelNames do
         throwErrorAt view.ref "invalid inductive type, universe parameters mismatch in mutually inductive datatypes"
 
+private def ElabHeaderResult.checkLevelNames (rs : Array ElabHeaderResult) : TermElabM Unit := do
+  if rs.size > 1 then
+    let levelNames := rs[0]!.levelNames
+    for r in rs do
+      unless r.levelNames == levelNames do
+        throwErrorAt r.view.ref "invalid inductive type, universe parameters mismatch in mutually inductive datatypes"
+
 private def mkTypeFor (r : ElabHeaderResult) : TermElabM Expr := do
   withLCtx r.lctx r.localInsts do
     mkForallFVars r.params r.type
@@ -791,12 +847,15 @@ private partial def fixedIndicesToParams (numParams : Nat) (indTypes : Array Ind
 private def mkInductiveDecl (vars : Array Expr) (views : Array InductiveView) : TermElabM Unit := Term.withoutSavingRecAppSyntax do
   let view0 := views[0]!
   let scopeLevelNames ← Term.getLevelNames
-  checkLevelNames views
+  InductiveView.checkLevelNames views
   let allUserLevelNames := view0.levelNames
   let isUnsafe          := view0.modifiers.isUnsafe
   withRef view0.ref <| Term.withLevelNames allUserLevelNames do
     let rs ← elabHeader views
     Term.synthesizeSyntheticMVarsNoPostponing
+    ElabHeaderResult.checkLevelNames rs
+    let allUserLevelNames := rs[0]!.levelNames
+    trace[Elab.inductive] "level names: {allUserLevelNames}"
     withInductiveLocalDecls rs fun params indFVars => do
       trace[Elab.inductive] "indFVars: {indFVars}"
       let mut indTypesArray := #[]
@@ -888,19 +947,55 @@ private def applyComputedFields (indViews : Array InductiveView) : CommandElabM
   liftTermElabM do Term.withDeclName indViews[0]!.declName do
     ComputedFields.setComputedFields computedFields
 
-def elabInductiveViews (views : Array InductiveView) : CommandElabM Unit := do
+def elabInductiveViews (vars : Array Expr) (views : Array InductiveView) : TermElabM Unit := do
   let view0 := views[0]!
   let ref := view0.ref
-  runTermElabM fun vars => Term.withDeclName view0.declName do withRef ref do
+  Term.withDeclName view0.declName do withRef ref do
     mkInductiveDecl vars views
     mkSizeOfInstances view0.declName
     Lean.Meta.IndPredBelow.mkBelow view0.declName
     for view in views do
       mkInjectiveTheorems view.declName
+
+def elabInductiveViewsPostprocessing (views : Array InductiveView) : CommandElabM Unit := do
+  let view0 := views[0]!
+  let ref := view0.ref
   applyComputedFields views -- NOTE: any generated code before this line is invalid
   applyDerivingHandlers views
   runTermElabM fun _ => Term.withDeclName view0.declName do withRef ref do
     for view in views do
       Term.applyAttributesAt view.declName view.modifiers.attrs .afterCompilation
 
+def elabInductives (inductives : Array (Modifiers × Syntax)) : CommandElabM Unit := do
+  let vs ← runTermElabM fun vars => do
+    let vs ← inductives.mapM fun (modifiers, stx) => inductiveSyntaxToView modifiers stx
+    elabInductiveViews vars vs
+    pure vs
+  elabInductiveViewsPostprocessing vs
+
+def elabInductive (modifiers : Modifiers) (stx : Syntax) : CommandElabM Unit := do
+  elabInductives #[(modifiers, stx)]
+
+def elabClassInductive (modifiers : Modifiers) (stx : Syntax) : CommandElabM Unit := do
+  let modifiers := modifiers.addAttr { name := `class }
+  elabInductive modifiers stx
+
+/--
+Returns true if all elements of the `mutual` block (`Lean.Parser.Command.mutual`) are inductive declarations.
+-/
+def isMutualInductive (stx : Syntax) : Bool :=
+  stx[1].getArgs.all fun elem =>
+    let decl     := elem[1]
+    let declKind := decl.getKind
+    declKind == `Lean.Parser.Command.inductive
+
+/--
+Elaborates a `mutual` block satisfying `Lean.Elab.Command.isMutualInductive`.
+-/
+def elabMutualInductive (elems : Array Syntax) : CommandElabM Unit := do
+  let inductives ← elems.mapM fun stx => do
+    let modifiers ← elabModifiers ⟨stx[0]⟩
+    pure (modifiers, stx[1])
+  elabInductives inductives
+
 end Lean.Elab.Command

src/Lean/Elab/LetRec.lean

@@ -51,7 +51,7 @@ private def mkLetRecDeclView (letRec : Syntax) : TermElabM LetRecView := do
       checkNotAlreadyDeclared declName
       applyAttributesAt declName attrs AttributeApplicationTime.beforeElaboration
       addDocString' declName docStr?
-      addAuxDeclarationRanges declName decl declId
+      addDeclarationRangesFromSyntax declName decl declId
       let binders := decl[1].getArgs
       let typeStx := expandOptType declId decl[2]
       let (type, binderIds) ← elabBindersEx binders fun xs => do

src/Lean/Elab/MutualDef.lean

@@ -997,7 +997,7 @@ where
       for view in views, header in headers do
         -- NOTE: this should be the full `ref`, and thus needs to be done after any snapshotting
         -- that depends only on a part of the ref
-        addDeclarationRanges header.declName view.ref
+        addDeclarationRangesForBuiltin header.declName view.modifiers.stx view.ref
 
 
   processDeriving (headers : Array DefViewElabHeader) := do
@@ -1021,7 +1021,7 @@ def elabMutualDef (ds : Array Syntax) : CommandElabM Unit := do
     let mut reusedAllHeaders := true
     for h : i in [0:ds.size], headerPromise in headerPromises do
       let d := ds[i]
-      let modifiers ← elabModifiers d[0]
+      let modifiers ← elabModifiers ⟨d[0]⟩
       if ds.size > 1 && modifiers.isNonrec then
         throwErrorAt d "invalid use of 'nonrec' modifier in 'mutual' block"
       let mut view ← mkDefView modifiers d[1]

src/Lean/Elab/ParseImportsFast.lean

@@ -182,7 +182,7 @@ partial def moduleIdent (runtimeOnly : Bool) : Parser := fun input s =>
   let s := p input s
   match s.error? with
   | none => many p input s
-  | some _ => { pos, error? := none, imports := s.imports.shrink size }
+  | some _ => { pos, error? := none, imports := s.imports.take size }
 
 @[inline] partial def preludeOpt (k : String) : Parser :=
   keywordCore k (fun _ s => s.pushModule `Init false) (fun _ s => s)

src/Lean/Elab/PreDefinition/Basic.lean

@@ -125,7 +125,7 @@ private def reportTheoremDiag (d : TheoremVal) : TermElabM Unit := do
     if proofSize > diagnostics.threshold.proofSize.get (← getOptions) then
       let sizeMsg := MessageData.trace { cls := `size } m!"{proofSize}" #[]
       let constOccs ← d.value.numApps (threshold := diagnostics.threshold.get (← getOptions))
-      let constOccsMsg ← constOccs.mapM fun (declName, numOccs) => return MessageData.trace { cls := `occs } m!"{MessageData.ofConst (← mkConstWithLevelParams declName)} ↦ {numOccs}" #[]
+      let constOccsMsg ← constOccs.mapM fun (declName, numOccs) => return MessageData.trace { cls := `occs } m!"{.ofConstName declName} ↦ {numOccs}" #[]
       -- let info
       logInfo <| MessageData.trace { cls := `theorem } m!"{d.name}" (#[sizeMsg] ++ constOccsMsg)
 
@@ -221,7 +221,7 @@ def addAndCompilePartialRec (preDefs : Array PreDefinition) : TermElabM Unit :=
               else
                 none
             | _ => none
-          modifiers := {} }
+          modifiers := default }
 
 private def containsRecFn (recFnNames : Array Name) (e : Expr) : Bool :=
   (e.find? fun e => e.isConst && recFnNames.contains e.constName!).isSome

src/Lean/Elab/PreDefinition/MkInhabitant.lean

@@ -5,9 +5,24 @@ Authors: Leonardo de Moura
 -/
 prelude
 import Lean.Meta.AppBuilder
+import Lean.PrettyPrinter
 namespace Lean.Elab
 open Meta
 
+private def withInhabitedInstances (xs : Array Expr) (k : Array Expr → MetaM α) : MetaM α := do
+  let rec go (i : Nat) (insts : Array Expr) : MetaM α := do
+    if h : i < xs.size then
+      let x := xs[i]
+      let xTy ← inferType x
+      let u ← getLevel xTy
+      let instTy := mkApp (.const ``Inhabited [u]) xTy
+      let instVal := mkApp2 (.const ``Inhabited.mk [u]) xTy x
+      withLetDecl `inst instTy instVal fun inst =>
+        go (i + 1) (insts.push inst)
+    else
+      k insts
+  go 0 #[]
+
 private def mkInhabitant? (type : Expr) (useOfNonempty : Bool) : MetaM (Option Expr) := do
   try
     if useOfNonempty then
@@ -17,36 +32,41 @@ private def mkInhabitant? (type : Expr) (useOfNonempty : Bool) : MetaM (Option E
   catch _ =>
     return none
 
-private def findAssumption? (xs : Array Expr) (type : Expr) : MetaM (Option Expr) := do
-  xs.findM? fun x => do isDefEq (← inferType x) type
-
-private def mkFnInhabitant? (xs : Array Expr) (type : Expr) (useOfNonempty : Bool) : MetaM (Option Expr) :=
-  let rec loop
-    | 0,   type => mkInhabitant? type useOfNonempty
-    | i+1, type => do
-      let x := xs[i]!
-      let type ← mkForallFVars #[x] type;
-      match (← mkInhabitant? type useOfNonempty) with
-      | none     => loop i type
-      | some val => return some (← mkLambdaFVars xs[0:i] val)
-  loop xs.size type
+/--
+Find an inhabitant while doing delta unfolding.
+-/
+private partial def mkInhabitantForAux? (xs insts : Array Expr) (type : Expr) (useOfNonempty : Bool) : MetaM (Option Expr) := withIncRecDepth do
+  if let some val ← mkInhabitant? type useOfNonempty then
+    mkLambdaFVars xs (← mkLetFVars (usedLetOnly := true) insts val)
+  else
+    let type ← whnfCore type
+    if type.isForall then
+      forallTelescope type fun xs' type' =>
+        withInhabitedInstances xs' fun insts' =>
+          mkInhabitantForAux? (xs ++ xs') (insts ++ insts') type' useOfNonempty
+    else if let some type' ← unfoldDefinition? type then
+      mkInhabitantForAux? xs insts type' useOfNonempty
+    else
+      return none
 
 /- TODO: add a global IO.Ref to let users customize/extend this procedure -/
-def mkInhabitantFor (declName : Name) (xs : Array Expr) (type : Expr) : MetaM Expr := do
-  let go? (useOfNonempty : Bool) : MetaM (Option Expr) := do
-    match (← mkInhabitant? type useOfNonempty) with
-    | some val => mkLambdaFVars xs val
-    | none     =>
-    match (← findAssumption? xs type) with
-    | some x => mkLambdaFVars xs x
-    | none   =>
-    match (← mkFnInhabitant? xs type useOfNonempty) with
-    | some val => return val
-    | none     => return none
-  match (← go? false) with
-  | some val => return val
-  | none     => match (← go? true) with
-    | some val => return val
-    | none     => throwError "failed to compile partial definition '{declName}', failed to show that type is inhabited and non empty"
+def mkInhabitantFor (declName : Name) (xs : Array Expr) (type : Expr) : MetaM Expr :=
+  withInhabitedInstances xs fun insts => do
+    if let some val ← mkInhabitantForAux? xs insts type false <||> mkInhabitantForAux? xs insts type true then
+      return val
+    else
+      throwError "\
+        failed to compile 'partial' definition '{declName}', could not prove that the type\
+        {indentExpr (← mkForallFVars xs type)}\n\
+        is nonempty.\n\
+        \n\
+        This process uses multiple strategies:\n\
+        - It looks for a parameter that matches the return type.\n\
+        - It tries synthesizing '{.ofConstName ``Inhabited}' and '{.ofConstName ``Nonempty}' \
+          instances for the return type, while making every parameter into a local '{.ofConstName ``Inhabited}' instance.\n\
+        - It tries unfolding the return type.\n\
+        \n\
+        If the return type is defined using the 'structure' or 'inductive' command, \
+        you can try adding a 'deriving Nonempty' clause to it."
 
 end Lean.Elab

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

@@ -114,8 +114,9 @@ private def withBelowDict [Inhabited α] (below : Expr) (numIndParams : Nat)
   The dictionary is built using the `PProd` (`And` for inductive predicates).
   We keep searching it until we find `C recArg`, where `C` is the auxiliary fresh variable created at `withBelowDict`.  -/
 private partial def toBelow (below : Expr) (numIndParams : Nat) (positions : Positions) (fnIndex : Nat) (recArg : Expr) : MetaM Expr := do
-  withBelowDict below numIndParams positions fun Cs belowDict =>
-    toBelowAux Cs[fnIndex]! belowDict recArg below
+  withTraceNode `Elab.definition.structural (return m!"{exceptEmoji ·} searching IH for {recArg} in {←inferType below}") do
+    withBelowDict below numIndParams positions fun Cs belowDict =>
+      toBelowAux Cs[fnIndex]! belowDict recArg below
 
 private partial def replaceRecApps (recArgInfos : Array RecArgInfo) (positions : Positions)
     (below : Expr) (e : Expr) : M Expr :=
@@ -212,21 +213,21 @@ def mkBRecOnMotive (recArgInfo : RecArgInfo) (value : Expr) : M Expr := do
 /--
 Calculates the `.brecOn` functional argument corresponding to one structural recursive function.
 The `value` is the function with (only) the fixed parameters moved into the context,
-The `type` is the expected type of the argument.
+The `FType` is the expected type of the argument.
 The `recArgInfos` is used to transform the body of the function to replace recursive calls with
 uses of the `below` induction hypothesis.
 -/
 def mkBRecOnF (recArgInfos : Array RecArgInfo) (positions : Positions)
     (recArgInfo : RecArgInfo) (value : Expr) (FType : Expr) : M Expr := do
   lambdaTelescope value fun xs value => do
-    let (indexMajorArgs, otherArgs) := recArgInfo.pickIndicesMajor xs
-    let FType ← instantiateForall FType indexMajorArgs
+    let (indicesMajorArgs, otherArgs) := recArgInfo.pickIndicesMajor xs
+    let FType ← instantiateForall FType indicesMajorArgs
     forallBoundedTelescope FType (some 1) fun below _ => do
       -- TODO: `below` user name is `f`, and it will make a global `f` to be pretty printed as `_root_.f` in error messages.
       -- We should add an option to `forallBoundedTelescope` to ensure fresh names are used.
       let below := below[0]!
-      let valueNew   ← replaceRecApps recArgInfos positions below value
-      mkLambdaFVars (indexMajorArgs ++ #[below] ++ otherArgs) valueNew
+      let valueNew ← replaceRecApps recArgInfos positions below value
+      mkLambdaFVars (indicesMajorArgs ++ #[below] ++ otherArgs) valueNew
 
 /--
 Given the `motives`, figures out whether to use `.brecOn` or `.binductionOn`, pass
@@ -264,7 +265,7 @@ def inferBRecOnFTypes (recArgInfos : Array RecArgInfo) (positions : Positions)
     (brecOnConst : Nat → Expr) : MetaM (Array Expr) := do
   let numTypeFormers := positions.size
   let recArgInfo := recArgInfos[0]! -- pick an arbitrary one
-  let brecOn := brecOnConst 0
+  let brecOn := brecOnConst recArgInfo.indIdx
   check brecOn
   let brecOnType ← inferType brecOn
   -- Skip the indices and major argument

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

@@ -77,7 +77,7 @@ def getRecArgInfo (fnName : Name) (numFixed : Nat) (xs : Array Expr) (i : Nat) :
       if !indIndices.all Expr.isFVar then
         throwError "its type {indInfo.name} is an inductive family and indices are not variables{indentExpr xType}"
       else if !indIndices.allDiff then
-        throwError " its type {indInfo.name} is an inductive family and indices are not pairwise distinct{indentExpr xType}"
+        throwError "its type {indInfo.name} is an inductive family and indices are not pairwise distinct{indentExpr xType}"
       else
         let indexMinPos := getIndexMinPos xs indIndices
         let numFixed    := if indexMinPos < numFixed then indexMinPos else numFixed

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

@@ -107,9 +107,9 @@ private def elimMutualRecursion (preDefs : Array PreDefinition) (xs : Array Expr
     check valueNew
     return #[{ preDef with value := valueNew }]
 
-  -- Sort the (indices of the) definitions by their position in indInfo.all
+  -- Groups the (indices of the) definitions by their position in indInfo.all
   let positions : Positions := .groupAndSort (·.indIdx) recArgInfos (Array.range indInfo.numTypeFormers)
-  trace[Elab.definition.structural] "positions: {positions}"
+  trace[Elab.definition.structural] "assignments of type formers of {indInfo.name} to functions: {positions}"
 
   -- Construct the common `.brecOn` arguments
   let motives ← (Array.zip recArgInfos values).mapM fun (r, v) => mkBRecOnMotive r v
@@ -117,7 +117,7 @@ private def elimMutualRecursion (preDefs : Array PreDefinition) (xs : Array Expr
   let brecOnConst ← mkBRecOnConst recArgInfos positions motives
   let FTypes ← inferBRecOnFTypes recArgInfos positions brecOnConst
   trace[Elab.definition.structural] "FTypes: {FTypes}"
-  let FArgs ← (recArgInfos.zip  (values.zip FTypes)).mapM fun (r, (v, t)) =>
+  let FArgs ← (recArgInfos.zip (values.zip FTypes)).mapM fun (r, (v, t)) =>
     mkBRecOnF recArgInfos positions r v t
   trace[Elab.definition.structural] "FArgs: {FArgs}"
   -- Assemble the individual `.brecOn` applications

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

@@ -15,7 +15,7 @@ partial def addSmartUnfoldingDefAux (preDef : PreDefinition) (recArgPos : Nat) :
   return { preDef with
     declName  := mkSmartUnfoldingNameFor preDef.declName
     value     := (← visit preDef.value)
-    modifiers := {}
+    modifiers := default
   }
 where
   /--

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

@@ -4,18 +4,15 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Leonardo de Moura
 -/
 prelude
-import Lean.Util.HasConstCache
-import Lean.Meta.Match.Match
-import Lean.Meta.Tactic.Simp.Main
-import Lean.Meta.Tactic.Cleanup
-import Lean.Meta.ArgsPacker
-import Lean.Elab.Tactic.Basic
-import Lean.Elab.RecAppSyntax
-import Lean.Elab.PreDefinition.Basic
-import Lean.Elab.PreDefinition.Structural.Basic
-import Lean.Elab.PreDefinition.Structural.BRecOn
-import Lean.Elab.PreDefinition.WF.Basic
 import Lean.Data.Array
+import Lean.Elab.PreDefinition.Basic
+import Lean.Elab.PreDefinition.WF.Basic
+import Lean.Elab.Tactic.Basic
+import Lean.Meta.ArgsPacker
+import Lean.Meta.ForEachExpr
+import Lean.Meta.Match.MatcherApp.Transform
+import Lean.Meta.Tactic.Cleanup
+import Lean.Util.HasConstCache
 
 namespace Lean.Elab.WF
 open Meta

src/Lean/Elab/Print.lean

@@ -11,7 +11,7 @@ import Lean.Elab.Command
 namespace Lean.Elab.Command
 
 private def throwUnknownId (id : Name) : CommandElabM Unit :=
-  throwError "unknown identifier '{mkConst id}'"
+  throwError "unknown identifier '{.ofConstName id}'"
 
 private def levelParamsToMessageData (levelParams : List Name) : MessageData :=
   match levelParams with

src/Lean/Elab/StructInst.lean

@@ -434,7 +434,7 @@ private def expandParentFields (s : Struct) : TermElabM Struct := do
     | { lhs := .fieldName ref fieldName :: _,    .. } =>
       addCompletionInfo <| CompletionInfo.fieldId ref fieldName (← getLCtx) s.structName
       match findField? env s.structName fieldName with
-      | none => throwErrorAt ref "'{fieldName}' is not a field of structure '{MessageData.ofConstName s.structName}'"
+      | none => throwErrorAt ref "'{fieldName}' is not a field of structure '{.ofConstName s.structName}'"
       | some baseStructName =>
         if baseStructName == s.structName then pure field
         else match getPathToBaseStructure? env baseStructName s.structName with
@@ -826,9 +826,12 @@ def mkDefaultValue? (struct : Struct) (cinfo : ConstantInfo) : TermElabM (Option
 /-- Reduce default value. It performs beta reduction and projections of the given structures. -/
 partial def reduce (structNames : Array Name) (e : Expr) : MetaM Expr := do
   match e with
-  | .lam ..       => lambdaLetTelescope e fun xs b => do mkLambdaFVars xs (← reduce structNames b)
-  | .forallE ..   => forallTelescope e fun xs b => do mkForallFVars xs (← reduce structNames b)
-  | .letE ..      => lambdaLetTelescope e fun xs b => do mkLetFVars xs (← reduce structNames b)
+  | .forallE ..   =>
+    forallTelescope e fun xs b => withReduceLCtx xs do
+      mkForallFVars xs (← reduce structNames b)
+  | .lam .. | .letE .. =>
+    lambdaLetTelescope e fun xs b => withReduceLCtx xs do
+      mkLambdaFVars (usedLetOnly := true) xs (← reduce structNames b)
   | .proj _ i b   =>
     match (← Meta.project? b i) with
     | some r => reduce structNames r
@@ -858,6 +861,24 @@ partial def reduce (structNames : Array Name) (e : Expr) : MetaM Expr := do
     | some val => if val.isMVar then pure val else reduce structNames val
     | none     => return e
   | e => return e
+where
+  /--
+  Reduce the types and values of the local variables `xs` in the local context.
+  -/
+  withReduceLCtx {α} (xs : Array Expr) (k : MetaM α) (i : Nat := 0) : MetaM α := do
+    if h : i < xs.size then
+      let fvarId := xs[i].fvarId!
+      let decl ← fvarId.getDecl
+      let type ← reduce structNames decl.type
+      let mut lctx ← getLCtx
+      if let some value := decl.value? then
+        let value ← reduce structNames value
+        lctx := lctx.modifyLocalDecl fvarId (· |>.setType type |>.setValue value)
+      else
+        lctx := lctx.modifyLocalDecl fvarId (· |>.setType type)
+      withLCtx lctx (← getLocalInstances) (withReduceLCtx xs k (i + 1))
+    else
+      k
 
 partial def tryToSynthesizeDefault (structs : Array Struct) (allStructNames : Array Name) (maxDistance : Nat) (fieldName : Name) (mvarId : MVarId) : TermElabM Bool :=
   let rec loop (i : Nat) (dist : Nat) := do
@@ -873,6 +894,7 @@ partial def tryToSynthesizeDefault (structs : Array Struct) (allStructNames : Ar
         | none     => setMCtx mctx; loop (i+1) (dist+1)
         | some val =>
           let val ← reduce allStructNames val
+          trace[Elab.struct] "default value for {fieldName}:{indentExpr val}"
           match val.find? fun e => (defaultMissing? e).isSome with
           | some _ => setMCtx mctx; loop (i+1) (dist+1)
           | none   =>

src/Lean/Elab/Structure.lean

@@ -20,6 +20,11 @@ import Lean.Elab.Binders
 
 namespace Lean.Elab.Command
 
+register_builtin_option structureDiamondWarning : Bool := {
+  defValue := false
+  descr    := "enable/disable warning messages for structure diamonds"
+}
+
 open Meta
 open TSyntax.Compat
 
@@ -34,53 +39,83 @@ structure StructCtorView where
   modifiers : Modifiers
   name      : Name
   declName  : Name
+  deriving Inhabited
 
 structure StructFieldView where
   ref        : Syntax
   modifiers  : Modifiers
   binderInfo : BinderInfo
   declName   : Name
-  name       : Name -- The field name as it is going to be registered in the kernel. It does not include macroscopes.
-  rawName    : Name -- Same as `name` but including macroscopes.
+  /-- Ref for the field name -/
+  nameId     : Syntax
+  /-- The name of the field. (Without macro scopes.) -/
+  name       : Name
+  /-- Same as `name` but includes macro scopes. Used for field elaboration. -/
+  rawName    : Name
   binders    : Syntax
   type?      : Option Syntax
   value?     : Option Syntax
 
 structure StructView where
-  ref               : Syntax
-  modifiers         : Modifiers
-  scopeLevelNames   : List Name  -- All `universe` declarations in the current scope
-  allUserLevelNames : List Name  -- `scopeLevelNames` ++ explicit universe parameters provided in the `structure` command
-  isClass           : Bool
-  declName          : Name
-  scopeVars         : Array Expr -- All `variable` declaration in the current scope
-  params            : Array Expr -- Explicit parameters provided in the `structure` command
-  parents           : Array Syntax
-  type              : Syntax
-  ctor              : StructCtorView
-  fields            : Array StructFieldView
+  ref             : Syntax
+  declId          : Syntax
+  modifiers       : Modifiers
+  isClass         : Bool -- struct-only
+  shortDeclName   : Name
+  declName        : Name
+  levelNames      : List Name
+  binders         : Syntax
+  type            : Syntax -- modified (inductive has type?)
+  parents         : Array Syntax -- struct-only
+  ctor            : StructCtorView -- struct-only
+  fields          : Array StructFieldView -- struct-only
+  derivingClasses : Array DerivingClassView
+  deriving Inhabited
+
+structure StructParentInfo where
+  ref        : Syntax
+  fvar?      : Option Expr
+  structName : Name
+  subobject  : Bool
+  type       : Expr
+  deriving Inhabited
 
 inductive StructFieldKind where
-  | newField | copiedField | fromParent | subobject
+  | newField | copiedField | fromParent
+  /-- The field is an embedded parent. -/
+  | subobject (structName : Name)
   deriving Inhabited, DecidableEq, Repr
 
 structure StructFieldInfo where
+  ref      : Syntax
   name     : Name
-  declName : Name -- Remark: for `fromParent` fields, `declName` is only relevant in the generation of auxiliary "default value" functions.
+  /-- Name of projection function.
+  Remark: for `fromParent` fields, `declName` is only relevant in the generation of auxiliary "default value" functions. -/
+  declName : Name
   fvar     : Expr
   kind     : StructFieldKind
   value?   : Option Expr := none
   deriving Inhabited, Repr
 
+structure ElabStructHeaderResult where
+  view             : StructView
+  lctx             : LocalContext
+  localInsts       : LocalInstances
+  levelNames       : List Name
+  params           : Array Expr
+  type             : Expr
+  parents          : Array StructParentInfo
+  /-- Field infos from parents. -/
+  parentFieldInfos : Array StructFieldInfo
+  deriving Inhabited
+
 def StructFieldInfo.isFromParent (info : StructFieldInfo) : Bool :=
   match info.kind with
   | StructFieldKind.fromParent => true
   | _                          => false
 
 def StructFieldInfo.isSubobject (info : StructFieldInfo) : Bool :=
-  match info.kind with
-  | StructFieldKind.subobject => true
-  | _                         => false
+  info.kind matches StructFieldKind.subobject ..
 
 private def defaultCtorName := `mk
 
@@ -94,8 +129,8 @@ private def expandCtor (structStx : Syntax) (structModifiers : Modifiers) (struc
   let useDefault := do
     let declName := structDeclName ++ defaultCtorName
     let ref := structStx[1].mkSynthetic
-    addAuxDeclarationRanges declName ref ref
-    pure { ref, modifiers := {}, name := defaultCtorName, declName }
+    addDeclarationRangesFromSyntax declName ref
+    pure { ref, modifiers := default, name := defaultCtorName, declName }
   if structStx[5].isNone then
     useDefault
   else
@@ -115,7 +150,7 @@ private def expandCtor (structStx : Syntax) (structModifiers : Modifiers) (struc
       let declName := structDeclName ++ name
       let declName ← applyVisibility ctorModifiers.visibility declName
       addDocString' declName ctorModifiers.docString?
-      addAuxDeclarationRanges declName ctor[1] ctor[1]
+      addDeclarationRangesFromSyntax declName ctor[1]
       pure { ref := ctor[1], name, modifiers := ctorModifiers, declName }
 
 def checkValidFieldModifier (modifiers : Modifiers) : TermElabM Unit := do
@@ -161,14 +196,15 @@ private def expandFields (structStx : Syntax) (structModifiers : Modifiers) (str
       throwError "invalid 'private' field in a 'private' structure"
     if fieldModifiers.isProtected && structModifiers.isPrivate then
       throwError "invalid 'protected' field in a 'private' structure"
-    let (binders, type?) ←
+    let (binders, type?, value?) ←
       if binfo == BinderInfo.default then
         let (binders, type?) := expandOptDeclSig fieldBinder[3]
         let optBinderTacticDefault := fieldBinder[4]
         if optBinderTacticDefault.isNone then
-          pure (binders, type?)
+          pure (binders, type?, none)
         else if optBinderTacticDefault[0].getKind != ``Parser.Term.binderTactic then
-          pure (binders, type?)
+          -- binderDefault := leading_parser " := " >> termParser
+          pure (binders, type?, some optBinderTacticDefault[0][1])
         else
           let binderTactic := optBinderTacticDefault[0]
           match type? with
@@ -180,22 +216,10 @@ private def expandFields (structStx : Syntax) (structModifiers : Modifiers) (str
             -- It is safe to reset the binders to a "null" node since there is no value to be elaborated
             let type ← `(forall $(binders.getArgs):bracketedBinder*, $type)
             let type ← `(autoParam $type $(mkIdentFrom tac name))
-            pure (mkNullNode, some type.raw)
+            pure (mkNullNode, some type.raw, none)
       else
         let (binders, type) := expandDeclSig fieldBinder[3]
-        pure (binders, some type)
-    let value? ← if binfo != BinderInfo.default then
-      pure none
-    else
-      let optBinderTacticDefault := fieldBinder[4]
-      -- trace[Elab.struct] ">>> {optBinderTacticDefault}"
-      if optBinderTacticDefault.isNone then
-        pure none
-      else if optBinderTacticDefault[0].getKind == ``Parser.Term.binderTactic then
-        pure none
-      else
-        -- binderDefault := leading_parser " := " >> termParser
-        pure (some optBinderTacticDefault[0][1])
+        pure (binders, some type, none)
     let idents := fieldBinder[2].getArgs
     idents.foldlM (init := views) fun (views : Array StructFieldView) ident => withRef ident do
       let rawName := ident.getId
@@ -211,16 +235,59 @@ private def expandFields (structStx : Syntax) (structModifiers : Modifiers) (str
         binderInfo := binfo
         declName
         name
+        nameId     := ident
         rawName
         binders
         type?
         value?
       }
 
-private def validStructType (type : Expr) : Bool :=
-  match type with
-  | Expr.sort .. => true
-  | _            => false
+/-
+leading_parser (structureTk <|> classTk) >> declId >> many Term.bracketedBinder >> optional «extends» >> Term.optType >>
+  optional (("where" <|> ":=") >> optional structCtor >> structFields) >> optDeriving
+
+where
+def «extends» := leading_parser " extends " >> sepBy1 termParser ", "
+def typeSpec := leading_parser " : " >> termParser
+def optType : Parser := optional typeSpec
+
+def structFields         := leading_parser many (structExplicitBinder <|> structImplicitBinder <|> structInstBinder)
+def structCtor           := leading_parser try (declModifiers >> ident >> " :: ")
+-/
+def structureSyntaxToView (modifiers : Modifiers) (stx : Syntax) : TermElabM StructView := do
+  checkValidInductiveModifier modifiers
+  let isClass   := stx[0].getKind == ``Parser.Command.classTk
+  let modifiers := if isClass then modifiers.addAttr { name := `class } else modifiers
+  let declId    := stx[1]
+  let ⟨name, declName, levelNames⟩ ← Term.expandDeclId (← getCurrNamespace) (← Term.getLevelNames) declId modifiers
+  addDeclarationRangesForBuiltin declName modifiers.stx stx
+  let binders   := stx[2]
+  let exts      := stx[3]
+  let parents   := if exts.isNone then #[] else exts[0][1].getSepArgs
+  let optType   := stx[4]
+  let derivingClasses ← getOptDerivingClasses stx[6]
+  let type      ← if optType.isNone then `(Sort _) else pure optType[0][1]
+  let ctor ← expandCtor stx modifiers declName
+  let fields ← expandFields stx modifiers declName
+  fields.forM fun field => do
+    if field.declName == ctor.declName then
+      throwErrorAt field.ref "invalid field name '{field.name}', it is equal to structure constructor name"
+    addDeclarationRangesFromSyntax field.declName field.ref
+  return {
+    ref := stx
+    declId
+    modifiers
+    isClass
+    shortDeclName := name
+    declName
+    levelNames
+    binders
+    type
+    parents
+    ctor
+    fields
+    derivingClasses
+  }
 
 private def findFieldInfo? (infos : Array StructFieldInfo) (fieldName : Name) : Option StructFieldInfo :=
   infos.find? fun info => info.name == fieldName
@@ -228,17 +295,12 @@ private def findFieldInfo? (infos : Array StructFieldInfo) (fieldName : Name) :
 private def containsFieldName (infos : Array StructFieldInfo) (fieldName : Name) : Bool :=
   (findFieldInfo? infos fieldName).isSome
 
-private def updateFieldInfoVal (infos : Array StructFieldInfo) (fieldName : Name) (value : Expr) : Array StructFieldInfo :=
-  infos.map fun info =>
-    if info.name == fieldName then
-      { info with value? := value  }
-    else
+private def replaceFieldInfo (infos : Array StructFieldInfo) (info : StructFieldInfo) : Array StructFieldInfo :=
+  infos.map fun info' =>
+    if info'.name == info.name then
       info
-
-register_builtin_option structureDiamondWarning : Bool := {
-  defValue := false
-  descr    := "enable/disable warning messages for structure diamonds"
-}
+    else
+      info'
 
 /-- Return `some fieldName` if field `fieldName` of the parent structure `parentStructName` is already in `infos` -/
 private def findExistingField? (infos : Array StructFieldInfo) (parentStructName : Name) : CoreM (Option Name) := do
@@ -256,14 +318,14 @@ where
     if h : i < subfieldNames.size then
       let subfieldName := subfieldNames.get ⟨i, h⟩
       if containsFieldName infos subfieldName then
-        throwError "field '{subfieldName}' from '{parentStructName}' has already been declared"
+        throwError "field '{subfieldName}' from '{.ofConstName parentStructName}' has already been declared"
       let val  ← mkProjection parentFVar subfieldName
       let type ← inferType val
-      withLetDecl subfieldName type val fun subfieldFVar =>
+      withLetDecl subfieldName type val fun subfieldFVar => do
         /- The following `declName` is only used for creating the `_default` auxiliary declaration name when
            its default value is overwritten in the structure. If the default value is not overwritten, then its value is irrelevant. -/
         let declName := structDeclName ++ subfieldName
-        let infos := infos.push { name := subfieldName, declName, fvar := subfieldFVar, kind := StructFieldKind.fromParent }
+        let infos := infos.push { ref := (← getRef), name := subfieldName, declName, fvar := subfieldFVar, kind := StructFieldKind.fromParent }
         go (i+1) infos
     else
       k infos
@@ -366,7 +428,7 @@ private partial def copyDefaultValue? (fieldMap : FieldMap) (expandedStructNames
     go? (← instantiateValueLevelParams cinfo us)
 where
   failed : TermElabM (Option Expr) := do
-    logWarning s!"ignoring default value for field '{fieldName}' defined at '{structName}'"
+    logWarning m!"ignoring default value for field '{fieldName}' defined at '{.ofConstName structName}'"
     return none
 
   go? (e : Expr) : TermElabM (Option Expr) := do
@@ -402,7 +464,7 @@ where
         | some existingFieldInfo =>
           let existingFieldType ← inferType existingFieldInfo.fvar
           unless (← isDefEq fieldType existingFieldType) do
-            throwError "parent field type mismatch, field '{fieldName}' from parent '{parentStructName}' {← mkHasTypeButIsExpectedMsg fieldType existingFieldType}"
+            throwError "parent field type mismatch, field '{fieldName}' from parent '{.ofConstName parentStructName}' {← mkHasTypeButIsExpectedMsg fieldType existingFieldType}"
           /- Remark: if structure has a default value for this field, it will be set at the `processOveriddenDefaultValues` below. -/
           copy (i+1) infos (fieldMap.insert fieldName existingFieldInfo.fvar) expandedStructNames
         | none =>
@@ -414,10 +476,11 @@ where
               let fieldDeclName := structDeclName ++ fieldName
               let fieldDeclName ← applyVisibility (← toVisibility fieldInfo) fieldDeclName
               addDocString' fieldDeclName (← findDocString? (← getEnv) fieldInfo.projFn)
-              let infos := infos.push { name := fieldName, declName := fieldDeclName, fvar := fieldFVar, value?,
+              let infos := infos.push { ref := (← getRef)
+                                        name := fieldName, declName := fieldDeclName, fvar := fieldFVar, value?,
                                         kind := StructFieldKind.copiedField }
               copy (i+1) infos fieldMap expandedStructNames
-          if fieldInfo.subobject?.isSome then
+          if let some parentParentStructName := fieldInfo.subobject? then
             let fieldParentStructName ← getStructureName fieldType
             if (← findExistingField? infos fieldParentStructName).isSome then
               -- See comment at `copyDefaultValue?`
@@ -428,8 +491,10 @@ where
             else
               let subfieldNames := getStructureFieldsFlattened (← getEnv) fieldParentStructName
               let fieldName := fieldInfo.fieldName
-              withLocalDecl fieldName fieldInfo.binderInfo fieldType fun parentFVar =>
-                let infos := infos.push { name := fieldName, declName := structDeclName ++ fieldName, fvar := parentFVar, kind := StructFieldKind.subobject }
+              withLocalDecl fieldName fieldInfo.binderInfo fieldType fun parentFVar => do
+                let infos := infos.push { ref := (← getRef)
+                                          name := fieldName, declName := structDeclName ++ fieldName, fvar := parentFVar,
+                                          kind := StructFieldKind.subobject parentParentStructName }
                 processSubfields structDeclName parentFVar fieldParentStructName subfieldNames infos fun infos =>
                   copy (i+1) infos (fieldMap.insert fieldName parentFVar) expandedStructNames
           else
@@ -466,20 +531,24 @@ private partial def mkToParentName (parentStructName : Name) (p : Name → Bool)
       if p curr then curr else go (i+1)
     go 1
 
-private partial def withParents (view : StructView) (k : Array StructFieldInfo → Array Expr → TermElabM α) : TermElabM α := do
+private partial def elabParents (view : StructView)
+    (k : Array StructFieldInfo → Array StructParentInfo → TermElabM α) : TermElabM α := do
   go 0 #[] #[]
 where
-  go (i : Nat) (infos : Array StructFieldInfo) (copiedParents : Array Expr) : TermElabM α := do
+  go (i : Nat) (infos : Array StructFieldInfo) (parents : Array StructParentInfo) : TermElabM α := do
     if h : i < view.parents.size then
-      let parentStx := view.parents.get ⟨i, h⟩
-      withRef parentStx do
-      let parentType ← Term.withSynthesize <| Term.elabType parentStx
-      let parentType ← whnf parentType
+      let parent := view.parents[i]
+      withRef parent do
+      let type ← Term.elabType parent
+      let parentType ← whnf type
       let parentStructName ← getStructureName parentType
+      if parents.any (fun info => info.structName == parentStructName) then
+        logWarningAt parent m!"duplicate parent structure '{.ofConstName parentStructName}'"
       if let some existingFieldName ← findExistingField? infos parentStructName then
         if structureDiamondWarning.get (← getOptions) then
-          logWarning s!"field '{existingFieldName}' from '{parentStructName}' has already been declared"
-        copyNewFieldsFrom view.declName infos parentType fun infos => go (i+1) infos (copiedParents.push parentType)
+          logWarning m!"field '{existingFieldName}' from '{.ofConstName parentStructName}' has already been declared"
+        let parents := parents.push { ref := parent, fvar? := none, subobject := false, structName := parentStructName, type := parentType }
+        copyNewFieldsFrom view.declName infos parentType fun infos => go (i+1) infos parents
         -- TODO: if `class`, then we need to create a let-decl that stores the local instance for the `parentStructure`
       else
         let env ← getEnv
@@ -487,10 +556,13 @@ where
         let toParentName := mkToParentName parentStructName fun n => !containsFieldName infos n && !subfieldNames.contains n
         let binfo := if view.isClass && isClass env parentStructName then BinderInfo.instImplicit else BinderInfo.default
         withLocalDecl toParentName binfo parentType fun parentFVar =>
-          let infos := infos.push { name := toParentName, declName := view.declName ++ toParentName, fvar := parentFVar, kind := StructFieldKind.subobject }
-          processSubfields view.declName parentFVar parentStructName subfieldNames infos fun infos => go (i+1) infos copiedParents
+          let infos := infos.push { ref := parent,
+                                    name := toParentName, declName := view.declName ++ toParentName, fvar := parentFVar,
+                                    kind := StructFieldKind.subobject parentStructName }
+          let parents := parents.push { ref := parent, fvar? := parentFVar, subobject := true, structName := parentStructName, type := parentType }
+          processSubfields view.declName parentFVar parentStructName subfieldNames infos fun infos => go (i+1) infos parents
     else
-      k infos copiedParents
+      k infos parents
 
 private def elabFieldTypeValue (view : StructFieldView) : TermElabM (Option Expr × Option Expr) :=
   Term.withAutoBoundImplicit <| Term.withAutoBoundImplicitForbiddenPred (fun n => view.name == n) <| Term.elabBinders view.binders.getArgs fun params => do
@@ -525,7 +597,7 @@ private partial def withFields (views : Array StructFieldView) (infos : Array St
 where
   go (i : Nat) (defaultValsOverridden : NameSet) (infos : Array StructFieldInfo) : TermElabM α := do
     if h : i < views.size then
-      let view := views.get ⟨i, h⟩
+      let view := views[i]
       withRef view.ref do
       match findFieldInfo? infos view.name with
       | none      =>
@@ -534,13 +606,15 @@ where
         | none,      none => throwError "invalid field, type expected"
         | some type, _    =>
           withLocalDecl view.rawName view.binderInfo type fun fieldFVar =>
-            let infos := infos.push { name := view.name, declName := view.declName, fvar := fieldFVar, value? := value?,
+            let infos := infos.push { ref := view.nameId
+                                      name := view.name, declName := view.declName, fvar := fieldFVar, value? := value?,
                                       kind := StructFieldKind.newField }
             go (i+1) defaultValsOverridden infos
         | none, some value =>
           let type ← inferType value
           withLocalDecl view.rawName view.binderInfo type fun fieldFVar =>
-            let infos := infos.push { name := view.name, declName := view.declName, fvar := fieldFVar, value? := value,
+            let infos := infos.push { ref := view.nameId
+                                      name := view.name, declName := view.declName, fvar := fieldFVar, value? := value,
                                       kind := StructFieldKind.newField }
             go (i+1) defaultValsOverridden infos
       | some info =>
@@ -560,11 +634,11 @@ where
               let fvarType ← inferType info.fvar
               let value ← Term.elabTermEnsuringType valStx fvarType
               pushInfoLeaf <| .ofFieldRedeclInfo { stx := view.ref }
-              let infos := updateFieldInfoVal infos info.name value
+              let infos := replaceFieldInfo infos { info with ref := view.nameId, value? := value }
               go (i+1) defaultValsOverridden infos
         match info.kind with
         | StructFieldKind.newField    => throwError "field '{view.name}' has already been declared"
-        | StructFieldKind.subobject   => throwError "unexpected subobject field reference" -- improve error message
+        | StructFieldKind.subobject n => throwError "unexpected reference to subobject field '{n}'" -- improve error message
         | StructFieldKind.copiedField => updateDefaultValue
         | StructFieldKind.fromParent  => updateDefaultValue
     else
@@ -654,13 +728,13 @@ private def updateResultingUniverse (fieldInfos : Array StructFieldInfo) (type :
   let r ← getResultUniverse type
   let rOffset : Nat   := r.getOffset
   let r       : Level := r.getLevelOffset
-  match r with
-  | Level.mvar mvarId =>
-    let us ← collectUniversesFromFields r rOffset fieldInfos
-    let rNew := mkResultUniverse us rOffset (isPropCandidate fieldInfos)
-    assignLevelMVar mvarId rNew
-    instantiateMVars type
-  | _ => throwError "failed to compute resulting universe level of structure, provide universe explicitly"
+  unless r.isMVar do
+    throwError "failed to compute resulting universe level of inductive datatype, provide universe explicitly: {r}"
+  let us ← collectUniversesFromFields r rOffset fieldInfos
+  trace[Elab.structure] "updateResultingUniverse us: {us}, r: {r}, rOffset: {rOffset}"
+  let rNew := mkResultUniverse us rOffset (isPropCandidate fieldInfos)
+  assignLevelMVar r.mvarId! rNew
+  instantiateMVars type
 
 private def collectLevelParamsInFVar (s : CollectLevelParams.State) (fvar : Expr) : TermElabM CollectLevelParams.State := do
   let type ← inferType fvar
@@ -704,9 +778,13 @@ private def mkCtor (view : StructView) (levelParams : List Name) (params : Array
 @[extern "lean_mk_projections"]
 private opaque mkProjections (env : Environment) (structName : Name) (projs : List Name) (isClass : Bool) : Except KernelException Environment
 
-private def addProjections (structName : Name) (projs : List Name) (isClass : Bool) : TermElabM Unit := do
+private def addProjections (r : ElabStructHeaderResult) (fieldInfos : Array StructFieldInfo) : TermElabM Unit := do
+  if r.type.isProp then
+    if let some fieldInfo ← fieldInfos.findM? (not <$> Meta.isProof ·.fvar) then
+      throwErrorAt fieldInfo.ref m!"failed to generate projections for 'Prop' structure, field '{format fieldInfo.name}' is not a proof"
+  let projNames := fieldInfos |>.filter (!·.isFromParent) |>.map (·.declName)
   let env ← getEnv
-  let env ← ofExceptKernelException (mkProjections env structName projs isClass)
+  let env ← ofExceptKernelException (mkProjections env r.view.declName projNames.toList r.view.isClass)
   setEnv env
 
 private def registerStructure (structName : Name) (infos : Array StructFieldInfo) : TermElabM Unit := do
@@ -714,46 +792,39 @@ private def registerStructure (structName : Name) (infos : Array StructFieldInfo
       if info.kind == StructFieldKind.fromParent then
         return none
       else
-        let env ← getEnv
         return some {
           fieldName  := info.name
           projFn     := info.declName
           binderInfo := (← getFVarLocalDecl info.fvar).binderInfo
           autoParam? := (← inferType info.fvar).getAutoParamTactic?
-          subobject? :=
-            if info.kind == StructFieldKind.subobject then
-              match env.find? info.declName with
-              | some info =>
-                match info.type.getForallBody.getAppFn with
-                | Expr.const parentName .. => some parentName
-                | _ => panic! "ill-formed structure"
-              | _ => panic! "ill-formed environment"
-            else
-              none
+          subobject? := if let .subobject parentName := info.kind then parentName else none
         }
   modifyEnv fun env => Lean.registerStructure env { structName, fields }
 
 private def mkAuxConstructions (declName : Name) : TermElabM Unit := do
   let env ← getEnv
-  let hasUnit := env.contains `PUnit
-  let hasEq   := env.contains `Eq
-  let hasHEq  := env.contains `HEq
+  let hasEq   := env.contains ``Eq
+  let hasHEq  := env.contains ``HEq
+  let hasUnit := env.contains ``PUnit
   mkRecOn declName
   if hasUnit then mkCasesOn declName
   if hasUnit && hasEq && hasHEq then mkNoConfusion declName
 
-private def addDefaults (lctx : LocalContext) (defaultAuxDecls : Array (Name × Expr × Expr)) : TermElabM Unit := do
-  let localInsts ← getLocalInstances
-  withLCtx lctx localInsts do
-    defaultAuxDecls.forM fun (declName, type, value) => do
-      let value ← instantiateMVars value
-      if value.hasExprMVar then
-        throwError "invalid default value for field, it contains metavariables{indentExpr value}"
-      /- The identity function is used as "marker". -/
-      let value ← mkId value
-      -- No need to compile the definition, since it is only used during elaboration.
-      discard <| mkAuxDefinition declName type value (zetaDelta := true) (compile := false)
-      setReducibleAttribute declName
+private def addDefaults (lctx : LocalContext) (fieldInfos : Array StructFieldInfo) : TermElabM Unit := do
+  withLCtx lctx (← getLocalInstances) do
+    fieldInfos.forM fun fieldInfo => do
+      if let some value := fieldInfo.value? then
+        let declName := mkDefaultFnOfProjFn fieldInfo.declName
+        let type ← inferType fieldInfo.fvar
+        let value ← instantiateMVars value
+        if value.hasExprMVar then
+          discard <| Term.logUnassignedUsingErrorInfos (← getMVars value)
+          throwErrorAt fieldInfo.ref "invalid default value for field '{format fieldInfo.name}', it contains metavariables{indentExpr value}"
+        /- The identity function is used as "marker". -/
+        let value ← mkId value
+        -- No need to compile the definition, since it is only used during elaboration.
+        discard <| mkAuxDefinition declName type value (zetaDelta := true) (compile := false)
+        setReducibleAttribute declName
 
 /--
 Given `type` of the form `forall ... (source : A), B`, return `forall ... [source : A], B`.
@@ -767,12 +838,14 @@ private def setSourceInstImplicit (type : Expr) : Expr :=
       type.updateForall! .instImplicit d b
   | _ => unreachable!
 
-private partial def mkCoercionToCopiedParent (levelParams : List Name) (params : Array Expr) (view : StructView) (parentType : Expr) : MetaM Unit := do
+/--
+Creates a projection function to a non-subobject parent.
+-/
+private partial def mkCoercionToCopiedParent (levelParams : List Name) (params : Array Expr) (view : StructView) (parentStructName : Name) (parentType : Expr) : MetaM StructureParentInfo := do
   let env ← getEnv
   let structName := view.declName
   let sourceFieldNames := getStructureFieldsFlattened env structName
   let structType := mkAppN (Lean.mkConst structName (levelParams.map mkLevelParam)) params
-  let Expr.const parentStructName _ ← pure parentType.getAppFn | unreachable!
   let binfo := if view.isClass && isClass env parentStructName then BinderInfo.instImplicit else BinderInfo.default
   withLocalDeclD `self structType fun source => do
     let mut declType ← instantiateMVars (← mkForallFVars params (← mkForallFVars #[source] parentType))
@@ -810,138 +883,162 @@ private partial def mkCoercionToCopiedParent (levelParams : List Name) (params :
       addInstance declName AttributeKind.global (eval_prio default)
     else
       setReducibleAttribute declName
+    return { structName := parentStructName, subobject := false, projFn := declName }
 
-private def elabStructureView (view : StructView) : TermElabM Unit := do
-  view.fields.forM fun field => do
-    if field.declName == view.ctor.declName then
-      throwErrorAt field.ref "invalid field name '{field.name}', it is equal to structure constructor name"
-    addAuxDeclarationRanges field.declName field.ref field.ref
-  let type ← Term.elabType view.type
-  unless validStructType type do throwErrorAt view.type "expected Type"
-  withRef view.ref do
-  withParents view fun fieldInfos copiedParents => do
-  withFields view.fields fieldInfos fun fieldInfos => do
+private def elabStructHeader (view : StructView) : TermElabM ElabStructHeaderResult :=
+  Term.withAutoBoundImplicitForbiddenPred (fun n => view.shortDeclName == n) do
+  Term.withAutoBoundImplicit do
+  Term.elabBinders view.binders.getArgs fun params => do
+  elabParents view fun parentFieldInfos parents => do
+    let type ← Term.elabType view.type
     Term.synthesizeSyntheticMVarsNoPostponing
-    let u ← getResultUniverse type
-    let univToInfer? ← shouldInferResultUniverse u
-    withUsed view.scopeVars view.params fieldInfos fun scopeVars => do
-      let fieldInfos ← levelMVarToParam scopeVars view.params fieldInfos univToInfer?
-      let type ← withRef view.ref do
-        if univToInfer?.isSome then
-          updateResultingUniverse fieldInfos type
-        else
-          checkResultingUniverse (← getResultUniverse type)
-          pure type
-      trace[Elab.structure] "type: {type}"
-      let usedLevelNames ← collectLevelParamsInStructure type scopeVars view.params fieldInfos
-      match sortDeclLevelParams view.scopeLevelNames view.allUserLevelNames usedLevelNames with
-      | Except.error msg      => withRef view.ref <| throwError msg
-      | Except.ok levelParams =>
-        let params := scopeVars ++ view.params
-        let ctor ← mkCtor view levelParams params fieldInfos
-        let type ← mkForallFVars params type
-        let type ← instantiateMVars type
-        let indType := { name := view.declName, type := type, ctors := [ctor] : InductiveType }
-        let decl    := Declaration.inductDecl levelParams params.size [indType] view.modifiers.isUnsafe
-        Term.ensureNoUnassignedMVars decl
-        addDecl decl
-        let projNames := (fieldInfos.filter fun (info : StructFieldInfo) => !info.isFromParent).toList.map fun (info : StructFieldInfo) => info.declName
-        addProjections view.declName projNames view.isClass
-        registerStructure view.declName fieldInfos
-        mkAuxConstructions view.declName
-        let instParents ← fieldInfos.filterM fun info => do
-          let decl ← Term.getFVarLocalDecl! info.fvar
-          pure (info.isSubobject && decl.binderInfo.isInstImplicit)
-        withSaveInfoContext do  -- save new env
-          Term.addLocalVarInfo view.ref[1] (← mkConstWithLevelParams view.declName)
-          if let some _ := view.ctor.ref.getPos? (canonicalOnly := true) then
-            Term.addTermInfo' view.ctor.ref (← mkConstWithLevelParams view.ctor.declName) (isBinder := true)
-          for field in view.fields do
-            -- may not exist if overriding inherited field
-            if (← getEnv).contains field.declName then
-              Term.addTermInfo' field.ref (← mkConstWithLevelParams field.declName) (isBinder := true)
-        Term.applyAttributesAt view.declName view.modifiers.attrs AttributeApplicationTime.afterTypeChecking
-        let projInstances := instParents.toList.map fun info => info.declName
-        projInstances.forM fun declName => addInstance declName AttributeKind.global (eval_prio default)
-        copiedParents.forM fun parent => mkCoercionToCopiedParent levelParams params view parent
-        let lctx ← getLCtx
-        let fieldsWithDefault := fieldInfos.filter fun info => info.value?.isSome
-        let defaultAuxDecls ← fieldsWithDefault.mapM fun info => do
-          let type ← inferType info.fvar
-          pure (mkDefaultFnOfProjFn info.declName, type, info.value?.get!)
-        /- The `lctx` and `defaultAuxDecls` are used to create the auxiliary "default value" declarations
-           The parameters `params` for these definitions must be marked as implicit, and all others as explicit. -/
-        let lctx :=
-          params.foldl (init := lctx) fun (lctx : LocalContext) (p : Expr) =>
-            if p.isFVar then
-              lctx.setBinderInfo p.fvarId! BinderInfo.implicit
-            else
-              lctx
-        let lctx :=
-          fieldInfos.foldl (init := lctx) fun (lctx : LocalContext) (info : StructFieldInfo) =>
-            if info.isFromParent then lctx -- `fromParent` fields are elaborated as let-decls, and are zeta-expanded when creating "default value" auxiliary functions
-            else lctx.setBinderInfo info.fvar.fvarId! BinderInfo.default
-        addDefaults lctx defaultAuxDecls
+    let u ← mkFreshLevelMVar
+    unless ← isDefEq type (mkSort u) do
+      throwErrorAt view.type "invalid structure type, expecting 'Type _' or 'Prop'"
+    let type ← instantiateMVars (← whnf type)
+    Term.addAutoBoundImplicits' params type fun params type => do
+      let levelNames ← Term.getLevelNames
+      trace[Elab.structure] "header params: {params}, type: {type}, levelNames: {levelNames}"
+      return { lctx := (← getLCtx), localInsts := (← getLocalInstances), levelNames, params, type, view, parents, parentFieldInfos }
 
-/-
-leading_parser (structureTk <|> classTk) >> declId >> many Term.bracketedBinder >> optional «extends» >> Term.optType >>
-  optional (("where" <|> ":=") >> optional structCtor >> structFields) >> optDeriving
-
-where
-def «extends» := leading_parser " extends " >> sepBy1 termParser ", "
-def typeSpec := leading_parser " : " >> termParser
-def optType : Parser := optional typeSpec
-
-def structFields         := leading_parser many (structExplicitBinder <|> structImplicitBinder <|> structInstBinder)
-def structCtor           := leading_parser try (declModifiers >> ident >> " :: ")
+private def mkTypeFor (r : ElabStructHeaderResult) : TermElabM Expr := do
+  withLCtx r.lctx r.localInsts do
+    mkForallFVars r.params r.type
 
+/--
+Create a local declaration for the structure and execute `x params indFVar`, where `params` are the structure's type parameters and
+`indFVar` is the new local declaration.
 -/
+private partial def withStructureLocalDecl (r : ElabStructHeaderResult) (x : Array Expr → Expr → TermElabM α) : TermElabM α := do
+  let declName := r.view.declName
+  let shortDeclName := r.view.shortDeclName
+  let type ← mkTypeFor r
+  let params := r.params
+  withLCtx r.lctx r.localInsts <| withRef r.view.ref do
+    Term.withAuxDecl shortDeclName type declName fun indFVar =>
+      x params indFVar
+
+/--
+Remark: `numVars <= numParams`.
+`numVars` is the number of context `variables` used in the declaration,
+and `numParams - numVars` is the number of parameters provided as binders in the declaration.
+-/
+private def mkInductiveType (view : StructView) (indFVar : Expr) (levelNames : List Name)
+    (numVars : Nat) (numParams : Nat) (type : Expr) (ctor : Constructor) : TermElabM InductiveType := do
+  let levelParams := levelNames.map mkLevelParam
+  let const := mkConst view.declName levelParams
+  let ctorType ← forallBoundedTelescope ctor.type numParams fun params type => do
+    if type.containsFVar indFVar.fvarId! then
+      throwErrorAt view.ref "Recursive structures are not yet supported."
+    let type := type.replace fun e =>
+      if e == indFVar then
+        mkAppN const (params.extract 0 numVars)
+      else
+        none
+    instantiateMVars (← mkForallFVars params type)
+  return { name := view.declName, type := ← instantiateMVars type, ctors := [{ ctor with type := ← instantiateMVars ctorType }] }
+
+def mkStructureDecl (vars : Array Expr) (view : StructView) : TermElabM Unit := Term.withoutSavingRecAppSyntax do
+  let scopeLevelNames ← Term.getLevelNames
+  let isUnsafe := view.modifiers.isUnsafe
+  withRef view.ref <| Term.withLevelNames view.levelNames do
+    let r ← elabStructHeader view
+    Term.synthesizeSyntheticMVarsNoPostponing
+    withLCtx r.lctx r.localInsts do
+    withStructureLocalDecl r fun params indFVar => do
+    trace[Elab.structure] "indFVar: {indFVar}"
+    Term.addLocalVarInfo view.declId indFVar
+    withFields view.fields r.parentFieldInfos fun fieldInfos =>
+    withRef view.ref do
+      Term.synthesizeSyntheticMVarsNoPostponing
+      let type ← instantiateMVars r.type
+      let u ← getResultUniverse type
+      let univToInfer? ← shouldInferResultUniverse u
+      withUsed vars params fieldInfos fun scopeVars => do
+        let fieldInfos ← levelMVarToParam scopeVars params fieldInfos univToInfer?
+        let type ← withRef view.ref do
+          if univToInfer?.isSome then
+            updateResultingUniverse fieldInfos type
+          else
+            checkResultingUniverse (← getResultUniverse type)
+            pure type
+        trace[Elab.structure] "type: {type}"
+        let usedLevelNames ← collectLevelParamsInStructure type scopeVars params fieldInfos
+        match sortDeclLevelParams scopeLevelNames r.levelNames usedLevelNames with
+        | Except.error msg      => throwErrorAt view.declId msg
+        | Except.ok levelParams =>
+          let params := scopeVars ++ params
+          let ctor ← mkCtor view levelParams params fieldInfos
+          let type ← mkForallFVars params type
+          let type ← instantiateMVars type
+          let indType ← mkInductiveType view indFVar levelParams scopeVars.size params.size type ctor
+          let decl    := Declaration.inductDecl levelParams params.size [indType] isUnsafe
+          Term.ensureNoUnassignedMVars decl
+          addDecl decl
+          -- rename indFVar so that it does not shadow the actual declaration:
+          let lctx := (← getLCtx).modifyLocalDecl indFVar.fvarId! fun decl => decl.setUserName .anonymous
+          withLCtx lctx (← getLocalInstances) do
+          addProjections r fieldInfos
+          registerStructure view.declName fieldInfos
+          mkAuxConstructions view.declName
+          let instParents ← fieldInfos.filterM fun info => do
+            let decl ← Term.getFVarLocalDecl! info.fvar
+            pure (info.isSubobject && decl.binderInfo.isInstImplicit)
+          withSaveInfoContext do  -- save new env
+            Term.addLocalVarInfo view.ref[1] (← mkConstWithLevelParams view.declName)
+            if let some _ := view.ctor.ref.getPos? (canonicalOnly := true) then
+              Term.addTermInfo' view.ctor.ref (← mkConstWithLevelParams view.ctor.declName) (isBinder := true)
+            for field in view.fields do
+              -- may not exist if overriding inherited field
+              if (← getEnv).contains field.declName then
+                Term.addTermInfo' field.ref (← mkConstWithLevelParams field.declName) (isBinder := true)
+          withRef view.declId do
+            Term.applyAttributesAt view.declName view.modifiers.attrs AttributeApplicationTime.afterTypeChecking
+          let projInstances := instParents.toList.map fun info => info.declName
+          projInstances.forM fun declName => addInstance declName AttributeKind.global (eval_prio default)
+          let parentInfos ← r.parents.mapM fun parent => do
+            if parent.subobject then
+              let some info := fieldInfos.find? (·.kind == .subobject parent.structName) | unreachable!
+              pure { structName := parent.structName, subobject := true, projFn := info.declName }
+            else
+              mkCoercionToCopiedParent levelParams params view parent.structName parent.type
+          setStructureParents view.declName parentInfos
+          let lctx ← getLCtx
+          /- The `lctx` and `defaultAuxDecls` are used to create the auxiliary "default value" declarations
+            The parameters `params` for these definitions must be marked as implicit, and all others as explicit. -/
+          let lctx :=
+            params.foldl (init := lctx) fun (lctx : LocalContext) (p : Expr) =>
+              if p.isFVar then
+                lctx.setBinderInfo p.fvarId! BinderInfo.implicit
+              else
+                lctx
+          let lctx :=
+            fieldInfos.foldl (init := lctx) fun (lctx : LocalContext) (info : StructFieldInfo) =>
+              if info.isFromParent then lctx -- `fromParent` fields are elaborated as let-decls, and are zeta-expanded when creating "default value" auxiliary functions
+              else lctx.setBinderInfo info.fvar.fvarId! BinderInfo.default
+          addDefaults lctx fieldInfos
+
+
+def elabStructureView (vars : Array Expr) (view : StructView) : TermElabM Unit := do
+  Term.withDeclName view.declName <| withRef view.ref do
+    mkStructureDecl vars view
+    unless view.isClass do
+      Lean.Meta.IndPredBelow.mkBelow view.declName
+      mkSizeOfInstances view.declName
+      mkInjectiveTheorems view.declName
+
+def elabStructureViewPostprocessing (view : StructView) : CommandElabM Unit := do
+  view.derivingClasses.forM fun classView => classView.applyHandlers #[view.declName]
+  runTermElabM fun _ => Term.withDeclName view.declName <| withRef view.declId do
+    Term.applyAttributesAt view.declName view.modifiers.attrs .afterCompilation
+
 def elabStructure (modifiers : Modifiers) (stx : Syntax) : CommandElabM Unit := do
-  checkValidInductiveModifier modifiers
-  let isClass   := stx[0].getKind == ``Parser.Command.classTk
-  let modifiers := if isClass then modifiers.addAttr { name := `class } else modifiers
-  let declId    := stx[1]
-  let params    := stx[2].getArgs
-  let exts      := stx[3]
-  let parents   := if exts.isNone then #[] else exts[0][1].getSepArgs
-  let optType   := stx[4]
-  let derivingClassViews ← liftCoreM <| getOptDerivingClasses stx[6]
-  let type ← if optType.isNone then `(Sort _) else pure optType[0][1]
-  let declName ←
-    runTermElabM fun scopeVars => do
-      let scopeLevelNames ← Term.getLevelNames
-      let ⟨name, declName, allUserLevelNames⟩ ← Elab.expandDeclId (← getCurrNamespace) scopeLevelNames declId modifiers
-      Term.withAutoBoundImplicitForbiddenPred (fun n => name == n) do
-        addDeclarationRanges declName stx
-        Term.withDeclName declName do
-          let ctor ← expandCtor stx modifiers declName
-          let fields ← expandFields stx modifiers declName
-          Term.withLevelNames allUserLevelNames <| Term.withAutoBoundImplicit <|
-            Term.elabBinders params fun params => do
-              Term.synthesizeSyntheticMVarsNoPostponing
-              let params ← Term.addAutoBoundImplicits params
-              let allUserLevelNames ← Term.getLevelNames
-              elabStructureView {
-                ref := stx
-                modifiers
-                scopeLevelNames
-                allUserLevelNames
-                declName
-                isClass
-                scopeVars
-                params
-                parents
-                type
-                ctor
-                fields
-              }
-              unless isClass do
-                mkSizeOfInstances declName
-                mkInjectiveTheorems declName
-              return declName
-  derivingClassViews.forM fun view => view.applyHandlers #[declName]
-  runTermElabM fun _ => Term.withDeclName declName do
-    Term.applyAttributesAt declName modifiers.attrs .afterCompilation
+  let view ← runTermElabM fun vars => do
+    let view ← structureSyntaxToView modifiers stx
+    trace[Elab.structure] "view.levelNames: {view.levelNames}"
+    elabStructureView vars view
+    pure view
+  elabStructureViewPostprocessing view
 
 builtin_initialize registerTraceClass `Elab.structure
 

src/Lean/Elab/Syntax.lean

@@ -146,7 +146,7 @@ where
       let args ← args.mapM fun arg => withNestedParser do process arg
       mkParserSeq args
     else
-      let args ← args.mapIdxM fun i arg => withReader (fun ctx => { ctx with first := ctx.first && i.val == 0 }) do process arg
+      let args ← args.mapIdxM fun i arg => withReader (fun ctx => { ctx with first := ctx.first && i == 0 }) do process arg
       mkParserSeq args
 
   ensureNoPrec (stx : Syntax) :=

src/Lean/Elab/SyntheticMVars.lean

@@ -219,10 +219,13 @@ def reportStuckSyntheticMVar (mvarId : MVarId) (ignoreStuckTC := false) : TermEl
           let mvarDecl ← getMVarDecl mvarId
           unless (← MonadLog.hasErrors) do
             throwError "typeclass instance problem is stuck, it is often due to metavariables{indentExpr mvarDecl.type}{extraErrorMsg}"
-    | .coe header expectedType e f? =>
+    | .coe header expectedType e f? mkErrorMsg? =>
       mvarId.withContext do
-        throwTypeMismatchError header expectedType (← inferType e) e f?
-          m!"failed to create type class instance for{indentExpr (← getMVarDecl mvarId).type}"
+        if let some mkErrorMsg := mkErrorMsg? then
+          throwError (← mkErrorMsg mvarId expectedType e)
+        else
+          throwTypeMismatchError header expectedType (← inferType e) e f?
+            m!"failed to create type class instance for{indentExpr (← getMVarDecl mvarId).type}"
     | _ => unreachable! -- TODO handle other cases.
 
 /--
@@ -386,7 +389,7 @@ mutual
     withRef mvarSyntheticDecl.stx do
     match mvarSyntheticDecl.kind with
     | .typeClass extraErrorMsg? => synthesizePendingInstMVar mvarId extraErrorMsg?
-    | .coe _header? expectedType e _f? => mvarId.withContext do
+    | .coe _header? expectedType e _f? _ => mvarId.withContext do
       if (← withDefault do isDefEq (← inferType e) expectedType) then
         -- Types may be defeq now due to mvar assignments, type class
         -- defaulting, etc.

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

@@ -225,8 +225,8 @@ def reflectBV (g : MVarId) : M ReflectionResult := g.withContext do
   let mut sats := #[]
   let mut unusedHypotheses := {}
   for hyp in hyps do
-    if let some reflected ← SatAtBVLogical.of (mkFVar hyp) then
-      sats := sats.push reflected
+    if let (some reflected, lemmas) ← (SatAtBVLogical.of (mkFVar hyp)).run then
+      sats := (sats ++ lemmas).push reflected
     else
       unusedHypotheses := unusedHypotheses.insert hyp
   if h : sats.size = 0 then

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

@@ -79,6 +79,7 @@ instance : ToExpr Gate where
     | .and => mkConst ``Gate.and
     | .xor => mkConst ``Gate.xor
     | .beq => mkConst ``Gate.beq
+    | .imp => mkConst ``Gate.imp
   toTypeExpr := mkConst ``Gate
 
 instance : ToExpr BVPred where
@@ -101,6 +102,7 @@ where
   | .const b => mkApp2 (mkConst ``BoolExpr.const) (toTypeExpr α) (toExpr b)
   | .not x => mkApp2 (mkConst ``BoolExpr.not) (toTypeExpr α) (go x)
   | .gate g x y => mkApp4 (mkConst ``BoolExpr.gate) (toTypeExpr α) (toExpr g) (go x) (go y)
+  | .ite d l r => mkApp4 (mkConst ``BoolExpr.ite) (toTypeExpr α) (go d) (go l) (go r)
 
 
 open Lean.Meta
@@ -124,6 +126,76 @@ The reflection monad, used to track `BitVec` variables that we see as we travers
 -/
 abbrev M := StateRefT State MetaM
 
+/--
+A reified version of an `Expr` representing a `BVExpr`.
+-/
+structure ReifiedBVExpr where
+  width : Nat
+  /--
+  The reified expression.
+  -/
+  bvExpr : BVExpr width
+  /--
+  A proof that `bvExpr.eval atomsAssignment = originalBVExpr`.
+  -/
+  evalsAtAtoms : M Expr
+  /--
+  A cache for `toExpr bvExpr`.
+  -/
+  expr : Expr
+
+/--
+A reified version of an `Expr` representing a `BVPred`.
+-/
+structure ReifiedBVPred where
+  /--
+  The reified expression.
+  -/
+  bvPred : BVPred
+  /--
+  A proof that `bvPred.eval atomsAssignment = originalBVPredExpr`.
+  -/
+  evalsAtAtoms : M Expr
+  /--
+  A cache for `toExpr bvPred`
+  -/
+  expr : Expr
+
+/--
+A reified version of an `Expr` representing a `BVLogicalExpr`.
+-/
+structure ReifiedBVLogical where
+  /--
+  The reified expression.
+  -/
+  bvExpr : BVLogicalExpr
+  /--
+  A proof that `bvExpr.eval atomsAssignment = originalBVLogicalExpr`.
+  -/
+  evalsAtAtoms : M Expr
+  /--
+  A cache for `toExpr bvExpr`
+  -/
+  expr : Expr
+
+/--
+A reified version of an `Expr` representing a `BVLogicalExpr` that we know to be true.
+-/
+structure SatAtBVLogical where
+  /--
+  The reified expression.
+  -/
+  bvExpr : BVLogicalExpr
+  /--
+  A proof that `bvExpr.eval atomsAssignment = true`.
+  -/
+  satAtAtoms : M Expr
+  /--
+  A cache for `toExpr bvExpr`
+  -/
+  expr : Expr
+
+
 namespace M
 
 /--
@@ -171,5 +243,34 @@ where
 
 end M
 
+/--
+The state of the lemma reflection monad.
+-/
+structure LemmaState where
+  /--
+  The list of top level lemmas that got created on the fly during reflection.
+  -/
+  lemmas : Array SatAtBVLogical := #[]
+
+/--
+The lemma reflection monad. It extends the usual reflection monad `M` by adding the ability to
+add additional top level lemmas on the fly.
+-/
+abbrev LemmaM := StateRefT LemmaState M
+
+namespace LemmaM
+
+def run (m : LemmaM α) (state : LemmaState := {}) : M (α × Array SatAtBVLogical) := do
+  let (res, state) ← StateRefT'.run m state
+  return (res, state.lemmas)
+
+/--
+Add another top level lemma.
+-/
+def addLemma (lemma : SatAtBVLogical) : LemmaM Unit := do
+  modify fun s => { s with lemmas := s.lemmas.push lemma }
+
+end LemmaM
+
 end Frontend
 end Lean.Elab.Tactic.BVDecide

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

@@ -14,30 +14,14 @@ Provides the logic for reifying `BitVec` expressions.
 namespace Lean.Elab.Tactic.BVDecide
 namespace Frontend
 
-open Lean.Meta
 open Std.Tactic.BVDecide
-open Std.Tactic.BVDecide.Reflect.BitVec
-
-/--
-A reified version of an `Expr` representing a `BVExpr`.
--/
-structure ReifiedBVExpr where
-  width : Nat
-  /--
-  The reified expression.
-  -/
-  bvExpr : BVExpr width
-  /--
-  A proof that `bvExpr.eval atomsAssignment = originalBVExpr`.
-  -/
-  evalsAtAtoms : M Expr
-  /--
-  A cache for `toExpr bvExpr`.
-  -/
-  expr : Expr
+open Lean.Meta
 
 namespace ReifiedBVExpr
 
+/--
+Build `BVExpr.eval atoms expr` where `atoms` is the assignment stored in the monad.
+-/
 def mkEvalExpr (w : Nat) (expr : Expr) : M Expr := do
   return mkApp3 (mkConst ``BVExpr.eval) (toExpr w) (← M.atomsAssignment) expr
 
@@ -47,6 +31,9 @@ def mkBVRefl (w : Nat) (expr : Expr) : Expr :=
    (mkApp (mkConst ``BitVec) (toExpr w))
    expr
 
+/--
+Register `e` as an atom of width `width`.
+-/
 def mkAtom (e : Expr) (width : Nat) : M ReifiedBVExpr := do
   let ident ← M.lookup e width
   let expr := mkApp2 (mkConst ``BVExpr.var) (toExpr width) (toExpr ident)
@@ -55,6 +42,9 @@ def mkAtom (e : Expr) (width : Nat) : M ReifiedBVExpr := do
     return mkBVRefl width evalExpr
   return ⟨width, .var ident, proof, expr⟩
 
+/--
+Parse `expr` as a `Nat` or `BitVec` constant depending on `ty`.
+-/
 def getNatOrBvValue? (ty : Expr) (expr : Expr) : M (Option Nat) := do
   match_expr ty with
   | Nat =>
@@ -65,295 +55,25 @@ def getNatOrBvValue? (ty : Expr) (expr : Expr) : M (Option Nat) := do
   | _ => return none
 
 /--
-Reify an `Expr` that's a `BitVec`.
+Construct an uninterpreted `BitVec` atom from `x`.
 -/
-partial def of (x : Expr) : M (Option ReifiedBVExpr) := do
-  match_expr x with
-  | BitVec.ofNat _ _ => goBvLit x
-  | HAnd.hAnd _ _ _ _ lhsExpr rhsExpr =>
-    binaryReflection lhsExpr rhsExpr .and ``Std.Tactic.BVDecide.Reflect.BitVec.and_congr
-  | HOr.hOr _ _ _ _ lhsExpr rhsExpr =>
-    binaryReflection lhsExpr rhsExpr .or ``Std.Tactic.BVDecide.Reflect.BitVec.or_congr
-  | HXor.hXor _ _ _ _ lhsExpr rhsExpr =>
-    binaryReflection lhsExpr rhsExpr .xor ``Std.Tactic.BVDecide.Reflect.BitVec.xor_congr
-  | HAdd.hAdd _ _ _ _ lhsExpr rhsExpr =>
-    binaryReflection lhsExpr rhsExpr .add ``Std.Tactic.BVDecide.Reflect.BitVec.add_congr
-  | HMul.hMul _ _ _ _ lhsExpr rhsExpr =>
-    binaryReflection lhsExpr rhsExpr .mul ``Std.Tactic.BVDecide.Reflect.BitVec.mul_congr
-  | HDiv.hDiv _ _ _ _ lhsExpr rhsExpr =>
-    binaryReflection lhsExpr rhsExpr .udiv ``Std.Tactic.BVDecide.Reflect.BitVec.udiv_congr
-  | HMod.hMod _ _ _ _ lhsExpr rhsExpr =>
-    binaryReflection lhsExpr rhsExpr .umod ``Std.Tactic.BVDecide.Reflect.BitVec.umod_congr
-  | Complement.complement _ _ innerExpr =>
-    unaryReflection innerExpr .not ``Std.Tactic.BVDecide.Reflect.BitVec.not_congr
-  | HShiftLeft.hShiftLeft _ β _ _ innerExpr distanceExpr =>
-    let distance? ← getNatOrBvValue? β distanceExpr
-    if distance?.isSome then
-      shiftConstReflection
-        β
-        distanceExpr
-        innerExpr
-        .shiftLeftConst
-        ``BVUnOp.shiftLeftConst
-        ``Std.Tactic.BVDecide.Reflect.BitVec.shiftLeftNat_congr
-    else
-      shiftReflection
-        β
-        distanceExpr
-        innerExpr
-        .shiftLeft
-        ``BVExpr.shiftLeft
-        ``Std.Tactic.BVDecide.Reflect.BitVec.shiftLeft_congr
-  | HShiftRight.hShiftRight _ β _ _ innerExpr distanceExpr =>
-    let distance? ← getNatOrBvValue? β distanceExpr
-    if distance?.isSome then
-      shiftConstReflection
-        β
-        distanceExpr
-        innerExpr
-        .shiftRightConst
-        ``BVUnOp.shiftRightConst
-        ``Std.Tactic.BVDecide.Reflect.BitVec.shiftRightNat_congr
-    else
-      shiftReflection
-        β
-        distanceExpr
-        innerExpr
-        .shiftRight
-        ``BVExpr.shiftRight
-        ``Std.Tactic.BVDecide.Reflect.BitVec.shiftRight_congr
-  | BitVec.sshiftRight _ innerExpr distanceExpr =>
-    let some distance ← getNatValue? distanceExpr | return ← ofAtom x
-    shiftConstLikeReflection
-      distance
-      innerExpr
-      .arithShiftRightConst
-      ``BVUnOp.arithShiftRightConst
-      ``Std.Tactic.BVDecide.Reflect.BitVec.arithShiftRight_congr
-  | BitVec.zeroExtend _ newWidthExpr innerExpr =>
-    let some newWidth ← getNatValue? newWidthExpr | return ← ofAtom x
-    let some inner ← ofOrAtom innerExpr | return none
-    let bvExpr := .zeroExtend newWidth inner.bvExpr
-    let expr :=
-      mkApp3
-        (mkConst ``BVExpr.zeroExtend)
-        (toExpr inner.width)
-        newWidthExpr
-        inner.expr
-    let proof := do
-      let innerEval ← mkEvalExpr inner.width inner.expr
-      let innerProof ← inner.evalsAtAtoms
-      return mkApp5 (mkConst ``Std.Tactic.BVDecide.Reflect.BitVec.zeroExtend_congr)
-        newWidthExpr
-        (toExpr inner.width)
-        innerExpr
-        innerEval
-        innerProof
-    return some ⟨newWidth, bvExpr, proof, expr⟩
-  | BitVec.signExtend _ newWidthExpr innerExpr =>
-    let some newWidth ← getNatValue? newWidthExpr | return ← ofAtom x
-    let some inner ← ofOrAtom innerExpr | return none
-    let bvExpr := .signExtend newWidth inner.bvExpr
-    let expr :=
-      mkApp3
-        (mkConst ``BVExpr.signExtend)
-        (toExpr inner.width)
-        newWidthExpr
-        inner.expr
-    let proof := do
-      let innerEval ← mkEvalExpr inner.width inner.expr
-      let innerProof ← inner.evalsAtAtoms
-      return mkApp5 (mkConst ``Std.Tactic.BVDecide.Reflect.BitVec.signExtend_congr)
-        newWidthExpr
-        (toExpr inner.width)
-        innerExpr
-        innerEval
-        innerProof
-    return some ⟨newWidth, bvExpr, proof, expr⟩
-  | HAppend.hAppend _ _ _ _ lhsExpr rhsExpr =>
-    let some lhs ← ofOrAtom lhsExpr | return none
-    let some rhs ← ofOrAtom rhsExpr | return none
-    let bvExpr := .append lhs.bvExpr rhs.bvExpr
-    let expr := mkApp4 (mkConst ``BVExpr.append)
-      (toExpr lhs.width)
-      (toExpr rhs.width)
-      lhs.expr rhs.expr
-    let proof := do
-      let lhsEval ← mkEvalExpr lhs.width lhs.expr
-      let lhsProof ← lhs.evalsAtAtoms
-      let rhsProof ← rhs.evalsAtAtoms
-      let rhsEval ← mkEvalExpr rhs.width rhs.expr
-      return mkApp8 (mkConst ``Std.Tactic.BVDecide.Reflect.BitVec.append_congr)
-        (toExpr lhs.width) (toExpr rhs.width)
-        lhsExpr lhsEval
-        rhsExpr rhsEval
-        lhsProof rhsProof
-    return some ⟨lhs.width + rhs.width, bvExpr, proof, expr⟩
-  | BitVec.replicate _ nExpr innerExpr =>
-    let some inner ← ofOrAtom innerExpr | return none
-    let some n ← getNatValue? nExpr | return ← ofAtom x
-    let bvExpr := .replicate n inner.bvExpr
-    let expr := mkApp3 (mkConst ``BVExpr.replicate)
-      (toExpr inner.width)
-      (toExpr n)
-      inner.expr
-    let proof := do
-      let innerEval ← mkEvalExpr inner.width inner.expr
-      let innerProof ← inner.evalsAtAtoms
-      return mkApp5 (mkConst ``Std.Tactic.BVDecide.Reflect.BitVec.replicate_congr)
-        (toExpr n)
-        (toExpr inner.width)
-        innerExpr
-        innerEval
-        innerProof
-    return some ⟨inner.width * n, bvExpr, proof, expr⟩
-  | BitVec.extractLsb' _ startExpr lenExpr innerExpr =>
-    let some start ← getNatValue? startExpr | return ← ofAtom x
-    let some len ← getNatValue? lenExpr | return ← ofAtom x
-    let some inner ← ofOrAtom innerExpr | return none
-    let bvExpr := .extract start len inner.bvExpr
-    let expr := mkApp4 (mkConst ``BVExpr.extract)
-      (toExpr inner.width)
-      startExpr
-      lenExpr
-      inner.expr
-    let proof := do
-      let innerEval ← mkEvalExpr inner.width inner.expr
-      let innerProof ← inner.evalsAtAtoms
-      return mkApp6 (mkConst ``Std.Tactic.BVDecide.Reflect.BitVec.extract_congr)
-        startExpr
-        lenExpr
-        (toExpr inner.width)
-        innerExpr
-        innerEval
-        innerProof
-    return some ⟨len, bvExpr, proof, expr⟩
-  | BitVec.rotateLeft _ innerExpr distanceExpr =>
-    rotateReflection
-      distanceExpr
-      innerExpr
-      .rotateLeft
-      ``BVUnOp.rotateLeft
-      ``Std.Tactic.BVDecide.Reflect.BitVec.rotateLeft_congr
-  | BitVec.rotateRight _ innerExpr distanceExpr =>
-    rotateReflection
-      distanceExpr
-      innerExpr
-      .rotateRight
-      ``BVUnOp.rotateRight
-      ``Std.Tactic.BVDecide.Reflect.BitVec.rotateRight_congr
-  | _ => ofAtom x
-where
-  ofAtom (x : Expr) : M (Option ReifiedBVExpr) := do
-    let t ← instantiateMVars (← whnfR (← inferType x))
-    let_expr BitVec widthExpr := t | return none
-    let some width ← getNatValue? widthExpr | return none
-    let atom ← mkAtom x width
-    return some atom
+def bitVecAtom (x : Expr) : M (Option ReifiedBVExpr) := do
+  let t ← instantiateMVars (← whnfR (← inferType x))
+  let_expr BitVec widthExpr := t | return none
+  let some width ← getNatValue? widthExpr | return none
+  let atom ← mkAtom x width
+  return some atom
 
-  ofOrAtom (x : Expr) : M (Option ReifiedBVExpr) := do
-    let res ← of x
-    match res with
-    | some exp => return some exp
-    | none => ofAtom x
-
-  shiftConstLikeReflection (distance : Nat) (innerExpr : Expr) (shiftOp : Nat → BVUnOp)
-      (shiftOpName : Name) (congrThm : Name) :
-      M (Option ReifiedBVExpr) := do
-    let some inner ← ofOrAtom innerExpr | return none
-    let bvExpr : BVExpr inner.width := .un (shiftOp distance) inner.bvExpr
-    let expr :=
-      mkApp3
-        (mkConst ``BVExpr.un)
-        (toExpr inner.width)
-        (mkApp (mkConst shiftOpName) (toExpr distance))
-        inner.expr
-    let congrProof :=
-      mkApp
-        (mkConst congrThm)
-        (toExpr distance)
-    let proof := unaryCongrProof inner innerExpr congrProof
-    return some ⟨inner.width, bvExpr, proof, expr⟩
-
-  rotateReflection (distanceExpr : Expr) (innerExpr : Expr) (rotateOp : Nat → BVUnOp)
-      (rotateOpName : Name) (congrThm : Name) :
-      M (Option ReifiedBVExpr) := do
-    -- Either the shift values are constant or we abstract the entire term as atoms
-    let some distance ← getNatValue? distanceExpr | return ← ofAtom x
-    shiftConstLikeReflection distance innerExpr rotateOp rotateOpName congrThm
-
-  shiftConstReflection (β : Expr) (distanceExpr : Expr) (innerExpr : Expr) (shiftOp : Nat → BVUnOp)
-      (shiftOpName : Name) (congrThm : Name) :
-      M (Option ReifiedBVExpr) := do
-    -- Either the shift values are constant or we abstract the entire term as atoms
-    let some distance ← getNatOrBvValue? β distanceExpr | return ← ofAtom x
-    shiftConstLikeReflection distance innerExpr shiftOp shiftOpName congrThm
-
-  shiftReflection (β : Expr) (distanceExpr : Expr) (innerExpr : Expr)
-      (shiftOp : {m n : Nat} → BVExpr m → BVExpr n → BVExpr m) (shiftOpName : Name)
-      (congrThm : Name) :
-      M (Option ReifiedBVExpr) := do
-    let_expr BitVec _ ← β | return ← ofAtom x
-    let some inner ← of innerExpr | return none
-    let some distance ← of distanceExpr | return none
-    let bvExpr : BVExpr inner.width := shiftOp inner.bvExpr distance.bvExpr
-    let expr :=
-      mkApp4
-        (mkConst shiftOpName)
-        (toExpr inner.width)
-        (toExpr distance.width)
-        inner.expr
-        distance.expr
-    let congrProof :=
-      mkApp2
-        (mkConst congrThm)
-        (toExpr inner.width)
-        (toExpr distance.width)
-    let proof := binaryCongrProof inner distance innerExpr distanceExpr congrProof
-    return some ⟨inner.width, bvExpr, proof, expr⟩
-
-  binaryReflection (lhsExpr rhsExpr : Expr) (op : BVBinOp) (congrThm : Name) :
-      M (Option ReifiedBVExpr) := do
-    let some lhs ← ofOrAtom lhsExpr | return none
-    let some rhs ← ofOrAtom rhsExpr | return none
-    if h : rhs.width = lhs.width then
-      let bvExpr : BVExpr lhs.width := .bin lhs.bvExpr op (h ▸ rhs.bvExpr)
-      let expr := mkApp4 (mkConst ``BVExpr.bin) (toExpr lhs.width) lhs.expr (toExpr op) rhs.expr
-      let congrThm := mkApp (mkConst congrThm) (toExpr lhs.width)
-      let proof := binaryCongrProof lhs rhs lhsExpr rhsExpr congrThm
-      return some ⟨lhs.width, bvExpr, proof, expr⟩
-    else
-      return none
-
-  binaryCongrProof (lhs rhs : ReifiedBVExpr) (lhsExpr rhsExpr : Expr) (congrThm : Expr) :
-      M Expr := do
-    let lhsEval ← mkEvalExpr lhs.width lhs.expr
-    let lhsProof ← lhs.evalsAtAtoms
-    let rhsProof ← rhs.evalsAtAtoms
-    let rhsEval ← mkEvalExpr rhs.width rhs.expr
-    return mkApp6 congrThm lhsExpr rhsExpr lhsEval rhsEval lhsProof rhsProof
-
-  unaryReflection (innerExpr : Expr) (op : BVUnOp) (congrThm : Name) :
-      M (Option ReifiedBVExpr) := do
-    let some inner ← ofOrAtom innerExpr | return none
-    let bvExpr := .un op inner.bvExpr
-    let expr := mkApp3 (mkConst ``BVExpr.un) (toExpr inner.width) (toExpr op) inner.expr
-    let proof := unaryCongrProof inner innerExpr (mkConst congrThm)
-    return some ⟨inner.width, bvExpr, proof, expr⟩
-
-  unaryCongrProof (inner : ReifiedBVExpr) (innerExpr : Expr) (congrProof : Expr) : M Expr := do
-    let innerEval ← mkEvalExpr inner.width inner.expr
-    let innerProof ← inner.evalsAtAtoms
-    return mkApp4 congrProof (toExpr inner.width) innerExpr innerEval innerProof
-
-  goBvLit (x : Expr) : M (Option ReifiedBVExpr) := do
-    let some ⟨width, bvVal⟩ ← getBitVecValue? x | return ← ofAtom x
-    let bvExpr : BVExpr width := .const bvVal
-    let expr := mkApp2 (mkConst ``BVExpr.const) (toExpr width) (toExpr bvVal)
-    let proof := do
-      let evalExpr ← mkEvalExpr width expr
-      return mkBVRefl width evalExpr
-    return some ⟨width, bvExpr, proof, expr⟩
+/--
+Build a reified version of the constant `val`.
+-/
+def mkBVConst (val : BitVec w) : M ReifiedBVExpr := do
+  let bvExpr : BVExpr w := .const val
+  let expr := mkApp2 (mkConst ``BVExpr.const) (toExpr w) (toExpr val)
+  let proof := do
+    let evalExpr ← ReifiedBVExpr.mkEvalExpr w expr
+    return ReifiedBVExpr.mkBVRefl w evalExpr
+  return ⟨w, bvExpr, proof, expr⟩
 
 end ReifiedBVExpr
 

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

@@ -14,24 +14,7 @@ namespace Lean.Elab.Tactic.BVDecide
 namespace Frontend
 
 open Std.Tactic.BVDecide
-open Std.Tactic.BVDecide.Reflect.Bool
-
-/--
-A reified version of an `Expr` representing a `BVLogicalExpr`.
--/
-structure ReifiedBVLogical where
-  /--
-  The reified expression.
-  -/
-  bvExpr : BVLogicalExpr
-  /--
-  A proof that `bvExpr.eval atomsAssignment = originalBVLogicalExpr`.
-  -/
-  evalsAtAtoms : M Expr
-  /--
-  A cache for `toExpr bvExpr`
-  -/
-  expr : Expr
+open Lean.Meta
 
 namespace ReifiedBVLogical
 
@@ -44,66 +27,107 @@ def mkTrans (x y z : Expr) (hxy hyz : Expr) : Expr :=
 def mkEvalExpr (expr : Expr) : M Expr := do
   return mkApp2 (mkConst ``BVLogicalExpr.eval) (← M.atomsAssignment) expr
 
-partial def of (t : Expr) : M (Option ReifiedBVLogical) := do
-  match_expr t with
-  | Bool.true =>
-    let boolExpr := .const true
-    let expr := mkApp2 (mkConst ``BoolExpr.const) (mkConst ``BVPred) (toExpr Bool.true)
-    let proof := return mkRefl (mkConst ``Bool.true)
-    return some ⟨boolExpr, proof, expr⟩
-  | Bool.false =>
-    let boolExpr := .const false
-    let expr := mkApp2 (mkConst ``BoolExpr.const) (mkConst ``BVPred) (toExpr Bool.false)
-    let proof := return mkRefl (mkConst ``Bool.false)
-    return some ⟨boolExpr, proof, expr⟩
-  | Bool.not subExpr =>
-    let some sub ← of subExpr | return none
-    let boolExpr := .not sub.bvExpr
-    let expr := mkApp2 (mkConst ``BoolExpr.not) (mkConst ``BVPred) sub.expr
-    let proof := do
-      let subEvalExpr ← mkEvalExpr sub.expr
-      let subProof ← sub.evalsAtAtoms
-      return mkApp3 (mkConst ``Std.Tactic.BVDecide.Reflect.Bool.not_congr) subExpr subEvalExpr subProof
-    return some ⟨boolExpr, proof, expr⟩
-  | Bool.and lhsExpr rhsExpr => gateReflection lhsExpr rhsExpr .and ``Std.Tactic.BVDecide.Reflect.Bool.and_congr
-  | Bool.xor lhsExpr rhsExpr => gateReflection lhsExpr rhsExpr .xor ``Std.Tactic.BVDecide.Reflect.Bool.xor_congr
-  | BEq.beq α _ lhsExpr rhsExpr =>
-    match_expr α with
-    | Bool => gateReflection lhsExpr rhsExpr .beq ``Std.Tactic.BVDecide.Reflect.Bool.beq_congr
-    | BitVec _ => goPred t
-    | _ => return none
-  | _ => goPred t
-where
-  gateReflection (lhsExpr rhsExpr : Expr) (gate : Gate) (congrThm : Name) :
-      M (Option ReifiedBVLogical) := do
-    let some lhs ← of lhsExpr | return none
-    let some rhs ← of rhsExpr | return none
-    let boolExpr := .gate  gate lhs.bvExpr rhs.bvExpr
-    let expr :=
-      mkApp4
-        (mkConst ``BoolExpr.gate)
-        (mkConst ``BVPred)
-        (toExpr gate)
-        lhs.expr
-        rhs.expr
-    let proof := do
-      let lhsEvalExpr ← mkEvalExpr lhs.expr
-      let rhsEvalExpr ← mkEvalExpr rhs.expr
-      let lhsProof ← lhs.evalsAtAtoms
-      let rhsProof ← rhs.evalsAtAtoms
-      return mkApp6
-        (mkConst congrThm)
-        lhsExpr rhsExpr
-        lhsEvalExpr rhsEvalExpr
-        lhsProof rhsProof
-    return some ⟨boolExpr, proof, expr⟩
+/--
+Construct a `ReifiedBVLogical` from `ReifiedBVPred` by wrapping it as an atom.
+-/
+def ofPred (bvPred : ReifiedBVPred) : M ReifiedBVLogical := do
+  let boolExpr := .literal bvPred.bvPred
+  let expr := mkApp2 (mkConst ``BoolExpr.literal) (mkConst ``BVPred) bvPred.expr
+  let proof := bvPred.evalsAtAtoms
+  return ⟨boolExpr, proof, expr⟩
 
-  goPred (t : Expr) : M (Option ReifiedBVLogical) := do
-    let some bvPred ← ReifiedBVPred.of t | return none
-    let boolExpr := .literal bvPred.bvPred
-    let expr := mkApp2 (mkConst ``BoolExpr.literal) (mkConst ``BVPred) bvPred.expr
-    let proof := bvPred.evalsAtAtoms
-    return some ⟨boolExpr, proof, expr⟩
+/--
+Construct an uninterrpeted `Bool` atom from `t`.
+-/
+def boolAtom (t : Expr) : M (Option ReifiedBVLogical) := do
+  let some pred ← ReifiedBVPred.boolAtom t | return none
+  ofPred pred
+
+/--
+Build a reified version of the constant `val`.
+-/
+def mkBoolConst (val : Bool) : M ReifiedBVLogical := do
+  let boolExpr := .const val
+  let expr := mkApp2 (mkConst ``BoolExpr.const) (mkConst ``BVPred) (toExpr val)
+  let proof := pure <| ReifiedBVLogical.mkRefl (toExpr val)
+  return ⟨boolExpr, proof, expr⟩
+
+/--
+Construct the reified version of applying the gate in `gate` to `lhs` and `rhs`.
+This function assumes that `lhsExpr` and `rhsExpr` are the corresponding expressions to `lhs`
+and `rhs`.
+-/
+def mkGate (lhs rhs : ReifiedBVLogical) (lhsExpr rhsExpr : Expr) (gate : Gate) :
+    M ReifiedBVLogical := do
+  let congrThm := congrThmOfGate gate
+  let boolExpr := .gate gate lhs.bvExpr rhs.bvExpr
+  let expr :=
+    mkApp4
+      (mkConst ``BoolExpr.gate)
+      (mkConst ``BVPred)
+      (toExpr gate)
+      lhs.expr
+      rhs.expr
+  let proof := do
+    let lhsEvalExpr ← ReifiedBVLogical.mkEvalExpr lhs.expr
+    let rhsEvalExpr ← ReifiedBVLogical.mkEvalExpr rhs.expr
+    let lhsProof ← lhs.evalsAtAtoms
+    let rhsProof ← rhs.evalsAtAtoms
+    return mkApp6
+      (mkConst congrThm)
+      lhsExpr rhsExpr
+      lhsEvalExpr rhsEvalExpr
+      lhsProof rhsProof
+  return ⟨boolExpr, proof, expr⟩
+where
+  congrThmOfGate (gate : Gate) : Name :=
+    match gate with
+    | .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
+
+/--
+Construct the reified version of `Bool.not subExpr`.
+This function assumes that `subExpr` is the expression corresponding to `sub`.
+-/
+def mkNot (sub : ReifiedBVLogical) (subExpr : Expr) : M ReifiedBVLogical := do
+  let boolExpr := .not sub.bvExpr
+  let expr := mkApp2 (mkConst ``BoolExpr.not) (mkConst ``BVPred) sub.expr
+  let proof := do
+    let subEvalExpr ← ReifiedBVLogical.mkEvalExpr sub.expr
+    let subProof ← sub.evalsAtAtoms
+    return mkApp3 (mkConst ``Std.Tactic.BVDecide.Reflect.Bool.not_congr) subExpr subEvalExpr subProof
+  return ⟨boolExpr, proof, expr⟩
+
+/--
+Construct the reified version of `if discrExpr then lhsExpr else rhsExpr`.
+This function assumes that `discrExpr`, lhsExpr` and `rhsExpr` are the corresponding expressions to
+`discr`, `lhs` and `rhs`.
+-/
+def mkIte (discr lhs rhs : ReifiedBVLogical) (discrExpr lhsExpr rhsExpr : Expr) :
+    M ReifiedBVLogical := do
+  let boolExpr := .ite discr.bvExpr lhs.bvExpr rhs.bvExpr
+  let expr :=
+    mkApp4
+      (mkConst ``BoolExpr.ite)
+      (mkConst ``BVPred)
+      discr.expr
+      lhs.expr
+      rhs.expr
+  let proof := do
+    let discrEvalExpr ← ReifiedBVLogical.mkEvalExpr discr.expr
+    let lhsEvalExpr ← ReifiedBVLogical.mkEvalExpr lhs.expr
+    let rhsEvalExpr ← ReifiedBVLogical.mkEvalExpr rhs.expr
+    let discrProof ← discr.evalsAtAtoms
+    let lhsProof ← lhs.evalsAtAtoms
+    let rhsProof ← rhs.evalsAtAtoms
+    return mkApp9
+      (mkConst ``Std.Tactic.BVDecide.Reflect.Bool.ite_congr)
+      discrExpr lhsExpr rhsExpr
+      discrEvalExpr lhsEvalExpr rhsEvalExpr
+      discrProof lhsProof rhsProof
+  return ⟨boolExpr, proof, expr⟩
 
 end ReifiedBVLogical
 

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

@@ -7,112 +7,99 @@ prelude
 import Lean.Elab.Tactic.BVDecide.Frontend.BVDecide.ReifiedBVExpr
 
 /-!
-Provides the logic for reifying expressions consisting of predicates over `BitVec`s.
+Provides the logic for reifying predicates on `BitVec`.
 -/
 
 namespace Lean.Elab.Tactic.BVDecide
 namespace Frontend
 
-open Lean.Meta
 open Std.Tactic.BVDecide
-open Std.Tactic.BVDecide.Reflect.BitVec
-
-/--
-A reified version of an `Expr` representing a `BVPred`.
--/
-structure ReifiedBVPred where
-  /--
-  The reified expression.
-  -/
-  bvPred : BVPred
-  /--
-  A proof that `bvPred.eval atomsAssignment = originalBVPredExpr`.
-  -/
-  evalsAtAtoms : M Expr
-  /--
-  A cache for `toExpr bvPred`
-  -/
-  expr : Expr
+open Lean.Meta
 
 namespace ReifiedBVPred
 
 /--
-Reify an `Expr` that is a proof of a predicate about `BitVec`.
+Construct an uninterpreted `Bool` atom from `t`.
 -/
-def of (t : Expr) : M (Option ReifiedBVPred) := do
-  match_expr t with
-  | BEq.beq α _ lhsExpr rhsExpr =>
-    let_expr BitVec _ := α | return none
-    binaryReflection lhsExpr rhsExpr .eq ``Std.Tactic.BVDecide.Reflect.BitVec.beq_congr
-  | BitVec.ult _ lhsExpr rhsExpr =>
-    binaryReflection lhsExpr rhsExpr .ult ``Std.Tactic.BVDecide.Reflect.BitVec.ult_congr
-  | BitVec.getLsbD _ subExpr idxExpr =>
-    let some sub ← ReifiedBVExpr.of subExpr | return none
-    let some idx ← getNatValue? idxExpr | return none
-    let bvExpr : BVPred := .getLsbD sub.bvExpr idx
-    let expr := mkApp3 (mkConst ``BVPred.getLsbD) (toExpr sub.width) sub.expr idxExpr
-    let proof := do
-      let subEval ← ReifiedBVExpr.mkEvalExpr sub.width sub.expr
-      let subProof ← sub.evalsAtAtoms
-      return mkApp5
-        (mkConst ``Std.Tactic.BVDecide.Reflect.BitVec.getLsbD_congr)
-        idxExpr
-        (toExpr sub.width)
-        subExpr
-        subEval
-        subProof
-    return some ⟨bvExpr, proof, expr⟩
-  | _ =>
-    /-
-    Idea: we have t : Bool here, let's construct:
-      BitVec.ofBool t : BitVec 1
-    as an atom. Then construct the BVPred corresponding to
-      BitVec.getLsb (BitVec.ofBool t) 0 : Bool
-    We can prove that this is equivalent to `t`. This allows us to have boolean variables in BVPred.
-    -/
-    let ty ← inferType t
-    let_expr Bool := ty | return none
-    let atom ← ReifiedBVExpr.mkAtom (mkApp (mkConst ``BitVec.ofBool) t) 1
-    let bvExpr : BVPred := .getLsbD atom.bvExpr 0
-    let expr := mkApp3 (mkConst ``BVPred.getLsbD) (toExpr 1) atom.expr (toExpr 0)
-    let proof := do
-      let atomEval ← ReifiedBVExpr.mkEvalExpr atom.width atom.expr
-      let atomProof ← atom.evalsAtAtoms
-      return mkApp3
-        (mkConst ``Std.Tactic.BVDecide.Reflect.BitVec.ofBool_congr)
-        t
-        atomEval
-        atomProof
-    return some ⟨bvExpr, proof, expr⟩
-where
-  binaryReflection (lhsExpr rhsExpr : Expr) (pred : BVBinPred) (congrThm : Name) :
-      M (Option ReifiedBVPred) := do
-    let some lhs ← ReifiedBVExpr.of lhsExpr | return none
-    let some rhs ← ReifiedBVExpr.of rhsExpr | return none
-    if h : lhs.width = rhs.width then
-      let bvExpr : BVPred := .bin (w := lhs.width) lhs.bvExpr pred (h ▸ rhs.bvExpr)
-      let expr :=
-        mkApp4
-          (mkConst ``BVPred.bin)
-          (toExpr lhs.width)
-          lhs.expr
-          (toExpr pred)
-          rhs.expr
-      let proof := do
-        let lhsEval ← ReifiedBVExpr.mkEvalExpr lhs.width lhs.expr
-        let lhsProof ← lhs.evalsAtAtoms
-        let rhsEval ← ReifiedBVExpr.mkEvalExpr rhs.width rhs.expr
-        let rhsProof ← rhs.evalsAtAtoms
-        return mkApp7
-          (mkConst congrThm)
-          (toExpr lhs.width)
-          lhsExpr rhsExpr lhsEval rhsEval
-          lhsProof
-          rhsProof
-      return some ⟨bvExpr, proof, expr⟩
-    else
-      return none
+def boolAtom (t : Expr) : M (Option ReifiedBVPred) := do
+  /-
+  Idea: we have t : Bool here, let's construct:
+    BitVec.ofBool t : BitVec 1
+  as an atom. Then construct the BVPred corresponding to
+    BitVec.getLsb (BitVec.ofBool t) 0 : Bool
+  We can prove that this is equivalent to `t`. This allows us to have boolean variables in BVPred.
+  -/
+  let ty ← inferType t
+  let_expr Bool := ty | return none
+  let atom ← ReifiedBVExpr.mkAtom (mkApp (mkConst ``BitVec.ofBool) t) 1
+  let bvExpr : BVPred := .getLsbD atom.bvExpr 0
+  let expr := mkApp3 (mkConst ``BVPred.getLsbD) (toExpr 1) atom.expr (toExpr 0)
+  let proof := do
+    let atomEval ← ReifiedBVExpr.mkEvalExpr atom.width atom.expr
+    let atomProof ← atom.evalsAtAtoms
+    return mkApp3
+      (mkConst ``Std.Tactic.BVDecide.Reflect.BitVec.ofBool_congr)
+      t
+      atomEval
+      atomProof
+  return some ⟨bvExpr, proof, expr⟩
 
+/--
+Construct the reified version of applying the predicate in `pred` to `lhs` and `rhs`.
+This function assumes that `lhsExpr` and `rhsExpr` are the corresponding expressions to `lhs`
+and `rhs`.
+-/
+def mkBinPred (lhs rhs : ReifiedBVExpr) (lhsExpr rhsExpr : Expr) (pred : BVBinPred) :
+    M (Option ReifiedBVPred) := do
+  if h : lhs.width = rhs.width then
+    let congrThm := congrThmofBinPred pred
+    let bvExpr : BVPred := .bin (w := lhs.width) lhs.bvExpr pred (h ▸ rhs.bvExpr)
+    let expr :=
+      mkApp4
+        (mkConst ``BVPred.bin)
+        (toExpr lhs.width)
+        lhs.expr
+        (toExpr pred)
+        rhs.expr
+    let proof := do
+      let lhsEval ← ReifiedBVExpr.mkEvalExpr lhs.width lhs.expr
+      let lhsProof ← lhs.evalsAtAtoms
+      let rhsEval ← ReifiedBVExpr.mkEvalExpr rhs.width rhs.expr
+      let rhsProof ← rhs.evalsAtAtoms
+      return mkApp7
+        (mkConst congrThm)
+        (toExpr lhs.width)
+        lhsExpr rhsExpr lhsEval rhsEval
+        lhsProof
+        rhsProof
+    return some ⟨bvExpr, proof, expr⟩
+  else
+    return none
+where
+  congrThmofBinPred (pred : BVBinPred) : Name :=
+    match pred with
+    | .eq => ``Std.Tactic.BVDecide.Reflect.BitVec.beq_congr
+    | .ult => ``Std.Tactic.BVDecide.Reflect.BitVec.ult_congr
+
+/--
+Construct the reified version of `BitVec.getLsbD subExpr idx`.
+This function assumes that `subExpr` is the expression corresponding to `sub`.
+-/
+def mkGetLsbD (sub : ReifiedBVExpr) (subExpr : Expr) (idx : Nat) : M ReifiedBVPred := do
+  let bvExpr : BVPred := .getLsbD sub.bvExpr idx
+  let idxExpr := toExpr idx
+  let expr := mkApp3 (mkConst ``BVPred.getLsbD) (toExpr sub.width) sub.expr idxExpr
+  let proof := do
+    let subEval ← ReifiedBVExpr.mkEvalExpr sub.width sub.expr
+    let subProof ← sub.evalsAtAtoms
+    return mkApp5
+      (mkConst ``Std.Tactic.BVDecide.Reflect.BitVec.getLsbD_congr)
+      idxExpr
+      (toExpr sub.width)
+      subExpr
+      subEval
+      subProof
+  return ⟨bvExpr, proof, expr⟩
 
 end ReifiedBVPred
 

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

@@ -0,0 +1,79 @@
+/-
+Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Henrik Böving
+-/
+prelude
+import Lean.Elab.Tactic.BVDecide.Frontend.BVDecide.ReifiedBVLogical
+
+/-!
+Provides the logic for generating auxiliary lemmas during reification.
+-/
+
+namespace Lean.Elab.Tactic.BVDecide
+namespace Frontend
+
+open Std.Tactic.BVDecide
+open Lean.Meta
+
+/--
+This function adds the two lemmas:
+- `discrExpr = true → atomExpr = lhsExpr`
+- `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`.
+-/
+def addIfLemmas (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 ()
+  LemmaM.addLemma trueLemma
+  let some falseLemma ← mkIfFalseLemma discr atom lhs 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)
+      (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 eqDiscrExpr ← mkAppM ``BEq.beq #[discrExpr, discrValExpr]
+    let eqDiscr ← ReifiedBVLogical.mkGate discr discrVal discrExpr discrValExpr .beq
+
+    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 trueExpr := mkConst ``Bool.true
+    let impExpr ← mkArrow (← mkEq eqDiscrExpr trueExpr) (← mkEq eqBVExpr trueExpr)
+    let decideImpExpr ← mkAppOptM ``Decidable.decide #[some impExpr, none]
+    let imp ← ReifiedBVLogical.mkGate eqDiscr eqBV eqDiscrExpr eqBVExpr .imp
+
+    let proof := do
+      let evalExpr ← ReifiedBVLogical.mkEvalExpr imp.expr
+      let congrProof ← imp.evalsAtAtoms
+      let lemmaProof := mkApp4 (mkConst lemmaName) (toExpr lhs.width) discrExpr lhsExpr rhsExpr
+      return mkApp4
+        (mkConst ``Std.Tactic.BVDecide.Reflect.Bool.lemma_congr)
+        decideImpExpr
+        evalExpr
+        congrProof
+        lemmaProof
+    return some ⟨imp.bvExpr, proof, imp.expr⟩
+
+end Frontend
+end Lean.Elab.Tactic.BVDecide

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

@@ -0,0 +1,408 @@
+/-
+Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
+Released under Apache 2.0 license as described in the file LICENSE.
+Authors: Henrik Böving
+-/
+prelude
+import Lean.Elab.Tactic.BVDecide.Frontend.BVDecide.ReifiedBVLogical
+import Lean.Elab.Tactic.BVDecide.Frontend.BVDecide.ReifiedLemmas
+
+/-!
+Reifies `BitVec` problems with boolean substructure.
+-/
+
+namespace Lean.Elab.Tactic.BVDecide
+namespace Frontend
+
+open Std.Tactic.BVDecide
+open Lean.Meta
+
+mutual
+
+/--
+Reify an `Expr` that's a constant-width `BitVec`.
+Unless this function is called on something that is not a constant-width `BitVec` it is always
+going to return `some`.
+-/
+partial def ReifiedBVExpr.of (x : Expr) : LemmaM (Option ReifiedBVExpr) := do
+  goOrAtom x
+where
+  /--
+  Reify `x`, returns `none` if the reification procedure failed.
+  -/
+  go (x : Expr) : LemmaM (Option ReifiedBVExpr) := do
+    match_expr x with
+    | BitVec.ofNat _ _ => goBvLit x
+    | HAnd.hAnd _ _ _ _ lhsExpr rhsExpr =>
+      binaryReflection lhsExpr rhsExpr .and ``Std.Tactic.BVDecide.Reflect.BitVec.and_congr
+    | HOr.hOr _ _ _ _ lhsExpr rhsExpr =>
+      binaryReflection lhsExpr rhsExpr .or ``Std.Tactic.BVDecide.Reflect.BitVec.or_congr
+    | HXor.hXor _ _ _ _ lhsExpr rhsExpr =>
+      binaryReflection lhsExpr rhsExpr .xor ``Std.Tactic.BVDecide.Reflect.BitVec.xor_congr
+    | HAdd.hAdd _ _ _ _ lhsExpr rhsExpr =>
+      binaryReflection lhsExpr rhsExpr .add ``Std.Tactic.BVDecide.Reflect.BitVec.add_congr
+    | HMul.hMul _ _ _ _ lhsExpr rhsExpr =>
+      binaryReflection lhsExpr rhsExpr .mul ``Std.Tactic.BVDecide.Reflect.BitVec.mul_congr
+    | HDiv.hDiv _ _ _ _ lhsExpr rhsExpr =>
+      binaryReflection lhsExpr rhsExpr .udiv ``Std.Tactic.BVDecide.Reflect.BitVec.udiv_congr
+    | HMod.hMod _ _ _ _ lhsExpr rhsExpr =>
+      binaryReflection lhsExpr rhsExpr .umod ``Std.Tactic.BVDecide.Reflect.BitVec.umod_congr
+    | Complement.complement _ _ innerExpr =>
+      unaryReflection innerExpr .not ``Std.Tactic.BVDecide.Reflect.BitVec.not_congr
+    | HShiftLeft.hShiftLeft _ β _ _ innerExpr distanceExpr =>
+      let distance? ← ReifiedBVExpr.getNatOrBvValue? β distanceExpr
+      if distance?.isSome then
+        shiftConstReflection
+          β
+          distanceExpr
+          innerExpr
+          .shiftLeftConst
+          ``BVUnOp.shiftLeftConst
+          ``Std.Tactic.BVDecide.Reflect.BitVec.shiftLeftNat_congr
+      else
+        shiftReflection
+          β
+          distanceExpr
+          innerExpr
+          .shiftLeft
+          ``BVExpr.shiftLeft
+          ``Std.Tactic.BVDecide.Reflect.BitVec.shiftLeft_congr
+    | HShiftRight.hShiftRight _ β _ _ innerExpr distanceExpr =>
+      let distance? ← ReifiedBVExpr.getNatOrBvValue? β distanceExpr
+      if distance?.isSome then
+        shiftConstReflection
+          β
+          distanceExpr
+          innerExpr
+          .shiftRightConst
+          ``BVUnOp.shiftRightConst
+          ``Std.Tactic.BVDecide.Reflect.BitVec.shiftRightNat_congr
+      else
+        shiftReflection
+          β
+          distanceExpr
+          innerExpr
+          .shiftRight
+          ``BVExpr.shiftRight
+          ``Std.Tactic.BVDecide.Reflect.BitVec.shiftRight_congr
+    | BitVec.sshiftRight _ innerExpr distanceExpr =>
+      let some distance ← getNatValue? distanceExpr | return none
+      shiftConstLikeReflection
+        distance
+        innerExpr
+        .arithShiftRightConst
+        ``BVUnOp.arithShiftRightConst
+        ``Std.Tactic.BVDecide.Reflect.BitVec.arithShiftRight_congr
+    | BitVec.zeroExtend _ newWidthExpr innerExpr =>
+      let some newWidth ← getNatValue? newWidthExpr | return none
+      let some inner ← goOrAtom innerExpr | return none
+      let bvExpr := .zeroExtend newWidth inner.bvExpr
+      let expr :=
+        mkApp3
+          (mkConst ``BVExpr.zeroExtend)
+          (toExpr inner.width)
+          newWidthExpr
+          inner.expr
+      let proof := do
+        let innerEval ← ReifiedBVExpr.mkEvalExpr inner.width inner.expr
+        let innerProof ← inner.evalsAtAtoms
+        return mkApp5 (mkConst ``Std.Tactic.BVDecide.Reflect.BitVec.zeroExtend_congr)
+          newWidthExpr
+          (toExpr inner.width)
+          innerExpr
+          innerEval
+          innerProof
+      return some ⟨newWidth, bvExpr, proof, expr⟩
+    | BitVec.signExtend _ newWidthExpr innerExpr =>
+      let some newWidth ← getNatValue? newWidthExpr | return none
+      let some inner ← goOrAtom innerExpr | return none
+      let bvExpr := .signExtend newWidth inner.bvExpr
+      let expr :=
+        mkApp3
+          (mkConst ``BVExpr.signExtend)
+          (toExpr inner.width)
+          newWidthExpr
+          inner.expr
+      let proof := do
+        let innerEval ← ReifiedBVExpr.mkEvalExpr inner.width inner.expr
+        let innerProof ← inner.evalsAtAtoms
+        return mkApp5 (mkConst ``Std.Tactic.BVDecide.Reflect.BitVec.signExtend_congr)
+          newWidthExpr
+          (toExpr inner.width)
+          innerExpr
+          innerEval
+          innerProof
+      return some ⟨newWidth, bvExpr, proof, expr⟩
+    | HAppend.hAppend _ _ _ _ lhsExpr rhsExpr =>
+      let some lhs ← goOrAtom lhsExpr | return none
+      let some rhs ← goOrAtom rhsExpr | return none
+      let bvExpr := .append lhs.bvExpr rhs.bvExpr
+      let expr := mkApp4 (mkConst ``BVExpr.append)
+        (toExpr lhs.width)
+        (toExpr rhs.width)
+        lhs.expr rhs.expr
+      let proof := do
+        let lhsEval ← ReifiedBVExpr.mkEvalExpr lhs.width lhs.expr
+        let lhsProof ← lhs.evalsAtAtoms
+        let rhsProof ← rhs.evalsAtAtoms
+        let rhsEval ← ReifiedBVExpr.mkEvalExpr rhs.width rhs.expr
+        return mkApp8 (mkConst ``Std.Tactic.BVDecide.Reflect.BitVec.append_congr)
+          (toExpr lhs.width) (toExpr rhs.width)
+          lhsExpr lhsEval
+          rhsExpr rhsEval
+          lhsProof rhsProof
+      return some ⟨lhs.width + rhs.width, bvExpr, proof, expr⟩
+    | BitVec.replicate _ nExpr innerExpr =>
+      let some inner ← goOrAtom innerExpr | return none
+      let some n ← getNatValue? nExpr | return none
+      let bvExpr := .replicate n inner.bvExpr
+      let expr := mkApp3 (mkConst ``BVExpr.replicate)
+        (toExpr inner.width)
+        (toExpr n)
+        inner.expr
+      let proof := do
+        let innerEval ← ReifiedBVExpr.mkEvalExpr inner.width inner.expr
+        let innerProof ← inner.evalsAtAtoms
+        return mkApp5 (mkConst ``Std.Tactic.BVDecide.Reflect.BitVec.replicate_congr)
+          (toExpr n)
+          (toExpr inner.width)
+          innerExpr
+          innerEval
+          innerProof
+      return some ⟨inner.width * n, bvExpr, proof, expr⟩
+    | BitVec.extractLsb' _ startExpr lenExpr innerExpr =>
+      let some start ← getNatValue? startExpr | return none
+      let some len ← getNatValue? lenExpr | return none
+      let some inner ← goOrAtom innerExpr | return none
+      let bvExpr := .extract start len inner.bvExpr
+      let expr := mkApp4 (mkConst ``BVExpr.extract)
+        (toExpr inner.width)
+        startExpr
+        lenExpr
+        inner.expr
+      let proof := do
+        let innerEval ← ReifiedBVExpr.mkEvalExpr inner.width inner.expr
+        let innerProof ← inner.evalsAtAtoms
+        return mkApp6 (mkConst ``Std.Tactic.BVDecide.Reflect.BitVec.extract_congr)
+          startExpr
+          lenExpr
+          (toExpr inner.width)
+          innerExpr
+          innerEval
+          innerProof
+      return some ⟨len, bvExpr, proof, expr⟩
+    | BitVec.rotateLeft _ innerExpr distanceExpr =>
+      rotateReflection
+        distanceExpr
+        innerExpr
+        .rotateLeft
+        ``BVUnOp.rotateLeft
+        ``Std.Tactic.BVDecide.Reflect.BitVec.rotateLeft_congr
+    | BitVec.rotateRight _ innerExpr distanceExpr =>
+      rotateReflection
+        distanceExpr
+        innerExpr
+        .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
+      let some atom ← ReifiedBVExpr.bitVecAtom x | 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
+      return some atom
+    | _ => return none
+
+  /--
+  Reify `x` or abstract it as an atom.
+  Unless this function is called on something that is not a fixed-width `BitVec` it is always going
+  to return `some`.
+  -/
+  goOrAtom (x : Expr) : LemmaM (Option ReifiedBVExpr) := do
+    let res ← go x
+    match res with
+    | some exp => return some exp
+    | none => ReifiedBVExpr.bitVecAtom x
+
+  shiftConstLikeReflection (distance : Nat) (innerExpr : Expr) (shiftOp : Nat → BVUnOp)
+      (shiftOpName : Name) (congrThm : Name) :
+      LemmaM (Option ReifiedBVExpr) := do
+    let some inner ← goOrAtom innerExpr | return none
+    let bvExpr : BVExpr inner.width := .un (shiftOp distance) inner.bvExpr
+    let expr :=
+      mkApp3
+        (mkConst ``BVExpr.un)
+        (toExpr inner.width)
+        (mkApp (mkConst shiftOpName) (toExpr distance))
+        inner.expr
+    let congrProof :=
+      mkApp
+        (mkConst congrThm)
+        (toExpr distance)
+    let proof := unaryCongrProof inner innerExpr congrProof
+    return some ⟨inner.width, bvExpr, proof, expr⟩
+
+  rotateReflection (distanceExpr : Expr) (innerExpr : Expr) (rotateOp : Nat → BVUnOp)
+      (rotateOpName : Name) (congrThm : Name) :
+      LemmaM (Option ReifiedBVExpr) := do
+    let some distance ← getNatValue? distanceExpr | return none
+    shiftConstLikeReflection distance innerExpr rotateOp rotateOpName congrThm
+
+  shiftConstReflection (β : Expr) (distanceExpr : Expr) (innerExpr : Expr) (shiftOp : Nat → BVUnOp)
+      (shiftOpName : Name) (congrThm : Name) :
+      LemmaM (Option ReifiedBVExpr) := do
+    let some distance ← ReifiedBVExpr.getNatOrBvValue? β distanceExpr | return none
+    shiftConstLikeReflection distance innerExpr shiftOp shiftOpName congrThm
+
+  shiftReflection (β : Expr) (distanceExpr : Expr) (innerExpr : Expr)
+      (shiftOp : {m n : Nat} → BVExpr m → BVExpr n → BVExpr m) (shiftOpName : Name)
+      (congrThm : Name) :
+      LemmaM (Option ReifiedBVExpr) := do
+    let_expr BitVec _ ← β | return none
+    let some inner ← goOrAtom innerExpr | return none
+    let some distance ← goOrAtom distanceExpr | return none
+    let bvExpr : BVExpr inner.width := shiftOp inner.bvExpr distance.bvExpr
+    let expr :=
+      mkApp4
+        (mkConst shiftOpName)
+        (toExpr inner.width)
+        (toExpr distance.width)
+        inner.expr
+        distance.expr
+    let congrProof :=
+      mkApp2
+        (mkConst congrThm)
+        (toExpr inner.width)
+        (toExpr distance.width)
+    let proof := binaryCongrProof inner distance innerExpr distanceExpr congrProof
+    return some ⟨inner.width, bvExpr, proof, expr⟩
+
+  binaryReflection (lhsExpr rhsExpr : Expr) (op : BVBinOp) (congrThm : Name) :
+      LemmaM (Option ReifiedBVExpr) := do
+    let some lhs ← goOrAtom lhsExpr | return none
+    let some rhs ← goOrAtom rhsExpr | return none
+    if h : rhs.width = lhs.width then
+      let bvExpr : BVExpr lhs.width := .bin lhs.bvExpr op (h ▸ rhs.bvExpr)
+      let expr := mkApp4 (mkConst ``BVExpr.bin) (toExpr lhs.width) lhs.expr (toExpr op) rhs.expr
+      let congrThm := mkApp (mkConst congrThm) (toExpr lhs.width)
+      let proof := binaryCongrProof lhs rhs lhsExpr rhsExpr congrThm
+      return some ⟨lhs.width, bvExpr, proof, expr⟩
+    else
+      return none
+
+  binaryCongrProof (lhs rhs : ReifiedBVExpr) (lhsExpr rhsExpr : Expr) (congrThm : Expr) :
+      M Expr := do
+    let lhsEval ← ReifiedBVExpr.mkEvalExpr lhs.width lhs.expr
+    let lhsProof ← lhs.evalsAtAtoms
+    let rhsProof ← rhs.evalsAtAtoms
+    let rhsEval ← ReifiedBVExpr.mkEvalExpr rhs.width rhs.expr
+    return mkApp6 congrThm lhsExpr rhsExpr lhsEval rhsEval lhsProof rhsProof
+
+  unaryReflection (innerExpr : Expr) (op : BVUnOp) (congrThm : Name) :
+      LemmaM (Option ReifiedBVExpr) := do
+    let some inner ← goOrAtom innerExpr | return none
+    let bvExpr := .un op inner.bvExpr
+    let expr := mkApp3 (mkConst ``BVExpr.un) (toExpr inner.width) (toExpr op) inner.expr
+    let proof := unaryCongrProof inner innerExpr (mkConst congrThm)
+    return some ⟨inner.width, bvExpr, proof, expr⟩
+
+  unaryCongrProof (inner : ReifiedBVExpr) (innerExpr : Expr) (congrProof : Expr) : M Expr := do
+    let innerEval ← ReifiedBVExpr.mkEvalExpr inner.width inner.expr
+    let innerProof ← inner.evalsAtAtoms
+    return mkApp4 congrProof (toExpr inner.width) innerExpr innerEval innerProof
+
+  goBvLit (x : Expr) : M (Option ReifiedBVExpr) := do
+    let some ⟨_, bvVal⟩ ← getBitVecValue? x | return ← ReifiedBVExpr.bitVecAtom x
+    ReifiedBVExpr.mkBVConst bvVal
+
+/--
+Reify an `Expr` that is a predicate about `BitVec`.
+Unless this function is called on something that is not a `Bool` it is always going to return `some`.
+-/
+partial def ReifiedBVPred.of (t : Expr) : LemmaM (Option ReifiedBVPred) := do
+  match ← go t with
+  | some pred => return some pred
+  | none => ReifiedBVPred.boolAtom t
+where
+  /--
+  Reify `t`, returns `none` if the reification procedure failed.
+  -/
+  go (t : Expr) : LemmaM (Option ReifiedBVPred) := do
+    match_expr t with
+    | BEq.beq α _ lhsExpr rhsExpr =>
+      let_expr BitVec _ := α | return none
+      binaryReflection lhsExpr rhsExpr .eq
+    | BitVec.ult _ lhsExpr rhsExpr =>
+      binaryReflection lhsExpr rhsExpr .ult
+    | BitVec.getLsbD _ subExpr idxExpr =>
+      let some sub ← ReifiedBVExpr.of subExpr | return none
+      let some idx ← getNatValue? idxExpr | return none
+      return some (← ReifiedBVPred.mkGetLsbD sub subExpr idx)
+    | _ => return none
+
+  binaryReflection (lhsExpr rhsExpr : Expr) (pred : BVBinPred) : LemmaM (Option ReifiedBVPred) := do
+    let some lhs ← ReifiedBVExpr.of lhsExpr | return none
+    let some rhs ← ReifiedBVExpr.of rhsExpr | return none
+    ReifiedBVPred.mkBinPred lhs rhs lhsExpr rhsExpr pred
+
+/--
+Reify an `Expr` that is a boolean expression containing predicates about `BitVec` as atoms.
+Unless this function is called on something that is not a `Bool` it is always going to return `some`.
+-/
+partial def ReifiedBVLogical.of (t : Expr) : LemmaM (Option ReifiedBVLogical) := do
+  goOrAtom t
+where
+  /--
+  Reify `t`, returns `none` if the reification procedure failed.
+  -/
+  go (t : Expr) : LemmaM (Option ReifiedBVLogical) := do
+    match_expr t with
+    | Bool.true => ReifiedBVLogical.mkBoolConst true
+    | Bool.false => ReifiedBVLogical.mkBoolConst false
+    | Bool.not subExpr =>
+      let some sub ← goOrAtom subExpr | return none
+      return some (← ReifiedBVLogical.mkNot sub subExpr)
+    | Bool.and lhsExpr rhsExpr => gateReflection lhsExpr rhsExpr .and
+    | Bool.xor lhsExpr rhsExpr => gateReflection lhsExpr rhsExpr .xor
+    | BEq.beq α _ lhsExpr rhsExpr =>
+      match_expr α with
+      | 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
+      let some discr ← goOrAtom discrExpr | return none
+      let some lhs ← goOrAtom lhsExpr | return none
+      let some rhs ← goOrAtom rhsExpr | return none
+      return some (← ReifiedBVLogical.mkIte discr lhs rhs discrExpr lhsExpr rhsExpr)
+    | _ => goPred t
+
+  /--
+  Reify `t` or abstract it as an atom.
+  Unless this function is called on something that is not a `Bool` it is always going to return `some`.
+  -/
+  goOrAtom (t : Expr) : LemmaM (Option ReifiedBVLogical) := do
+    match ← go t with
+    | some boolExpr => return some boolExpr
+    | none => ReifiedBVLogical.boolAtom t
+
+  gateReflection (lhsExpr rhsExpr : Expr) (gate : Gate) :
+      LemmaM (Option ReifiedBVLogical) := do
+    let some lhs ← goOrAtom lhsExpr | return none
+    let some rhs ← goOrAtom rhsExpr | return none
+    ReifiedBVLogical.mkGate lhs rhs lhsExpr rhsExpr gate
+
+  goPred (t : Expr) : LemmaM (Option ReifiedBVLogical) := do
+    let some pred ← ReifiedBVPred.of t | return none
+    ReifiedBVLogical.ofPred pred
+
+end
+
+end Frontend
+end Lean.Elab.Tactic.BVDecide

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

@@ -4,7 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE.
 Authors: Henrik Böving
 -/
 prelude
-import Lean.Elab.Tactic.BVDecide.Frontend.BVDecide.ReifiedBVLogical
+import Lean.Elab.Tactic.BVDecide.Frontend.BVDecide.Reify
 
 /-!
 This module is the main entry point for reifying `BitVec` problems with boolean substructure.
@@ -19,29 +19,12 @@ namespace Frontend
 open Lean.Meta
 open Std.Tactic.BVDecide
 
-/--
-A reified version of an `Expr` representing a `BVLogicalExpr` that we know to be true.
--/
-structure SatAtBVLogical where
-  /--
-  The reified expression.
-  -/
-  bvExpr : BVLogicalExpr
-  /--
-  A proof that `bvExpr.eval atomsAssignment = true`.
-  -/
-  satAtAtoms : M Expr
-  /--
-  A cache for `toExpr bvExpr`
-  -/
-  expr : Expr
-
 namespace SatAtBVLogical
 
 /--
 Reify an `Expr` that is a proof of some boolean structure on top of predicates about `BitVec`s.
 -/
-partial def of (h : Expr) : M (Option SatAtBVLogical) := do
+partial def of (h : Expr) : LemmaM (Option SatAtBVLogical) := do
   let t ← instantiateMVars (← whnfR (← inferType h))
   match_expr t with
   | Eq α lhsExpr rhsExpr =>

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

@@ -128,6 +128,8 @@ builtin_simproc [bv_normalize] bv_add_const' (((_ : BitVec _) + (_ : BitVec _))
       else
         return .continue
 
+attribute [builtin_bv_normalize_proc↓] reduceIte
+
 /--
 A pass in the normalization pipeline. Takes the current goal and produces a refined one or closes
 the goal fully, indicated by returning `none`.

src/Lean/Elab/Tactic/BuiltinTactic.lean

@@ -266,15 +266,16 @@ private def getOptRotation (stx : Syntax) : Nat :=
   for mvarId in mvarIds do
     unless (← mvarId.isAssigned) do
       setGoals [mvarId]
-      try
-        evalTactic stx[1]
-        mvarIdsNew := mvarIdsNew ++ (← getUnsolvedGoals)
-      catch ex =>
-        if (← read).recover then
-          logException ex
-          mvarIdsNew := mvarIdsNew.push mvarId
-        else
-          throw ex
+      mvarIdsNew ← Tactic.tryCatch
+        (do
+          evalTactic stx[1]
+          return mvarIdsNew ++ (← getUnsolvedGoals))
+        (fun ex => do
+          if (← read).recover then
+            logException ex
+            return mvarIdsNew.push mvarId
+          else
+            throw ex)
   setGoals mvarIdsNew.toList
 
 @[builtin_tactic Parser.Tactic.anyGoals] def evalAnyGoals : Tactic := fun stx => do

src/Lean/Elab/Tactic/Calc.lean

@@ -12,25 +12,38 @@ open Meta
 
 /-- Elaborator for the `calc` tactic mode variant. -/
 @[builtin_tactic Lean.calcTactic]
-def evalCalc : Tactic := fun stx => withMainContext do
-  let steps : TSyntax ``calcSteps := ⟨stx[1]⟩
-  let target := (← getMainTarget).consumeMData
-  let tag ← getMainTag
-  let (val, mvarIds) ← withCollectingNewGoalsFrom (parentTag := tag) (tagSuffix := `calc) do
-    runTermElab do
-    let mut val ← Term.elabCalcSteps steps
-    let mut valType ← instantiateMVars (← inferType val)
-    unless (← isDefEq valType target) do
-      let rec throwFailed :=
-        throwError "'calc' tactic failed, has type{indentExpr valType}\nbut it is expected to have type{indentExpr target}"
-      let some (_, _, rhs) ← Term.getCalcRelation? valType | throwFailed
-      let some (r, _, rhs') ← Term.getCalcRelation? target | throwFailed
-      let lastStep := mkApp2 r rhs rhs'
-      let lastStepGoal ← mkFreshExprSyntheticOpaqueMVar lastStep (tag := tag ++ `calc.step)
-      (val, valType) ← Term.mkCalcTrans val valType lastStepGoal lastStep
-      unless (← isDefEq valType target) do throwFailed
-    return val
-  (← getMainGoal).assign val
-  replaceMainGoal mvarIds
+def evalCalc : Tactic
+  | `(tactic| calc%$tk $steps:calcSteps) =>
+    withRef tk do
+    closeMainGoalUsing `calc (checkNewUnassigned := false) fun target tag => do
+    withTacticInfoContext steps do
+      let steps ← Term.mkCalcStepViews steps
+      let target := (← instantiateMVars target).consumeMData
+      let (val, mvarIds) ← withCollectingNewGoalsFrom (parentTag := tag) (tagSuffix := `calc) <| runTermElab do
+        let (val, valType) ← Term.elabCalcSteps steps
+        if (← isDefEq valType target) then
+          -- Immediately the right type, no need for further processing.
+          return val
+
+        let some (_, lhs, rhs) ← Term.getCalcRelation? valType | unreachable!
+        if let some (er, elhs, erhs) ← Term.getCalcRelation? target then
+          -- Feature: if the goal is `x ~ y`, try extending the `calc` with `_ ~ y` with a new "last step" goal.
+          if ← isDefEq lhs elhs <&&> isDefEq (← inferType rhs) (← inferType elhs) then
+            let lastStep := mkApp2 er rhs erhs
+            let lastStepGoal ← mkFreshExprSyntheticOpaqueMVar lastStep (tag := tag ++ `calc.step)
+            try
+              let (val', valType') ← Term.mkCalcTrans val valType lastStepGoal lastStep
+              if (← isDefEq valType' target) then
+                return val'
+            catch _ =>
+              pure ()
+
+        -- Calc extension failed, so let's go back and mimick the `calc` expression
+        Term.ensureHasTypeWithErrorMsgs target val
+          (mkImmedErrorMsg := fun _ => Term.throwCalcFailure steps)
+          (mkErrorMsg := fun _ => Term.throwCalcFailure steps)
+      pushGoals mvarIds
+      return val
+  | _ => throwUnsupportedSyntax
 
 end Lean.Elab.Tactic

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

@@ -23,6 +23,55 @@ private def isImplies (e : Expr) : MetaM Bool :=
   else
     return false
 
+private partial def mkCongrThm (origTag : Name) (f : Expr) (args : Array Expr) (addImplicitArgs := false) (nameSubgoals := true) :
+    MetaM (Expr × Array (Option MVarId) × Array (Option MVarId)) := do
+  let funInfo ← getFunInfoNArgs f args.size
+  let some congrThm ← mkCongrSimpCore? f funInfo (← getCongrSimpKinds f funInfo) (subsingletonInstImplicitRhs := false)
+    | throwError "'congr' conv tactic failed to create congruence theorem"
+  let mut eNew := f
+  let mut proof := congrThm.proof
+  let mut mvarIdsNew := #[]
+  let mut mvarIdsNewInsts := #[]
+  for h : i in [:congrThm.argKinds.size] do
+    let arg := args[i]!
+    let argInfo := funInfo.paramInfo[i]!
+    match congrThm.argKinds[i] with
+    | .fixed | .cast =>
+      eNew := mkApp eNew arg
+      proof := mkApp proof arg;
+      if addImplicitArgs || argInfo.isExplicit then
+        mvarIdsNew := mvarIdsNew.push none
+    | .eq =>
+      if addImplicitArgs || argInfo.isExplicit then
+        let tag ← if nameSubgoals then
+          pure (appendTag origTag (← whnf (← inferType proof)).bindingName!)
+        else pure origTag
+        let (rhs, mvarNew) ← mkConvGoalFor arg tag
+        eNew := mkApp eNew rhs
+        proof := mkApp3 proof arg rhs mvarNew
+        mvarIdsNew := mvarIdsNew.push (some mvarNew.mvarId!)
+      else
+        eNew := mkApp eNew arg
+        proof := mkApp3 proof arg arg (← mkEqRefl arg)
+    | .subsingletonInst =>
+      proof := mkApp proof arg
+      let rhs ← mkFreshExprMVar (← whnf (← inferType proof)).bindingDomain!
+      eNew := mkApp eNew rhs
+      proof := mkApp proof rhs
+      mvarIdsNewInsts := mvarIdsNewInsts.push (some rhs.mvarId!)
+    | .heq | .fixedNoParam => unreachable!
+  if congrThm.argKinds.size < args.size then
+    if congrThm.argKinds.size == 0 then
+      throwError "'congr' conv tactic failed to create congruence theorem"
+    let (proof', mvarIdsNew', mvarIdsNewInsts') ←
+      mkCongrThm origTag eNew args[funInfo.getArity:] addImplicitArgs nameSubgoals
+    for arg in args[funInfo.getArity:] do
+      proof ← Meta.mkCongrFun proof arg
+    proof ← mkEqTrans proof proof'
+    mvarIdsNew := mvarIdsNew ++ mvarIdsNew'
+    mvarIdsNewInsts := mvarIdsNewInsts ++ mvarIdsNewInsts'
+  return (proof, mvarIdsNew, mvarIdsNewInsts)
+
 def congr (mvarId : MVarId) (addImplicitArgs := false) (nameSubgoals := true) :
     MetaM (List (Option MVarId)) := mvarId.withContext do
   let origTag ← mvarId.getTag
@@ -31,39 +80,8 @@ def congr (mvarId : MVarId) (addImplicitArgs := false) (nameSubgoals := true) :
   if (← isImplies lhs) then
     return (← congrImplies mvarId).map Option.some
   else if lhs.isApp then
-    let funInfo ← getFunInfo lhs.getAppFn
-    let args := lhs.getAppArgs
-    let some congrThm ← mkCongrSimp? lhs.getAppFn (subsingletonInstImplicitRhs := false)
-      | throwError "'congr' conv tactic failed to create congruence theorem"
-    unless args.size == congrThm.argKinds.size do
-      throwError "'congr' conv tactic failed, unexpected number of arguments in congruence theorem"
-    let mut proof := congrThm.proof
-    let mut mvarIdsNew := #[]
-    let mut mvarIdsNewInsts := #[]
-    for i in [:args.size] do
-      let arg := args[i]!
-      let argInfo := funInfo.paramInfo[i]!
-      match congrThm.argKinds[i]! with
-      | .fixed | .cast =>
-        proof := mkApp proof arg;
-        if addImplicitArgs || argInfo.isExplicit then
-          mvarIdsNew := mvarIdsNew.push none
-      | .eq    =>
-        if addImplicitArgs || argInfo.isExplicit then
-          let tag ← if nameSubgoals then
-            pure (appendTag origTag (← whnf (← inferType proof)).bindingName!)
-          else pure origTag
-          let (rhs, mvarNew) ← mkConvGoalFor arg tag
-          proof := mkApp3 proof arg rhs mvarNew
-          mvarIdsNew := mvarIdsNew.push (some mvarNew.mvarId!)
-        else
-          proof := mkApp3 proof arg arg (← mkEqRefl arg)
-      | .subsingletonInst =>
-        proof := mkApp proof arg
-        let rhs ← mkFreshExprMVar (← whnf (← inferType proof)).bindingDomain!
-        proof := mkApp proof rhs
-        mvarIdsNewInsts := mvarIdsNewInsts.push (some rhs.mvarId!)
-      | .heq | .fixedNoParam => unreachable!
+    let (proof, mvarIdsNew, mvarIdsNewInsts) ←
+      mkCongrThm origTag lhs.getAppFn lhs.getAppArgs addImplicitArgs nameSubgoals
     let some (_, _, rhs') := (← whnf (← inferType proof)).eq? | throwError "'congr' conv tactic failed, equality expected"
     unless (← isDefEqGuarded rhs rhs') do
       throwError "invalid 'congr' conv tactic, failed to resolve{indentExpr rhs}\n=?={indentExpr rhs'}"

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

@@ -119,7 +119,7 @@ private def pre (pattern : AbstractMVarsResult) (state : IO.Ref PatternMatchStat
         let ids ← ids.mapIdxM fun i id =>
           match id.getNat with
           | 0 => throwErrorAt id "positive integer expected"
-          | n+1 => pure (n, i.1)
+          | n+1 => pure (n, i)
         let ids := ids.qsort (·.1 < ·.1)
         unless @Array.allDiff _ ⟨(·.1 == ·.1)⟩ ids do
           throwError "occurrence list is not distinct"

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

@@ -12,13 +12,16 @@ open Meta
 
 @[builtin_tactic Lean.Parser.Tactic.Conv.unfold] def evalUnfold : Tactic := fun stx => withMainContext do
   for declNameId in stx[1].getArgs do
-    let e ← elabTermForApply declNameId (mayPostpone := false)
-    match e with
-    | .const declName _ =>
-      applySimpResult (← unfold (← getLhs) declName)
-    | .fvar declFVarId =>
-      let lhs ← instantiateMVars (← getLhs)
-      changeLhs (← Meta.zetaDeltaFVars lhs #[declFVarId])
-    | _ => throwErrorAt declNameId m!"'unfold' conv tactic failed, expression {e} is not a global or local constant"
+    withRef declNameId do
+      let e ← withoutRecover <| elabTermForApply declNameId (mayPostpone := false)
+      match e with
+      | .const declName _ =>
+        applySimpResult (← unfold (← getLhs) declName)
+      | .fvar declFVarId =>
+        unless ← declFVarId.isLetVar do
+          throwError "conv tactic 'unfold' failed, local variable '{Expr.fvar declFVarId}' has no definition"
+        let lhs ← instantiateMVars (← getLhs)
+        changeLhs (← Meta.zetaDeltaFVars lhs #[declFVarId])
+      | _ => throwError "conv tactic 'unfold' failed, expression {e} is not a global or local constant"
 
 end Lean.Elab.Tactic.Conv

src/Lean/Elab/Tactic/ElabTerm.lean

@@ -257,45 +257,11 @@ def elabTermForApply (stx : Syntax) (mayPostpone := true) : TacticM Expr := do
     match (← Term.resolveId? stx (withInfo := true)) with
     | some e => return e
     | _      => pure ()
-  /-
-    By disabling the "error recovery" (and consequently "error to sorry") feature,
-    we make sure an `apply e` fails without logging an error message.
-    The motivation is that `apply` is frequently used when writing tactic such as
-    ```
-    cases h <;> intro h' <;> first | apply t[h'] | ....
-    ```
-    Here the type of `h'` may be different in each case, and the term `t[h']` containing `h'` may even fail to
-    be elaborated in some cases. When this happens we want the tactic to fail without reporting any error to the user,
-    and the next tactic is tried.
+  elabTerm stx none mayPostpone
 
-    A drawback of disabling "error to sorry" is that there is no error recovery after the error is thrown, and features such
-    as auto-completion are affected.
-
-    By disabling "error to sorry", we also limit ourselves to at most one error at `t[h']`.
-
-    By disabling "error to sorry", we also miss the opportunity to catch mistakes in tactic code such as
-      `first | apply nonsensical-term | assumption`
-
-    This should not be a big problem for the `apply` tactic since we usually provide small terms there.
-
-    Note that we do not disable "error to sorry" at `exact` and `refine` since they are often used to elaborate big terms,
-    and we do want error recovery there, and we want to see the error messages.
-
-    We should probably provide options for allowing users to control this behavior.
-
-    see issue #1037
-
-    More complex solution:
-      - We do not disable "error to sorry"
-      - We elaborate term and check whether errors were produced
-      - If there are other tactic branches and there are errors, we remove the errors from the log, and throw a new error to force the tactic to backtrack.
-  -/
-  withoutRecover <| elabTerm stx none mayPostpone
-
-def getFVarId (id : Syntax) : TacticM FVarId := withRef id do
+def getFVarId (id : Syntax) : TacticM FVarId := withRef id <| withMainContext do
   -- use apply-like elaboration to suppress insertion of implicit arguments
-  let e ← withMainContext do
-    elabTermForApply id (mayPostpone := false)
+  let e ← withoutRecover <| elabTermForApply id (mayPostpone := false)
   match e with
   | Expr.fvar fvarId => return fvarId
   | _                => throwError "unexpected term '{e}'; expected single reference to variable"
@@ -452,7 +418,7 @@ where
       if r.isAppOf ``isTrue then
         return m!"\
           tactic '{tacticName}' failed. internal error: the elaborator is able to reduce the \
-          '{MessageData.ofConstName ``Decidable}' instance, but the kernel is not able to"
+          '{.ofConstName ``Decidable}' instance, but the kernel is not able to"
       else if r.isAppOf ``isFalse then
         return m!"\
           tactic '{tacticName}' proved that the proposition\
@@ -466,42 +432,42 @@ where
         let unfoldedInsts ← unfolded |>.qsort Name.lt |>.filterMapM fun n => do
           let e ← mkConstWithLevelParams n
           if (← Meta.isClass? (← inferType e)) == ``Decidable then
-            return m!"'{MessageData.ofConst e}'"
+            return m!"'{.ofConst e}'"
           else
             return none
         return (reason, unfoldedInsts)
       let stuckMsg :=
         if unfoldedInsts.isEmpty then
-          m!"Reduction got stuck at the '{MessageData.ofConstName ``Decidable}' instance{indentExpr reason}"
+          m!"Reduction got stuck at the '{.ofConstName ``Decidable}' instance{indentExpr reason}"
         else
           let instances := if unfoldedInsts.size == 1 then "instance" else "instances"
-          m!"After unfolding the {instances} {MessageData.andList unfoldedInsts.toList}, \
-          reduction got stuck at the '{MessageData.ofConstName ``Decidable}' instance{indentExpr reason}"
+          m!"After unfolding the {instances} {.andList unfoldedInsts.toList}, \
+          reduction got stuck at the '{.ofConstName ``Decidable}' instance{indentExpr reason}"
       let hint :=
         if reason.isAppOf ``Eq.rec then
           m!"\n\n\
-          Hint: Reduction got stuck on '▸' ({MessageData.ofConstName ``Eq.rec}), \
-          which suggests that one of the '{MessageData.ofConstName ``Decidable}' instances is defined using tactics such as 'rw' or 'simp'. \
+          Hint: Reduction got stuck on '▸' ({.ofConstName ``Eq.rec}), \
+          which suggests that one of the '{.ofConstName ``Decidable}' instances is defined using tactics such as 'rw' or 'simp'. \
           To avoid tactics, make use of functions such as \
-          '{MessageData.ofConstName ``inferInstanceAs}' or '{MessageData.ofConstName ``decidable_of_decidable_of_iff}' \
+          '{.ofConstName ``inferInstanceAs}' or '{.ofConstName ``decidable_of_decidable_of_iff}' \
           to alter a proposition."
         else if reason.isAppOf ``Classical.choice then
           m!"\n\n\
-          Hint: Reduction got stuck on '{MessageData.ofConstName ``Classical.choice}', \
-          which indicates that a '{MessageData.ofConstName ``Decidable}' instance \
+          Hint: Reduction got stuck on '{.ofConstName ``Classical.choice}', \
+          which indicates that a '{.ofConstName ``Decidable}' instance \
           is defined using classical reasoning, proving an instance exists rather than giving a concrete construction. \
           The '{tacticName}' tactic works by evaluating a decision procedure via reduction, \
           and it cannot make progress with such instances. \
           This can occur due to the 'opened scoped Classical' command, which enables the instance \
-          '{MessageData.ofConstName ``Classical.propDecidable}'."
+          '{.ofConstName ``Classical.propDecidable}'."
         else
           MessageData.nil
       return m!"\
         tactic '{tacticName}' failed for proposition\
         {indentExpr expectedType}\n\
-        since its '{MessageData.ofConstName ``Decidable}' instance\
+        since its '{.ofConstName ``Decidable}' instance\
         {indentExpr s}\n\
-        did not reduce to '{MessageData.ofConstName ``isTrue}' or '{MessageData.ofConstName ``isFalse}'.\n\n\
+        did not reduce to '{.ofConstName ``isTrue}' or '{.ofConstName ``isFalse}'.\n\n\
         {stuckMsg}{hint}"
 
 @[builtin_tactic Lean.Parser.Tactic.decide] def evalDecide : Tactic := fun _ =>

src/Lean/Elab/Tactic/Ext.lean

@@ -123,12 +123,10 @@ def realizeExtTheorem (structName : Name) (flat : Bool) : Elab.Command.CommandEl
           levelParams := info.levelParams
         }
         modifyEnv fun env => addProtected env extName
-        Lean.addDeclarationRanges extName {
-          range := ← getDeclarationRange (← getRef)
-          selectionRange := ← getDeclarationRange (← getRef) }
+        addDeclarationRangesFromSyntax extName (← getRef)
     catch e =>
       throwError m!"\
-        Failed to generate an 'ext' theorem for '{MessageData.ofConstName structName}': {e.toMessageData}"
+        Failed to generate an 'ext' theorem for '{.ofConstName structName}': {e.toMessageData}"
   return extName
 
 /--
@@ -163,12 +161,10 @@ def realizeExtIffTheorem (extName : Name) : Elab.Command.CommandElabM Name := do
         -- Only declarations in a namespace can be protected:
         unless extIffName.isAtomic do
           modifyEnv fun env => addProtected env extIffName
-        Lean.addDeclarationRanges extIffName {
-          range := ← getDeclarationRange (← getRef)
-          selectionRange := ← getDeclarationRange (← getRef) }
+        addDeclarationRangesFromSyntax extName (← getRef)
     catch e =>
       throwError m!"\
-        Failed to generate an 'ext_iff' theorem from '{MessageData.ofConstName extName}': {e.toMessageData}\n\
+        Failed to generate an 'ext_iff' theorem from '{.ofConstName extName}': {e.toMessageData}\n\
         \n\
         Try '@[ext (iff := false)]' to prevent generating an 'ext_iff' theorem."
   return extIffName

src/Lean/Elab/Tactic/Generalize.lean

@@ -30,7 +30,7 @@ open Meta
       args := args.push { hName?, expr, xName? := arg[3].getId : GeneralizeArg }
     let hyps ← match expandOptLocation stx[2] with
     | .targets hyps _ => getFVarIds hyps
-    | .wildcard => pure (← getLCtx).getFVarIds
+    | .wildcard => pure ((← getLocalHyps).map (·.fvarId!))
     let mvarId ← getMainGoal
     mvarId.withContext do
       let (_, newVars, mvarId) ← mvarId.generalizeHyp args hyps

src/Lean/Elab/Tactic/Simp.lean

@@ -119,17 +119,22 @@ private def addDeclToUnfoldOrTheorem (thms : SimpTheorems) (id : Origin) (e : Ex
     thms.add id #[] e (post := post) (inv := inv)
 
 private def addSimpTheorem (thms : SimpTheorems) (id : Origin) (stx : Syntax) (post : Bool) (inv : Bool) : TermElabM SimpTheorems := do
-  let (levelParams, proof) ← Term.withoutModifyingElabMetaStateWithInfo <| withRef stx <| Term.withoutErrToSorry do
+  let thm? ← Term.withoutModifyingElabMetaStateWithInfo <| withRef stx do
     let e ← Term.elabTerm stx none
     Term.synthesizeSyntheticMVars (postpone := .no) (ignoreStuckTC := true)
     let e ← instantiateMVars e
+    if e.hasSyntheticSorry then
+      return none
     let e := e.eta
     if e.hasMVar then
       let r ← abstractMVars e
-      return (r.paramNames, r.expr)
+      return some (r.paramNames, r.expr)
     else
-      return (#[], e)
-  thms.add id levelParams proof (post := post) (inv := inv)
+      return some (#[], e)
+  if let some (levelParams, proof) := thm? then
+    thms.add id levelParams proof (post := post) (inv := inv)
+  else
+    return thms
 
 structure ElabSimpArgsResult where
   ctx      : Simp.Context
@@ -167,7 +172,7 @@ def elabSimpArgs (stx : Syntax) (ctx : Simp.Context) (simprocs : Simp.SimprocsAr
 
     syntax simpErase := "-" ident
     -/
-    withMainContext do
+    let go := withMainContext do
       let mut thmsArray := ctx.simpTheorems
       let mut thms      := thmsArray[0]!
       let mut simprocs  := simprocs
@@ -230,6 +235,12 @@ def elabSimpArgs (stx : Syntax) (ctx : Simp.Context) (simprocs : Simp.SimprocsAr
           else
             throw ex
       return { ctx := { ctx with simpTheorems := thmsArray.set! 0 thms }, simprocs, starArg }
+    -- If recovery is disabled, then we want simp argument elaboration failures to be exceptions.
+    -- This affects `addSimpTheorem`.
+    if (← read).recover then
+      go
+    else
+      Term.withoutErrToSorry go
 where
   isSimproc? (e : Expr) : MetaM (Option Name) := do
     let .const declName _ := e | return none

src/Lean/Elab/Tactic/Unfold.lean

@@ -29,13 +29,15 @@ def zetaDeltaTarget (declFVarId : FVarId) : TacticM Unit := do
   for declNameId in stx[1].getArgs do
     go declNameId loc
 where
-  go (declNameId : Syntax) (loc : Location) : TacticM Unit := withMainContext do
-    let e ← elabTermForApply declNameId (mayPostpone := false)
+  go (declNameId : Syntax) (loc : Location) : TacticM Unit := withMainContext <| withRef declNameId do
+    let e ← withoutRecover <| elabTermForApply declNameId (mayPostpone := false)
     match e with
     | .const declName _ =>
       withLocation loc (unfoldLocalDecl declName) (unfoldTarget declName) (throwTacticEx `unfold · m!"did not unfold '{declName}'")
     | .fvar declFVarId =>
+      unless ← declFVarId.isLetVar do
+        throwError "tactic 'unfold' failed, local variable '{Expr.fvar declFVarId}' has no definition"
       withLocation loc (zetaDeltaLocalDecl declFVarId) (zetaDeltaTarget declFVarId) (throwTacticEx `unfold · m!"did not unfold '{e}'")
-    | _ => withRef declNameId <| throwTacticEx `unfold (← getMainGoal) m!"expression {e} is not a global or local constant"
+    | _ => throwTacticEx `unfold (← getMainGoal) m!"expression {e} is not a global or local constant"
 
 end Lean.Elab.Tactic

src/Lean/Elab/Term.lean

@@ -46,11 +46,17 @@ inductive SyntheticMVarKind where
   regarding type class synthesis failure.
   -/
   | typeClass (extraErrorMsg? : Option MessageData)
-  /-- Use coercion to synthesize value for the metavariable.
-  if `f?` is `some f`, we produce an application type mismatch error message.
-  Otherwise, if `header?` is `some header`, we generate the error `(header ++ "has type" ++ eType ++ "but it is expected to have type" ++ expectedType)`
-  Otherwise, we generate the error `("type mismatch" ++ e ++ "has type" ++ eType ++ "but it is expected to have type" ++ expectedType)` -/
+  /--
+  Use coercion to synthesize value for the metavariable.
+  If synthesis fails, then throws an error.
+  - If `mkErrorMsg?` is provided, then the error `mkErrorMsg expectedType e` is thrown.
+    The `mkErrorMsg` function is allowed to throw an error itself.
+  - Otherwise, throws a default type mismatch error message.
+    If `header?` is not provided, the default header is "type mismatch".
+    If `f?` is provided, then throws an application type mismatch error.
+  -/
   | coe (header? : Option String) (expectedType : Expr) (e : Expr) (f? : Option Expr)
+      (mkErrorMsg? : Option (MVarId → Expr → Expr → MetaM MessageData))
   /-- Use tactic to synthesize value for metavariable. -/
   | tactic (tacticCode : Syntax) (ctx : SavedContext) (kind : TacticMVarKind)
   /-- Metavariable represents a hole whose elaboration has been postponed. -/
@@ -914,7 +920,9 @@ private def applyAttributesCore
   Remark: if the declaration has syntax errors, `declName` may be `.anonymous` see issue #4309
   In this case, we skip attribute application.
   -/
-  unless declName == .anonymous do
+  if declName == .anonymous then
+    return
+  withDeclName declName do
     for attr in attrs do
       withRef attr.stx do withLogging do
       let env ← getEnv
@@ -947,14 +955,14 @@ def applyAttributesAt (declName : Name) (attrs : Array Attribute) (applicationTi
 def applyAttributes (declName : Name) (attrs : Array Attribute) : TermElabM Unit :=
   applyAttributesCore declName attrs none
 
-def mkTypeMismatchError (header? : Option MessageData) (e : Expr) (eType : Expr) (expectedType : Expr) : TermElabM MessageData := do
+def mkTypeMismatchError (header? : Option MessageData) (e : Expr) (eType : Expr) (expectedType : Expr) : MetaM MessageData := do
   let header : MessageData := match header? with
     | some header => m!"{header} "
     | none        => m!"type mismatch{indentExpr e}\n"
   return m!"{header}{← mkHasTypeButIsExpectedMsg eType expectedType}"
 
 def throwTypeMismatchError (header? : Option MessageData) (expectedType : Expr) (eType : Expr) (e : Expr)
-    (f? : Option Expr := none) (_extraMsg? : Option MessageData := none) : TermElabM α := do
+    (f? : Option Expr := none) (_extraMsg? : Option MessageData := none) : MetaM α := do
   /-
     We ignore `extraMsg?` for now. In all our tests, it contained no useful information. It was
     always of the form:
@@ -1071,7 +1079,9 @@ def synthesizeInstMVarCore (instMVar : MVarId) (maxResultSize? : Option Nat := n
     else
       throwError "failed to synthesize{indentExpr type}{extraErrorMsg}{useDiagnosticMsg}"
 
-def mkCoe (expectedType : Expr) (e : Expr) (f? : Option Expr := none) (errorMsgHeader? : Option String := none) : TermElabM Expr := do
+def mkCoe (expectedType : Expr) (e : Expr) (f? : Option Expr := none) (errorMsgHeader? : Option String := none)
+    (mkErrorMsg? : Option (MVarId → (expectedType e : Expr) → MetaM MessageData) := none)
+    (mkImmedErrorMsg? : Option ((errorMsg? : Option MessageData) → (expectedType e : Expr) → MetaM MessageData) := none) : TermElabM Expr := do
   withTraceNode `Elab.coe (fun _ => return m!"adding coercion for {e} : {← inferType e} =?= {expectedType}") do
   try
     withoutMacroStackAtErr do
@@ -1080,11 +1090,24 @@ def mkCoe (expectedType : Expr) (e : Expr) (f? : Option Expr := none) (errorMsgH
       | .none => failure
       | .undef =>
         let mvarAux ← mkFreshExprMVar expectedType MetavarKind.syntheticOpaque
-        registerSyntheticMVarWithCurrRef mvarAux.mvarId! (.coe errorMsgHeader? expectedType e f?)
+        registerSyntheticMVarWithCurrRef mvarAux.mvarId! (.coe errorMsgHeader? expectedType e f? mkErrorMsg?)
         return mvarAux
   catch
-    | .error _ msg => throwTypeMismatchError errorMsgHeader? expectedType (← inferType e) e f? msg
-    | _            => throwTypeMismatchError errorMsgHeader? expectedType (← inferType e) e f?
+    | .error _ msg =>
+      if let some mkImmedErrorMsg := mkImmedErrorMsg? then
+        throwError (← mkImmedErrorMsg msg expectedType e)
+      else
+        throwTypeMismatchError errorMsgHeader? expectedType (← inferType e) e f? msg
+    | _            =>
+      if let some mkImmedErrorMsg := mkImmedErrorMsg? then
+        throwError (← mkImmedErrorMsg none expectedType e)
+      else
+        throwTypeMismatchError errorMsgHeader? expectedType (← inferType e) e f?
+
+def mkCoeWithErrorMsgs (expectedType : Expr) (e : Expr)
+    (mkImmedErrorMsg : (errorMsg? : Option MessageData) → (expectedType e : Expr) → MetaM MessageData)
+    (mkErrorMsg : MVarId → (expectedType e : Expr) → MetaM MessageData) : TermElabM Expr := do
+  mkCoe expectedType e (mkImmedErrorMsg? := mkImmedErrorMsg) (mkErrorMsg? := mkErrorMsg)
 
 /--
 If `expectedType?` is `some t`, then ensures `t` and `eType` are definitionally equal by inserting a coercion if necessary.
@@ -1099,6 +1122,15 @@ def ensureHasType (expectedType? : Option Expr) (e : Expr)
   else
     mkCoe expectedType e f? errorMsgHeader?
 
+def ensureHasTypeWithErrorMsgs (expectedType? : Option Expr) (e : Expr)
+    (mkImmedErrorMsg : (errorMsg? : Option MessageData) → (expectedType e : Expr) → MetaM MessageData)
+    (mkErrorMsg : MVarId → (expectedType e : Expr) → MetaM MessageData) : TermElabM Expr := do
+  let some expectedType := expectedType? | return e
+  if (← isDefEq (← inferType e) expectedType) then
+    return e
+  else
+    mkCoeWithErrorMsgs expectedType e mkImmedErrorMsg mkErrorMsg
+
 /--
   Create a synthetic sorry for the given expected type. If `expectedType? = none`, then a fresh
   metavariable is created to represent the type.

src/Lean/Exception.lean

@@ -71,7 +71,7 @@ protected def throwError [Monad m] [MonadError m] (msg : MessageData) : m α :=
 
 /-- Throw an unknown constant error message. -/
 def throwUnknownConstant [Monad m] [MonadError m] (constName : Name) : m α :=
-  Lean.throwError m!"unknown constant '{mkConst constName}'"
+  Lean.throwError m!"unknown constant '{.ofConstName constName}'"
 
 /-- Throw an error exception using the given message data and reference syntax. -/
 protected def throwErrorAt [Monad m] [MonadError m] (ref : Syntax) (msg : MessageData) : m α := do
@@ -81,10 +81,10 @@ protected def throwErrorAt [Monad m] [MonadError m] (ref : Syntax) (msg : Messag
 Convert an `Except` into a `m` monadic action, where `m` is any monad that
 implements `MonadError`.
 -/
-def ofExcept [Monad m] [MonadError m] [ToString ε] (x : Except ε α) : m α :=
+def ofExcept [Monad m] [MonadError m] [ToMessageData ε] (x : Except ε α) : m α :=
   match x with
   | .ok a    => return a
-  | .error e => Lean.throwError <| toString e
+  | .error e => Lean.throwError <| toMessageData e
 
 /--
 Throw an error exception for the given kernel exception.