mirror of
https://github.com/leanprover/lean4.git
synced 2026-03-18 19:04:07 +00:00
Compare commits
74 Commits
deprecate_
...
array_atta
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
e1fcd9ac52 | ||
|
|
87f94f2297 | ||
|
|
287dc6de43 | ||
|
|
5eef3d27fb | ||
|
|
75d1504af2 | ||
|
|
a00cf6330f | ||
|
|
1f32477385 | ||
|
|
91c14c7ee9 | ||
|
|
69530afdf9 | ||
|
|
b7667c1604 | ||
|
|
d6f898001b | ||
|
|
a38566693b | ||
|
|
4bef3588b5 | ||
|
|
64538cf6e8 | ||
|
|
aadf3f1d2c | ||
|
|
95bf45ff8b | ||
|
|
2a02c121cf | ||
|
|
4600bb16fc | ||
|
|
7ccdfc30ff | ||
|
|
7f0bdefb6e | ||
|
|
799b2b6628 | ||
|
|
b8d6e44c4f | ||
|
|
5a99cb326c | ||
|
|
e10fac93a6 | ||
|
|
62ae320e1c | ||
|
|
98b1edfc1f | ||
|
|
ab162b3f52 | ||
|
|
b8a13ab755 | ||
|
|
405593ea28 | ||
|
|
24f305c0e3 | ||
|
|
5d553d6369 | ||
|
|
a449e3fdd6 | ||
|
|
764386734c | ||
|
|
7f1d7a595b | ||
|
|
f13e5ca852 | ||
|
|
ecbaeff24b | ||
|
|
691acde696 | ||
|
|
b1e0c1b594 | ||
|
|
93b4ec0351 | ||
|
|
f06fc30c0b | ||
|
|
64b35a8c19 | ||
|
|
688ee4c887 | ||
|
|
9a3dd615e0 | ||
|
|
7e6363dc05 | ||
|
|
a074bd9a2b | ||
|
|
498d41633b | ||
|
|
e0d7c3ac79 | ||
|
|
6a5b122b40 | ||
|
|
bf9ddf2c74 | ||
|
|
3f47871e73 | ||
|
|
85f25967ea | ||
|
|
8e1ddbc5aa | ||
|
|
e6e39f502f | ||
|
|
debb82bc20 | ||
|
|
9a85433477 | ||
|
|
4616c0ac3e | ||
|
|
e55b681774 | ||
|
|
63132105ba | ||
|
|
350b36411c | ||
|
|
1c30c76e72 | ||
|
|
d5adadc00e | ||
|
|
f08805e5c4 | ||
|
|
256b49bda9 | ||
|
|
28cf146d00 | ||
|
|
970261b1e1 | ||
|
|
6b811f8c92 | ||
|
|
f721f94045 | ||
|
|
86524d5c23 | ||
|
|
f18d9e04bc | ||
|
|
fa33423c84 | ||
|
|
1315266dd3 | ||
|
|
b1e52f1475 | ||
|
|
985600f448 | ||
|
|
ace6248e20 |
2
.github/workflows/pr-body.yml
vendored
2
.github/workflows/pr-body.yml
vendored
@@ -1,6 +1,7 @@
|
||||
name: Check PR body for changelog convention
|
||||
|
||||
on:
|
||||
merge_group:
|
||||
pull_request:
|
||||
types: [opened, synchronize, reopened, edited, labeled, converted_to_draft, ready_for_review]
|
||||
|
||||
@@ -9,6 +10,7 @@ jobs:
|
||||
runs-on: ubuntu-latest
|
||||
steps:
|
||||
- name: Check PR body
|
||||
if: github.event_name == 'pull_request'
|
||||
uses: actions/github-script@v7
|
||||
with:
|
||||
script: |
|
||||
|
||||
@@ -170,7 +170,7 @@ lib.warn "The Nix-based build is deprecated" rec {
|
||||
ln -sf ${lean-all}/* .
|
||||
'';
|
||||
buildPhase = ''
|
||||
ctest --output-junit test-results.xml --output-on-failure -E 'leancomptest_(doc_example|foreign)|leanlaketest_reverse-ffi' -j$NIX_BUILD_CORES
|
||||
ctest --output-junit test-results.xml --output-on-failure -E 'leancomptest_(doc_example|foreign)|leanlaketest_reverse-ffi|leanruntest_timeIO' -j$NIX_BUILD_CORES
|
||||
'';
|
||||
installPhase = ''
|
||||
mkdir $out
|
||||
|
||||
@@ -1922,12 +1922,12 @@ represents an element of `Squash α` the same as `α` itself
|
||||
`Squash.lift` will extract a value in any subsingleton `β` from a function on `α`,
|
||||
while `Nonempty.rec` can only do the same when `β` is a proposition.
|
||||
-/
|
||||
def Squash (α : Type u) := Quot (fun (_ _ : α) => True)
|
||||
def Squash (α : Sort u) := Quot (fun (_ _ : α) => True)
|
||||
|
||||
/-- The canonical quotient map into `Squash α`. -/
|
||||
def Squash.mk {α : Type u} (x : α) : Squash α := Quot.mk _ x
|
||||
def Squash.mk {α : Sort u} (x : α) : Squash α := Quot.mk _ x
|
||||
|
||||
theorem Squash.ind {α : Type u} {motive : Squash α → Prop} (h : ∀ (a : α), motive (Squash.mk a)) : ∀ (q : Squash α), motive q :=
|
||||
theorem Squash.ind {α : Sort u} {motive : Squash α → Prop} (h : ∀ (a : α), motive (Squash.mk a)) : ∀ (q : Squash α), motive q :=
|
||||
Quot.ind h
|
||||
|
||||
/-- If `β` is a subsingleton, then a function `α → β` lifts to `Squash α → β`. -/
|
||||
|
||||
@@ -42,3 +42,4 @@ import Init.Data.PLift
|
||||
import Init.Data.Zero
|
||||
import Init.Data.NeZero
|
||||
import Init.Data.Function
|
||||
import Init.Data.RArray
|
||||
|
||||
@@ -18,3 +18,4 @@ import Init.Data.Array.Bootstrap
|
||||
import Init.Data.Array.GetLit
|
||||
import Init.Data.Array.MapIdx
|
||||
import Init.Data.Array.Set
|
||||
import Init.Data.Array.Monadic
|
||||
|
||||
@@ -10,6 +10,17 @@ import Init.Data.List.Attach
|
||||
|
||||
namespace Array
|
||||
|
||||
/--
|
||||
`O(n)`. Partial map. If `f : Π a, P a → β` is a partial function defined on
|
||||
`a : α` satisfying `P`, then `pmap f l h` is essentially the same as `map f l`
|
||||
but is defined only when all members of `l` satisfy `P`, using the proof
|
||||
to apply `f`.
|
||||
|
||||
We replace this at runtime with a more efficient version via the `csimp` lemma `pmap_eq_pmapImpl`.
|
||||
-/
|
||||
def pmap {P : α → Prop} (f : ∀ a, P a → β) (l : Array α) (H : ∀ a ∈ l, P a) : Array β :=
|
||||
(l.toList.pmap f (fun a m => H a (mem_def.mpr m))).toArray
|
||||
|
||||
/--
|
||||
Unsafe implementation of `attachWith`, taking advantage of the fact that the representation of
|
||||
`Array {x // P x}` is the same as the input `Array α`.
|
||||
@@ -35,6 +46,10 @@ Unsafe implementation of `attachWith`, taking advantage of the fact that the rep
|
||||
l.toArray.attach = (l.attachWith (· ∈ l.toArray) (by simp)).toArray := by
|
||||
simp [attach]
|
||||
|
||||
@[simp] theorem _root_.List.pmap_toArray {l : List α} {P : α → Prop} {f : ∀ a, P a → β} {H : ∀ a ∈ l.toArray, P a} :
|
||||
l.toArray.pmap f H = (l.pmap f (by simpa using H)).toArray := by
|
||||
simp [pmap]
|
||||
|
||||
@[simp] theorem toList_attachWith {l : Array α} {P : α → Prop} {H : ∀ x ∈ l, P x} :
|
||||
(l.attachWith P H).toList = l.toList.attachWith P (by simpa [mem_toList] using H) := by
|
||||
simp [attachWith]
|
||||
@@ -43,6 +58,387 @@ Unsafe implementation of `attachWith`, taking advantage of the fact that the rep
|
||||
l.attach.toList = l.toList.attachWith (· ∈ l) (by simp [mem_toList]) := by
|
||||
simp [attach]
|
||||
|
||||
@[simp] theorem toList_pmap {l : Array α} {P : α → Prop} {f : ∀ a, P a → β} {H : ∀ a ∈ l, P a} :
|
||||
(l.pmap f H).toList = l.toList.pmap f (fun a m => H a (mem_def.mpr m)) := by
|
||||
simp [pmap]
|
||||
|
||||
/-- Implementation of `pmap` using the zero-copy version of `attach`. -/
|
||||
@[inline] private def pmapImpl {P : α → Prop} (f : ∀ a, P a → β) (l : Array α) (H : ∀ a ∈ l, P a) :
|
||||
Array β := (l.attachWith _ H).map fun ⟨x, h'⟩ => f x h'
|
||||
|
||||
@[csimp] private theorem pmap_eq_pmapImpl : @pmap = @pmapImpl := by
|
||||
funext α β p f L h'
|
||||
cases L
|
||||
simp only [pmap, pmapImpl, List.attachWith_toArray, List.map_toArray, mk.injEq, List.map_attachWith]
|
||||
apply List.pmap_congr_left
|
||||
intro a m h₁ h₂
|
||||
congr
|
||||
|
||||
@[simp] theorem pmap_empty {P : α → Prop} (f : ∀ a, P a → β) : pmap f #[] (by simp) = #[] := rfl
|
||||
|
||||
@[simp] theorem pmap_push {P : α → Prop} (f : ∀ a, P a → β) (a : α) (l : Array α) (h : ∀ b ∈ l.push a, P b) :
|
||||
pmap f (l.push a) h =
|
||||
(pmap f l (fun a m => by simp at h; exact h a (.inl m))).push (f a (h a (by simp))) := by
|
||||
simp [pmap]
|
||||
|
||||
@[simp] theorem attach_empty : (#[] : Array α).attach = #[] := rfl
|
||||
|
||||
@[simp] theorem attachWith_empty {P : α → Prop} (H : ∀ x ∈ #[], P x) : (#[] : Array α).attachWith P H = #[] := rfl
|
||||
|
||||
@[simp] theorem _root_.List.attachWith_mem_toArray {l : List α} :
|
||||
l.attachWith (fun x => x ∈ l.toArray) (fun x h => by simpa using h) =
|
||||
l.attach.map fun ⟨x, h⟩ => ⟨x, by simpa using h⟩ := by
|
||||
simp only [List.attachWith, List.attach, List.map_pmap]
|
||||
apply List.pmap_congr_left
|
||||
simp
|
||||
|
||||
@[simp]
|
||||
theorem pmap_eq_map (p : α → Prop) (f : α → β) (l : Array α) (H) :
|
||||
@pmap _ _ p (fun a _ => f a) l H = map f l := by
|
||||
cases l; simp
|
||||
|
||||
theorem pmap_congr_left {p q : α → Prop} {f : ∀ a, p a → β} {g : ∀ a, q a → β} (l : Array α) {H₁ H₂}
|
||||
(h : ∀ a ∈ l, ∀ (h₁ h₂), f a h₁ = g a h₂) : pmap f l H₁ = pmap g l H₂ := by
|
||||
cases l
|
||||
simp only [mem_toArray] at h
|
||||
simp only [List.pmap_toArray, mk.injEq]
|
||||
rw [List.pmap_congr_left _ h]
|
||||
|
||||
theorem map_pmap {p : α → Prop} (g : β → γ) (f : ∀ a, p a → β) (l H) :
|
||||
map g (pmap f l H) = pmap (fun a h => g (f a h)) l H := by
|
||||
cases l
|
||||
simp [List.map_pmap]
|
||||
|
||||
theorem pmap_map {p : β → Prop} (g : ∀ b, p b → γ) (f : α → β) (l H) :
|
||||
pmap g (map f l) H = pmap (fun a h => g (f a) h) l fun _ h => H _ (mem_map_of_mem _ h) := by
|
||||
cases l
|
||||
simp [List.pmap_map]
|
||||
|
||||
theorem attach_congr {l₁ l₂ : Array α} (h : l₁ = l₂) :
|
||||
l₁.attach = l₂.attach.map (fun x => ⟨x.1, h ▸ x.2⟩) := by
|
||||
subst h
|
||||
simp
|
||||
|
||||
theorem attachWith_congr {l₁ l₂ : Array α} (w : l₁ = l₂) {P : α → Prop} {H : ∀ x ∈ l₁, P x} :
|
||||
l₁.attachWith P H = l₂.attachWith P fun _ h => H _ (w ▸ h) := by
|
||||
subst w
|
||||
simp
|
||||
|
||||
@[simp] theorem attach_push {a : α} {l : Array α} :
|
||||
(l.push a).attach =
|
||||
(l.attach.map (fun ⟨x, h⟩ => ⟨x, mem_push_of_mem a h⟩)).push ⟨a, by simp⟩ := by
|
||||
cases l
|
||||
rw [attach_congr (List.push_toArray _ _)]
|
||||
simp [Function.comp_def]
|
||||
|
||||
@[simp] theorem attachWith_push {a : α} {l : Array α} {P : α → Prop} {H : ∀ x ∈ l.push a, P x} :
|
||||
(l.push a).attachWith P H =
|
||||
(l.attachWith P (fun x h => by simp at H; exact H x (.inl h))).push ⟨a, H a (by simp)⟩ := by
|
||||
cases l
|
||||
simp [attachWith_congr (List.push_toArray _ _)]
|
||||
|
||||
theorem pmap_eq_map_attach {p : α → Prop} (f : ∀ a, p a → β) (l H) :
|
||||
pmap f l H = l.attach.map fun x => f x.1 (H _ x.2) := by
|
||||
cases l
|
||||
simp [List.pmap_eq_map_attach]
|
||||
|
||||
theorem attach_map_coe (l : Array α) (f : α → β) :
|
||||
(l.attach.map fun (i : {i // i ∈ l}) => f i) = l.map f := by
|
||||
cases l
|
||||
simp [List.attach_map_coe]
|
||||
|
||||
theorem attach_map_val (l : Array α) (f : α → β) : (l.attach.map fun i => f i.val) = l.map f :=
|
||||
attach_map_coe _ _
|
||||
|
||||
@[simp]
|
||||
theorem attach_map_subtype_val (l : Array α) : l.attach.map Subtype.val = l := by
|
||||
cases l; simp
|
||||
|
||||
theorem attachWith_map_coe {p : α → Prop} (f : α → β) (l : Array α) (H : ∀ a ∈ l, p a) :
|
||||
((l.attachWith p H).map fun (i : { i // p i}) => f i) = l.map f := by
|
||||
cases l; simp
|
||||
|
||||
theorem attachWith_map_val {p : α → Prop} (f : α → β) (l : Array α) (H : ∀ a ∈ l, p a) :
|
||||
((l.attachWith p H).map fun i => f i.val) = l.map f :=
|
||||
attachWith_map_coe _ _ _
|
||||
|
||||
@[simp]
|
||||
theorem attachWith_map_subtype_val {p : α → Prop} (l : Array α) (H : ∀ a ∈ l, p a) :
|
||||
(l.attachWith p H).map Subtype.val = l := by
|
||||
cases l; simp
|
||||
|
||||
@[simp]
|
||||
theorem mem_attach (l : Array α) : ∀ x, x ∈ l.attach
|
||||
| ⟨a, h⟩ => by
|
||||
have := mem_map.1 (by rw [attach_map_subtype_val] <;> exact h)
|
||||
rcases this with ⟨⟨_, _⟩, m, rfl⟩
|
||||
exact m
|
||||
|
||||
@[simp]
|
||||
theorem mem_pmap {p : α → Prop} {f : ∀ a, p a → β} {l H b} :
|
||||
b ∈ pmap f l H ↔ ∃ (a : _) (h : a ∈ l), f a (H a h) = b := by
|
||||
simp only [pmap_eq_map_attach, mem_map, mem_attach, true_and, Subtype.exists, eq_comm]
|
||||
|
||||
theorem mem_pmap_of_mem {p : α → Prop} {f : ∀ a, p a → β} {l H} {a} (h : a ∈ l) :
|
||||
f a (H a h) ∈ pmap f l H := by
|
||||
rw [mem_pmap]
|
||||
exact ⟨a, h, rfl⟩
|
||||
|
||||
@[simp]
|
||||
theorem size_pmap {p : α → Prop} {f : ∀ a, p a → β} {l H} : (pmap f l H).size = l.size := by
|
||||
cases l; simp
|
||||
|
||||
@[simp]
|
||||
theorem size_attach {L : Array α} : L.attach.size = L.size := by
|
||||
cases L; simp
|
||||
|
||||
@[simp]
|
||||
theorem size_attachWith {p : α → Prop} {l : Array α} {H} : (l.attachWith p H).size = l.size := by
|
||||
cases l; simp
|
||||
|
||||
@[simp]
|
||||
theorem pmap_eq_empty_iff {p : α → Prop} {f : ∀ a, p a → β} {l H} : pmap f l H = #[] ↔ l = #[] := by
|
||||
cases l; simp
|
||||
|
||||
theorem pmap_ne_empty_iff {P : α → Prop} (f : (a : α) → P a → β) {xs : Array α}
|
||||
(H : ∀ (a : α), a ∈ xs → P a) : xs.pmap f H ≠ #[] ↔ xs ≠ #[] := by
|
||||
cases xs; simp
|
||||
|
||||
theorem pmap_eq_self {l : Array α} {p : α → Prop} (hp : ∀ (a : α), a ∈ l → p a)
|
||||
(f : (a : α) → p a → α) : l.pmap f hp = l ↔ ∀ a (h : a ∈ l), f a (hp a h) = a := by
|
||||
cases l; simp [List.pmap_eq_self]
|
||||
|
||||
@[simp]
|
||||
theorem attach_eq_empty_iff {l : Array α} : l.attach = #[] ↔ l = #[] := by
|
||||
cases l; simp
|
||||
|
||||
theorem attach_ne_empty_iff {l : Array α} : l.attach ≠ #[] ↔ l ≠ #[] := by
|
||||
cases l; simp
|
||||
|
||||
@[simp]
|
||||
theorem attachWith_eq_empty_iff {l : Array α} {P : α → Prop} {H : ∀ a ∈ l, P a} :
|
||||
l.attachWith P H = #[] ↔ l = #[] := by
|
||||
cases l; simp
|
||||
|
||||
theorem attachWith_ne_empty_iff {l : Array α} {P : α → Prop} {H : ∀ a ∈ l, P a} :
|
||||
l.attachWith P H ≠ #[] ↔ l ≠ #[] := by
|
||||
cases l; simp
|
||||
|
||||
@[simp]
|
||||
theorem getElem?_pmap {p : α → Prop} (f : ∀ a, p a → β) {l : Array α} (h : ∀ a ∈ l, p a) (n : Nat) :
|
||||
(pmap f l h)[n]? = Option.pmap f l[n]? fun x H => h x (mem_of_getElem? H) := by
|
||||
cases l; simp
|
||||
|
||||
@[simp]
|
||||
theorem getElem_pmap {p : α → Prop} (f : ∀ a, p a → β) {l : Array α} (h : ∀ a ∈ l, p a) {n : Nat}
|
||||
(hn : n < (pmap f l h).size) :
|
||||
(pmap f l h)[n] =
|
||||
f (l[n]'(@size_pmap _ _ p f l h ▸ hn))
|
||||
(h _ (getElem_mem (@size_pmap _ _ p f l h ▸ hn))) := by
|
||||
cases l; simp
|
||||
|
||||
@[simp]
|
||||
theorem getElem?_attachWith {xs : Array α} {i : Nat} {P : α → Prop} {H : ∀ a ∈ xs, P a} :
|
||||
(xs.attachWith P H)[i]? = xs[i]?.pmap Subtype.mk (fun _ a => H _ (mem_of_getElem? a)) :=
|
||||
getElem?_pmap ..
|
||||
|
||||
@[simp]
|
||||
theorem getElem?_attach {xs : Array α} {i : Nat} :
|
||||
xs.attach[i]? = xs[i]?.pmap Subtype.mk (fun _ a => mem_of_getElem? a) :=
|
||||
getElem?_attachWith
|
||||
|
||||
@[simp]
|
||||
theorem getElem_attachWith {xs : Array α} {P : α → Prop} {H : ∀ a ∈ xs, P a}
|
||||
{i : Nat} (h : i < (xs.attachWith P H).size) :
|
||||
(xs.attachWith P H)[i] = ⟨xs[i]'(by simpa using h), H _ (getElem_mem (by simpa using h))⟩ :=
|
||||
getElem_pmap ..
|
||||
|
||||
@[simp]
|
||||
theorem getElem_attach {xs : Array α} {i : Nat} (h : i < xs.attach.size) :
|
||||
xs.attach[i] = ⟨xs[i]'(by simpa using h), getElem_mem (by simpa using h)⟩ :=
|
||||
getElem_attachWith h
|
||||
|
||||
theorem foldl_pmap (l : Array α) {P : α → Prop} (f : (a : α) → P a → β)
|
||||
(H : ∀ (a : α), a ∈ l → P a) (g : γ → β → γ) (x : γ) :
|
||||
(l.pmap f H).foldl g x = l.attach.foldl (fun acc a => g acc (f a.1 (H _ a.2))) x := by
|
||||
rw [pmap_eq_map_attach, foldl_map]
|
||||
|
||||
theorem foldr_pmap (l : Array α) {P : α → Prop} (f : (a : α) → P a → β)
|
||||
(H : ∀ (a : α), a ∈ l → P a) (g : β → γ → γ) (x : γ) :
|
||||
(l.pmap f H).foldr g x = l.attach.foldr (fun a acc => g (f a.1 (H _ a.2)) acc) x := by
|
||||
rw [pmap_eq_map_attach, foldr_map]
|
||||
|
||||
/--
|
||||
If we fold over `l.attach` with a function that ignores the membership predicate,
|
||||
we get the same results as folding over `l` directly.
|
||||
|
||||
This is useful when we need to use `attach` to show termination.
|
||||
|
||||
Unfortunately this can't be applied by `simp` because of the higher order unification problem,
|
||||
and even when rewriting we need to specify the function explicitly.
|
||||
See however `foldl_subtype` below.
|
||||
-/
|
||||
theorem foldl_attach (l : Array α) (f : β → α → β) (b : β) :
|
||||
l.attach.foldl (fun acc t => f acc t.1) b = l.foldl f b := by
|
||||
rcases l with ⟨l⟩
|
||||
simp only [List.attach_toArray, List.attachWith_mem_toArray, List.map_attach, size_toArray,
|
||||
List.length_pmap, List.foldl_toArray', mem_toArray, List.foldl_subtype]
|
||||
congr
|
||||
ext
|
||||
simpa using fun a => List.mem_of_getElem? a
|
||||
|
||||
/--
|
||||
If we fold over `l.attach` with a function that ignores the membership predicate,
|
||||
we get the same results as folding over `l` directly.
|
||||
|
||||
This is useful when we need to use `attach` to show termination.
|
||||
|
||||
Unfortunately this can't be applied by `simp` because of the higher order unification problem,
|
||||
and even when rewriting we need to specify the function explicitly.
|
||||
See however `foldr_subtype` below.
|
||||
-/
|
||||
theorem foldr_attach (l : Array α) (f : α → β → β) (b : β) :
|
||||
l.attach.foldr (fun t acc => f t.1 acc) b = l.foldr f b := by
|
||||
rcases l with ⟨l⟩
|
||||
simp only [List.attach_toArray, List.attachWith_mem_toArray, List.map_attach, size_toArray,
|
||||
List.length_pmap, List.foldr_toArray', mem_toArray, List.foldr_subtype]
|
||||
congr
|
||||
ext
|
||||
simpa using fun a => List.mem_of_getElem? a
|
||||
|
||||
theorem attach_map {l : Array α} (f : α → β) :
|
||||
(l.map f).attach = l.attach.map (fun ⟨x, h⟩ => ⟨f x, mem_map_of_mem f h⟩) := by
|
||||
cases l
|
||||
ext <;> simp
|
||||
|
||||
theorem attachWith_map {l : Array α} (f : α → β) {P : β → Prop} {H : ∀ (b : β), b ∈ l.map f → P b} :
|
||||
(l.map f).attachWith P H = (l.attachWith (P ∘ f) (fun _ h => H _ (mem_map_of_mem f h))).map
|
||||
fun ⟨x, h⟩ => ⟨f x, h⟩ := by
|
||||
cases l
|
||||
ext
|
||||
· simp
|
||||
· simp only [List.map_toArray, List.attachWith_toArray, List.getElem_toArray,
|
||||
List.getElem_attachWith, List.getElem_map, Function.comp_apply]
|
||||
erw [List.getElem_attachWith] -- Why is `erw` needed here?
|
||||
|
||||
theorem map_attachWith {l : Array α} {P : α → Prop} {H : ∀ (a : α), a ∈ l → P a}
|
||||
(f : { x // P x } → β) :
|
||||
(l.attachWith P H).map f =
|
||||
l.pmap (fun a (h : a ∈ l ∧ P a) => f ⟨a, H _ h.1⟩) (fun a h => ⟨h, H a h⟩) := by
|
||||
cases l
|
||||
ext <;> simp
|
||||
|
||||
/-- See also `pmap_eq_map_attach` for writing `pmap` in terms of `map` and `attach`. -/
|
||||
theorem map_attach {l : Array α} (f : { x // x ∈ l } → β) :
|
||||
l.attach.map f = l.pmap (fun a h => f ⟨a, h⟩) (fun _ => id) := by
|
||||
cases l
|
||||
ext <;> simp
|
||||
|
||||
theorem attach_filterMap {l : Array α} {f : α → Option β} :
|
||||
(l.filterMap f).attach = l.attach.filterMap
|
||||
fun ⟨x, h⟩ => (f x).pbind (fun b m => some ⟨b, mem_filterMap.mpr ⟨x, h, m⟩⟩) := by
|
||||
cases l
|
||||
rw [attach_congr (List.filterMap_toArray f _)]
|
||||
simp [List.attach_filterMap, List.map_filterMap, Function.comp_def]
|
||||
|
||||
theorem attach_filter {l : Array α} (p : α → Bool) :
|
||||
(l.filter p).attach = l.attach.filterMap
|
||||
fun x => if w : p x.1 then some ⟨x.1, mem_filter.mpr ⟨x.2, w⟩⟩ else none := by
|
||||
cases l
|
||||
rw [attach_congr (List.filter_toArray p _)]
|
||||
simp [List.attach_filter, List.map_filterMap, Function.comp_def]
|
||||
|
||||
-- We are still missing here `attachWith_filterMap` and `attachWith_filter`.
|
||||
-- Also missing are `filterMap_attach`, `filter_attach`, `filterMap_attachWith` and `filter_attachWith`.
|
||||
|
||||
theorem pmap_pmap {p : α → Prop} {q : β → Prop} (g : ∀ a, p a → β) (f : ∀ b, q b → γ) (l H₁ H₂) :
|
||||
pmap f (pmap g l H₁) H₂ =
|
||||
pmap (α := { x // x ∈ l }) (fun a h => f (g a h) (H₂ (g a h) (mem_pmap_of_mem a.2))) l.attach
|
||||
(fun a _ => H₁ a a.2) := by
|
||||
cases l
|
||||
simp [List.pmap_pmap, List.pmap_map]
|
||||
|
||||
@[simp] theorem pmap_append {p : ι → Prop} (f : ∀ a : ι, p a → α) (l₁ l₂ : Array ι)
|
||||
(h : ∀ a ∈ l₁ ++ l₂, p a) :
|
||||
(l₁ ++ l₂).pmap f h =
|
||||
(l₁.pmap f fun a ha => h a (mem_append_left l₂ ha)) ++
|
||||
l₂.pmap f fun a ha => h a (mem_append_right l₁ ha) := by
|
||||
cases l₁
|
||||
cases l₂
|
||||
simp
|
||||
|
||||
theorem pmap_append' {p : α → Prop} (f : ∀ a : α, p a → β) (l₁ l₂ : Array α)
|
||||
(h₁ : ∀ a ∈ l₁, p a) (h₂ : ∀ a ∈ l₂, p a) :
|
||||
((l₁ ++ l₂).pmap f fun a ha => (mem_append.1 ha).elim (h₁ a) (h₂ a)) =
|
||||
l₁.pmap f h₁ ++ l₂.pmap f h₂ :=
|
||||
pmap_append f l₁ l₂ _
|
||||
|
||||
@[simp] theorem attach_append (xs ys : Array α) :
|
||||
(xs ++ ys).attach = xs.attach.map (fun ⟨x, h⟩ => ⟨x, mem_append_left ys h⟩) ++
|
||||
ys.attach.map fun ⟨x, h⟩ => ⟨x, mem_append_right xs h⟩ := by
|
||||
cases xs
|
||||
cases ys
|
||||
rw [attach_congr (List.append_toArray _ _)]
|
||||
simp [List.attach_append, Function.comp_def]
|
||||
|
||||
@[simp] theorem attachWith_append {P : α → Prop} {xs ys : Array α}
|
||||
{H : ∀ (a : α), a ∈ xs ++ ys → P a} :
|
||||
(xs ++ ys).attachWith P H = xs.attachWith P (fun a h => H a (mem_append_left ys h)) ++
|
||||
ys.attachWith P (fun a h => H a (mem_append_right xs h)) := by
|
||||
simp [attachWith, attach_append, map_pmap, pmap_append]
|
||||
|
||||
@[simp] theorem pmap_reverse {P : α → Prop} (f : (a : α) → P a → β) (xs : Array α)
|
||||
(H : ∀ (a : α), a ∈ xs.reverse → P a) :
|
||||
xs.reverse.pmap f H = (xs.pmap f (fun a h => H a (by simpa using h))).reverse := by
|
||||
induction xs <;> simp_all
|
||||
|
||||
theorem reverse_pmap {P : α → Prop} (f : (a : α) → P a → β) (xs : Array α)
|
||||
(H : ∀ (a : α), a ∈ xs → P a) :
|
||||
(xs.pmap f H).reverse = xs.reverse.pmap f (fun a h => H a (by simpa using h)) := by
|
||||
rw [pmap_reverse]
|
||||
|
||||
@[simp] theorem attachWith_reverse {P : α → Prop} {xs : Array α}
|
||||
{H : ∀ (a : α), a ∈ xs.reverse → P a} :
|
||||
xs.reverse.attachWith P H =
|
||||
(xs.attachWith P (fun a h => H a (by simpa using h))).reverse := by
|
||||
cases xs
|
||||
simp
|
||||
|
||||
theorem reverse_attachWith {P : α → Prop} {xs : Array α}
|
||||
{H : ∀ (a : α), a ∈ xs → P a} :
|
||||
(xs.attachWith P H).reverse = (xs.reverse.attachWith P (fun a h => H a (by simpa using h))) := by
|
||||
cases xs
|
||||
simp
|
||||
|
||||
@[simp] theorem attach_reverse (xs : Array α) :
|
||||
xs.reverse.attach = xs.attach.reverse.map fun ⟨x, h⟩ => ⟨x, by simpa using h⟩ := by
|
||||
cases xs
|
||||
rw [attach_congr (List.reverse_toArray _)]
|
||||
simp
|
||||
|
||||
theorem reverse_attach (xs : Array α) :
|
||||
xs.attach.reverse = xs.reverse.attach.map fun ⟨x, h⟩ => ⟨x, by simpa using h⟩ := by
|
||||
cases xs
|
||||
simp
|
||||
|
||||
@[simp] theorem back?_pmap {P : α → Prop} (f : (a : α) → P a → β) (xs : Array α)
|
||||
(H : ∀ (a : α), a ∈ xs → P a) :
|
||||
(xs.pmap f H).back? = xs.attach.back?.map fun ⟨a, m⟩ => f a (H a m) := by
|
||||
cases xs
|
||||
simp
|
||||
|
||||
@[simp] theorem back?_attachWith {P : α → Prop} {xs : Array α}
|
||||
{H : ∀ (a : α), a ∈ xs → P a} :
|
||||
(xs.attachWith P H).back? = xs.back?.pbind (fun a h => some ⟨a, H _ (mem_of_back?_eq_some h)⟩) := by
|
||||
cases xs
|
||||
simp
|
||||
|
||||
@[simp]
|
||||
theorem back?_attach {xs : Array α} :
|
||||
xs.attach.back? = xs.back?.pbind fun a h => some ⟨a, mem_of_back?_eq_some h⟩ := by
|
||||
cases xs
|
||||
simp
|
||||
|
||||
/-! ## unattach
|
||||
|
||||
`Array.unattach` is the (one-sided) inverse of `Array.attach`. It is a synonym for `Array.map Subtype.val`.
|
||||
@@ -83,7 +479,7 @@ def unattach {α : Type _} {p : α → Prop} (l : Array { x // p x }) := l.map (
|
||||
|
||||
@[simp] theorem unattach_attach {l : Array α} : l.attach.unattach = l := by
|
||||
cases l
|
||||
simp
|
||||
simp only [List.attach_toArray, List.unattach_toArray, List.unattach_attachWith]
|
||||
|
||||
@[simp] theorem unattach_attachWith {p : α → Prop} {l : Array α}
|
||||
{H : ∀ a ∈ l, p a} :
|
||||
@@ -91,6 +487,15 @@ def unattach {α : Type _} {p : α → Prop} (l : Array { x // p x }) := l.map (
|
||||
cases l
|
||||
simp
|
||||
|
||||
@[simp] theorem getElem?_unattach {p : α → Prop} {l : Array { x // p x }} (i : Nat) :
|
||||
l.unattach[i]? = l[i]?.map Subtype.val := by
|
||||
simp [unattach]
|
||||
|
||||
@[simp] theorem getElem_unattach
|
||||
{p : α → Prop} {l : Array { x // p x }} (i : Nat) (h : i < l.unattach.size) :
|
||||
l.unattach[i] = (l[i]'(by simpa using h)).1 := by
|
||||
simp [unattach]
|
||||
|
||||
/-! ### Recognizing higher order functions using a function that only depends on the value. -/
|
||||
|
||||
/--
|
||||
|
||||
@@ -15,26 +15,26 @@ This file contains some theorems about `Array` and `List` needed for `Init.Data.
|
||||
|
||||
namespace Array
|
||||
|
||||
theorem foldlM_eq_foldlM_toList.aux [Monad m]
|
||||
theorem foldlM_toList.aux [Monad m]
|
||||
(f : β → α → m β) (arr : Array α) (i j) (H : arr.size ≤ i + j) (b) :
|
||||
foldlM.loop f arr arr.size (Nat.le_refl _) i j b = (arr.toList.drop j).foldlM f b := by
|
||||
unfold foldlM.loop
|
||||
split; split
|
||||
· cases Nat.not_le_of_gt ‹_› (Nat.zero_add _ ▸ H)
|
||||
· rename_i i; rw [Nat.succ_add] at H
|
||||
simp [foldlM_eq_foldlM_toList.aux f arr i (j+1) H]
|
||||
simp [foldlM_toList.aux f arr i (j+1) H]
|
||||
rw (occs := .pos [2]) [← List.getElem_cons_drop_succ_eq_drop ‹_›]
|
||||
rfl
|
||||
· rw [List.drop_of_length_le (Nat.ge_of_not_lt ‹_›)]; rfl
|
||||
|
||||
theorem foldlM_eq_foldlM_toList [Monad m]
|
||||
@[simp] theorem foldlM_toList [Monad m]
|
||||
(f : β → α → m β) (init : β) (arr : Array α) :
|
||||
arr.foldlM f init = arr.toList.foldlM f init := by
|
||||
simp [foldlM, foldlM_eq_foldlM_toList.aux]
|
||||
arr.toList.foldlM f init = arr.foldlM f init := by
|
||||
simp [foldlM, foldlM_toList.aux]
|
||||
|
||||
theorem foldl_eq_foldl_toList (f : β → α → β) (init : β) (arr : Array α) :
|
||||
arr.foldl f init = arr.toList.foldl f init :=
|
||||
List.foldl_eq_foldlM .. ▸ foldlM_eq_foldlM_toList ..
|
||||
@[simp] theorem foldl_toList (f : β → α → β) (init : β) (arr : Array α) :
|
||||
arr.toList.foldl f init = arr.foldl f init :=
|
||||
List.foldl_eq_foldlM .. ▸ foldlM_toList ..
|
||||
|
||||
theorem foldrM_eq_reverse_foldlM_toList.aux [Monad m]
|
||||
(f : α → β → m β) (arr : Array α) (init : β) (i h) :
|
||||
@@ -51,23 +51,23 @@ theorem foldrM_eq_reverse_foldlM_toList [Monad m] (f : α → β → m β) (init
|
||||
match arr, this with | _, .inl rfl => rfl | arr, .inr h => ?_
|
||||
simp [foldrM, h, ← foldrM_eq_reverse_foldlM_toList.aux, List.take_length]
|
||||
|
||||
theorem foldrM_eq_foldrM_toList [Monad m]
|
||||
@[simp] theorem foldrM_toList [Monad m]
|
||||
(f : α → β → m β) (init : β) (arr : Array α) :
|
||||
arr.foldrM f init = arr.toList.foldrM f init := by
|
||||
arr.toList.foldrM f init = arr.foldrM f init := by
|
||||
rw [foldrM_eq_reverse_foldlM_toList, List.foldlM_reverse]
|
||||
|
||||
theorem foldr_eq_foldr_toList (f : α → β → β) (init : β) (arr : Array α) :
|
||||
arr.foldr f init = arr.toList.foldr f init :=
|
||||
List.foldr_eq_foldrM .. ▸ foldrM_eq_foldrM_toList ..
|
||||
@[simp] theorem foldr_toList (f : α → β → β) (init : β) (arr : Array α) :
|
||||
arr.toList.foldr f init = arr.foldr f init :=
|
||||
List.foldr_eq_foldrM .. ▸ foldrM_toList ..
|
||||
|
||||
@[simp] theorem push_toList (arr : Array α) (a : α) : (arr.push a).toList = arr.toList ++ [a] := by
|
||||
simp [push, List.concat_eq_append]
|
||||
|
||||
@[simp] theorem toListAppend_eq (arr : Array α) (l) : arr.toListAppend l = arr.toList ++ l := by
|
||||
simp [toListAppend, foldr_eq_foldr_toList]
|
||||
simp [toListAppend, ← foldr_toList]
|
||||
|
||||
@[simp] theorem toListImpl_eq (arr : Array α) : arr.toListImpl = arr.toList := by
|
||||
simp [toListImpl, foldr_eq_foldr_toList]
|
||||
simp [toListImpl, ← foldr_toList]
|
||||
|
||||
@[simp] theorem pop_toList (arr : Array α) : arr.pop.toList = arr.toList.dropLast := rfl
|
||||
|
||||
@@ -76,7 +76,7 @@ theorem foldr_eq_foldr_toList (f : α → β → β) (init : β) (arr : Array α
|
||||
@[simp] theorem toList_append (arr arr' : Array α) :
|
||||
(arr ++ arr').toList = arr.toList ++ arr'.toList := by
|
||||
rw [← append_eq_append]; unfold Array.append
|
||||
rw [foldl_eq_foldl_toList]
|
||||
rw [← foldl_toList]
|
||||
induction arr'.toList generalizing arr <;> simp [*]
|
||||
|
||||
@[simp] theorem toList_empty : (#[] : Array α).toList = [] := rfl
|
||||
@@ -98,20 +98,44 @@ theorem foldr_eq_foldr_toList (f : α → β → β) (init : β) (arr : Array α
|
||||
rw [← appendList_eq_append]; unfold Array.appendList
|
||||
induction l generalizing arr <;> simp [*]
|
||||
|
||||
@[deprecated foldlM_eq_foldlM_toList (since := "2024-09-09")]
|
||||
abbrev foldlM_eq_foldlM_data := @foldlM_eq_foldlM_toList
|
||||
@[deprecated "Use the reverse direction of `foldrM_toList`." (since := "2024-11-13")]
|
||||
theorem foldrM_eq_foldrM_toList [Monad m]
|
||||
(f : α → β → m β) (init : β) (arr : Array α) :
|
||||
arr.foldrM f init = arr.toList.foldrM f init := by
|
||||
simp
|
||||
|
||||
@[deprecated foldl_eq_foldl_toList (since := "2024-09-09")]
|
||||
abbrev foldl_eq_foldl_data := @foldl_eq_foldl_toList
|
||||
@[deprecated "Use the reverse direction of `foldlM_toList`." (since := "2024-11-13")]
|
||||
theorem foldlM_eq_foldlM_toList [Monad m]
|
||||
(f : β → α → m β) (init : β) (arr : Array α) :
|
||||
arr.foldlM f init = arr.toList.foldlM f init:= by
|
||||
simp
|
||||
|
||||
@[deprecated "Use the reverse direction of `foldr_toList`." (since := "2024-11-13")]
|
||||
theorem foldr_eq_foldr_toList
|
||||
(f : α → β → β) (init : β) (arr : Array α) :
|
||||
arr.foldr f init = arr.toList.foldr f init := by
|
||||
simp
|
||||
|
||||
@[deprecated "Use the reverse direction of `foldl_toList`." (since := "2024-11-13")]
|
||||
theorem foldl_eq_foldl_toList
|
||||
(f : β → α → β) (init : β) (arr : Array α) :
|
||||
arr.foldl f init = arr.toList.foldl f init:= by
|
||||
simp
|
||||
|
||||
@[deprecated foldlM_toList (since := "2024-09-09")]
|
||||
abbrev foldlM_eq_foldlM_data := @foldlM_toList
|
||||
|
||||
@[deprecated foldl_toList (since := "2024-09-09")]
|
||||
abbrev foldl_eq_foldl_data := @foldl_toList
|
||||
|
||||
@[deprecated foldrM_eq_reverse_foldlM_toList (since := "2024-09-09")]
|
||||
abbrev foldrM_eq_reverse_foldlM_data := @foldrM_eq_reverse_foldlM_toList
|
||||
|
||||
@[deprecated foldrM_eq_foldrM_toList (since := "2024-09-09")]
|
||||
abbrev foldrM_eq_foldrM_data := @foldrM_eq_foldrM_toList
|
||||
@[deprecated foldrM_toList (since := "2024-09-09")]
|
||||
abbrev foldrM_eq_foldrM_data := @foldrM_toList
|
||||
|
||||
@[deprecated foldr_eq_foldr_toList (since := "2024-09-09")]
|
||||
abbrev foldr_eq_foldr_data := @foldr_eq_foldr_toList
|
||||
@[deprecated foldr_toList (since := "2024-09-09")]
|
||||
abbrev foldr_eq_foldr_data := @foldr_toList
|
||||
|
||||
@[deprecated push_toList (since := "2024-09-09")]
|
||||
abbrev push_data := @push_toList
|
||||
|
||||
281
src/Init/Data/Array/Find.lean
Normal file
281
src/Init/Data/Array/Find.lean
Normal file
@@ -0,0 +1,281 @@
|
||||
/-
|
||||
Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Kim Morrison
|
||||
-/
|
||||
prelude
|
||||
import Init.Data.List.Find
|
||||
import Init.Data.Array.Lemmas
|
||||
import Init.Data.Array.Attach
|
||||
|
||||
/-!
|
||||
# Lemmas about `Array.findSome?`, `Array.find?`.
|
||||
-/
|
||||
|
||||
namespace Array
|
||||
|
||||
open Nat
|
||||
|
||||
/-! ### findSome? -/
|
||||
|
||||
@[simp] theorem findSomeRev?_push_of_isSome (l : Array α) (h : (f a).isSome) : (l.push a).findSomeRev? f = f a := by
|
||||
cases l; simp_all
|
||||
|
||||
@[simp] theorem findSomeRev?_push_of_isNone (l : Array α) (h : (f a).isNone) : (l.push a).findSomeRev? f = l.findSomeRev? f := by
|
||||
cases l; simp_all
|
||||
|
||||
theorem exists_of_findSome?_eq_some {f : α → Option β} {l : Array α} (w : l.findSome? f = some b) :
|
||||
∃ a, a ∈ l ∧ f a = b := by
|
||||
cases l; simp_all [List.exists_of_findSome?_eq_some]
|
||||
|
||||
@[simp] theorem findSome?_eq_none_iff : findSome? p l = none ↔ ∀ x ∈ l, p x = none := by
|
||||
cases l; simp
|
||||
|
||||
@[simp] theorem findSome?_isSome_iff {f : α → Option β} {l : Array α} :
|
||||
(l.findSome? f).isSome ↔ ∃ x, x ∈ l ∧ (f x).isSome := by
|
||||
cases l; simp
|
||||
|
||||
theorem findSome?_eq_some_iff {f : α → Option β} {l : Array α} {b : β} :
|
||||
l.findSome? f = some b ↔ ∃ (l₁ : Array α) (a : α) (l₂ : Array α), l = l₁.push a ++ l₂ ∧ f a = some b ∧ ∀ x ∈ l₁, f x = none := by
|
||||
cases l
|
||||
simp only [List.findSome?_toArray, List.findSome?_eq_some_iff]
|
||||
constructor
|
||||
· rintro ⟨l₁, a, l₂, rfl, h₁, h₂⟩
|
||||
exact ⟨l₁.toArray, a, l₂.toArray, by simp_all⟩
|
||||
· rintro ⟨l₁, a, l₂, h₀, h₁, h₂⟩
|
||||
exact ⟨l₁.toList, a, l₂.toList, by simpa using congrArg toList h₀, h₁, by simpa⟩
|
||||
|
||||
@[simp] theorem findSome?_guard (l : Array α) : findSome? (Option.guard fun x => p x) l = find? p l := by
|
||||
cases l; simp
|
||||
|
||||
@[simp] theorem getElem?_zero_filterMap (f : α → Option β) (l : Array α) : (l.filterMap f)[0]? = l.findSome? f := by
|
||||
cases l; simp [← List.head?_eq_getElem?]
|
||||
|
||||
@[simp] theorem getElem_zero_filterMap (f : α → Option β) (l : Array α) (h) :
|
||||
(l.filterMap f)[0] = (l.findSome? f).get (by cases l; simpa [List.length_filterMap_eq_countP] using h) := by
|
||||
cases l; simp [← List.head_eq_getElem, ← getElem?_zero_filterMap]
|
||||
|
||||
@[simp] theorem back?_filterMap (f : α → Option β) (l : Array α) : (l.filterMap f).back? = l.findSomeRev? f := by
|
||||
cases l; simp
|
||||
|
||||
@[simp] theorem back!_filterMap [Inhabited β] (f : α → Option β) (l : Array α) :
|
||||
(l.filterMap f).back! = (l.findSomeRev? f).getD default := by
|
||||
cases l; simp
|
||||
|
||||
@[simp] theorem map_findSome? (f : α → Option β) (g : β → γ) (l : Array α) :
|
||||
(l.findSome? f).map g = l.findSome? (Option.map g ∘ f) := by
|
||||
cases l; simp
|
||||
|
||||
theorem findSome?_map (f : β → γ) (l : Array β) : findSome? p (l.map f) = l.findSome? (p ∘ f) := by
|
||||
cases l; simp [List.findSome?_map]
|
||||
|
||||
theorem findSome?_append {l₁ l₂ : Array α} : (l₁ ++ l₂).findSome? f = (l₁.findSome? f).or (l₂.findSome? f) := by
|
||||
cases l₁; cases l₂; simp [List.findSome?_append]
|
||||
|
||||
theorem getElem?_zero_flatten (L : Array (Array α)) :
|
||||
(flatten L)[0]? = L.findSome? fun l => l[0]? := by
|
||||
cases L using array_array_induction
|
||||
simp [← List.head?_eq_getElem?, List.head?_flatten, List.findSome?_map, Function.comp_def]
|
||||
|
||||
theorem getElem_zero_flatten.proof {L : Array (Array α)} (h : 0 < L.flatten.size) :
|
||||
(L.findSome? fun l => l[0]?).isSome := by
|
||||
cases L using array_array_induction
|
||||
simp only [List.findSome?_toArray, List.findSome?_map, Function.comp_def, List.getElem?_toArray,
|
||||
List.findSome?_isSome_iff, List.isSome_getElem?]
|
||||
simp only [flatten_toArray_map_toArray, size_toArray, List.length_flatten,
|
||||
Nat.sum_pos_iff_exists_pos, List.mem_map] at h
|
||||
obtain ⟨_, ⟨xs, m, rfl⟩, h⟩ := h
|
||||
exact ⟨xs, m, by simpa using h⟩
|
||||
|
||||
theorem getElem_zero_flatten {L : Array (Array α)} (h) :
|
||||
(flatten L)[0] = (L.findSome? fun l => l[0]?).get (getElem_zero_flatten.proof h) := by
|
||||
have t := getElem?_zero_flatten L
|
||||
simp [getElem?_eq_getElem, h] at t
|
||||
simp [← t]
|
||||
|
||||
theorem back?_flatten {L : Array (Array α)} :
|
||||
(flatten L).back? = (L.findSomeRev? fun l => l.back?) := by
|
||||
cases L using array_array_induction
|
||||
simp [List.getLast?_flatten, ← List.map_reverse, List.findSome?_map, Function.comp_def]
|
||||
|
||||
theorem findSome?_mkArray : findSome? f (mkArray n a) = if n = 0 then none else f a := by
|
||||
simp [mkArray_eq_toArray_replicate, List.findSome?_replicate]
|
||||
|
||||
@[simp] theorem findSome?_mkArray_of_pos (h : 0 < n) : findSome? f (mkArray n a) = f a := by
|
||||
simp [findSome?_mkArray, Nat.ne_of_gt h]
|
||||
|
||||
-- Argument is unused, but used to decide whether `simp` should unfold.
|
||||
@[simp] theorem findSome?_mkArray_of_isSome (_ : (f a).isSome) :
|
||||
findSome? f (mkArray n a) = if n = 0 then none else f a := by
|
||||
simp [findSome?_mkArray]
|
||||
|
||||
@[simp] theorem findSome?_mkArray_of_isNone (h : (f a).isNone) :
|
||||
findSome? f (mkArray n a) = none := by
|
||||
rw [Option.isNone_iff_eq_none] at h
|
||||
simp [findSome?_mkArray, h]
|
||||
|
||||
/-! ### find? -/
|
||||
|
||||
@[simp] theorem find?_singleton (a : α) (p : α → Bool) :
|
||||
#[a].find? p = if p a then some a else none := by
|
||||
simp [singleton_eq_toArray_singleton]
|
||||
|
||||
@[simp] theorem findRev?_push_of_pos (l : Array α) (h : p a) :
|
||||
findRev? p (l.push a) = some a := by
|
||||
cases l; simp [h]
|
||||
|
||||
@[simp] theorem findRev?_cons_of_neg (l : Array α) (h : ¬p a) :
|
||||
findRev? p (l.push a) = findRev? p l := by
|
||||
cases l; simp [h]
|
||||
|
||||
@[simp] theorem find?_eq_none : find? p l = none ↔ ∀ x ∈ l, ¬ p x := by
|
||||
cases l; simp
|
||||
|
||||
theorem find?_eq_some_iff_append {xs : Array α} :
|
||||
xs.find? p = some b ↔ p b ∧ ∃ (as bs : Array α), xs = as.push b ++ bs ∧ ∀ a ∈ as, !p a := by
|
||||
rcases xs with ⟨xs⟩
|
||||
simp only [List.find?_toArray, List.find?_eq_some_iff_append, Bool.not_eq_eq_eq_not,
|
||||
Bool.not_true, exists_and_right, and_congr_right_iff]
|
||||
intro w
|
||||
constructor
|
||||
· rintro ⟨as, ⟨⟨x, rfl⟩, h⟩⟩
|
||||
exact ⟨as.toArray, ⟨x.toArray, by simp⟩ , by simpa using h⟩
|
||||
· rintro ⟨as, ⟨⟨x, h'⟩, h⟩⟩
|
||||
exact ⟨as.toList, ⟨x.toList, by simpa using congrArg Array.toList h'⟩,
|
||||
by simpa using h⟩
|
||||
|
||||
@[simp]
|
||||
theorem find?_push_eq_some {xs : Array α} :
|
||||
(xs.push a).find? p = some b ↔ xs.find? p = some b ∨ (xs.find? p = none ∧ (p a ∧ a = b)) := by
|
||||
cases xs; simp
|
||||
|
||||
@[simp] theorem find?_isSome {xs : Array α} {p : α → Bool} : (xs.find? p).isSome ↔ ∃ x, x ∈ xs ∧ p x := by
|
||||
cases xs; simp
|
||||
|
||||
theorem find?_some {xs : Array α} (h : find? p xs = some a) : p a := by
|
||||
cases xs
|
||||
simp at h
|
||||
exact List.find?_some h
|
||||
|
||||
theorem mem_of_find?_eq_some {xs : Array α} (h : find? p xs = some a) : a ∈ xs := by
|
||||
cases xs
|
||||
simp at h
|
||||
simpa using List.mem_of_find?_eq_some h
|
||||
|
||||
theorem get_find?_mem {xs : Array α} (h) : (xs.find? p).get h ∈ xs := by
|
||||
cases xs
|
||||
simp [List.get_find?_mem]
|
||||
|
||||
@[simp] theorem find?_filter {xs : Array α} (p q : α → Bool) :
|
||||
(xs.filter p).find? q = xs.find? (fun a => p a ∧ q a) := by
|
||||
cases xs; simp
|
||||
|
||||
@[simp] theorem getElem?_zero_filter (p : α → Bool) (l : Array α) :
|
||||
(l.filter p)[0]? = l.find? p := by
|
||||
cases l; simp [← List.head?_eq_getElem?]
|
||||
|
||||
@[simp] theorem getElem_zero_filter (p : α → Bool) (l : Array α) (h) :
|
||||
(l.filter p)[0] =
|
||||
(l.find? p).get (by cases l; simpa [← List.countP_eq_length_filter] using h) := by
|
||||
cases l
|
||||
simp [List.getElem_zero_eq_head]
|
||||
|
||||
@[simp] theorem back?_filter (p : α → Bool) (l : Array α) : (l.filter p).back? = l.findRev? p := by
|
||||
cases l; simp
|
||||
|
||||
@[simp] theorem back!_filter [Inhabited α] (p : α → Bool) (l : Array α) :
|
||||
(l.filter p).back! = (l.findRev? p).get! := by
|
||||
cases l; simp [Option.get!_eq_getD]
|
||||
|
||||
@[simp] theorem find?_filterMap (xs : Array α) (f : α → Option β) (p : β → Bool) :
|
||||
(xs.filterMap f).find? p = (xs.find? (fun a => (f a).any p)).bind f := by
|
||||
cases xs; simp
|
||||
|
||||
@[simp] theorem find?_map (f : β → α) (xs : Array β) :
|
||||
find? p (xs.map f) = (xs.find? (p ∘ f)).map f := by
|
||||
cases xs; simp
|
||||
|
||||
@[simp] theorem find?_append {l₁ l₂ : Array α} :
|
||||
(l₁ ++ l₂).find? p = (l₁.find? p).or (l₂.find? p) := by
|
||||
cases l₁
|
||||
cases l₂
|
||||
simp
|
||||
|
||||
@[simp] theorem find?_flatten (xs : Array (Array α)) (p : α → Bool) :
|
||||
xs.flatten.find? p = xs.findSome? (·.find? p) := by
|
||||
cases xs using array_array_induction
|
||||
simp [List.findSome?_map, Function.comp_def]
|
||||
|
||||
theorem find?_flatten_eq_none {xs : Array (Array α)} {p : α → Bool} :
|
||||
xs.flatten.find? p = none ↔ ∀ ys ∈ xs, ∀ x ∈ ys, !p x := by
|
||||
simp
|
||||
|
||||
/--
|
||||
If `find? p` returns `some a` from `xs.flatten`, then `p a` holds, and
|
||||
some array in `xs` contains `a`, and no earlier element of that array satisfies `p`.
|
||||
Moreover, no earlier array in `xs` has an element satisfying `p`.
|
||||
-/
|
||||
theorem find?_flatten_eq_some {xs : Array (Array α)} {p : α → Bool} {a : α} :
|
||||
xs.flatten.find? p = some a ↔
|
||||
p a ∧ ∃ (as : Array (Array α)) (ys zs : Array α) (bs : Array (Array α)),
|
||||
xs = as.push (ys.push a ++ zs) ++ bs ∧
|
||||
(∀ a ∈ as, ∀ x ∈ a, !p x) ∧ (∀ x ∈ ys, !p x) := by
|
||||
cases xs using array_array_induction
|
||||
simp only [flatten_toArray_map_toArray, List.find?_toArray, List.find?_flatten_eq_some]
|
||||
simp only [Bool.not_eq_eq_eq_not, Bool.not_true, exists_and_right, and_congr_right_iff]
|
||||
intro w
|
||||
constructor
|
||||
· rintro ⟨as, ys, ⟨⟨zs, bs, rfl⟩, h₁, h₂⟩⟩
|
||||
exact ⟨as.toArray.map List.toArray, ys.toArray,
|
||||
⟨zs.toArray, bs.toArray.map List.toArray, by simp⟩, by simpa using h₁, by simpa using h₂⟩
|
||||
· rintro ⟨as, ys, ⟨⟨zs, bs, h⟩, h₁, h₂⟩⟩
|
||||
replace h := congrArg (·.map Array.toList) (congrArg Array.toList h)
|
||||
simp [Function.comp_def] at h
|
||||
exact ⟨as.toList.map Array.toList, ys.toList,
|
||||
⟨zs.toList, bs.toList.map Array.toList, by simpa using h⟩,
|
||||
by simpa using h₁, by simpa using h₂⟩
|
||||
|
||||
@[simp] theorem find?_flatMap (xs : Array α) (f : α → Array β) (p : β → Bool) :
|
||||
(xs.flatMap f).find? p = xs.findSome? (fun x => (f x).find? p) := by
|
||||
cases xs
|
||||
simp [List.find?_flatMap, Array.flatMap_toArray]
|
||||
|
||||
theorem find?_flatMap_eq_none {xs : Array α} {f : α → Array β} {p : β → Bool} :
|
||||
(xs.flatMap f).find? p = none ↔ ∀ x ∈ xs, ∀ y ∈ f x, !p y := by
|
||||
simp
|
||||
|
||||
theorem find?_mkArray :
|
||||
find? p (mkArray n a) = if n = 0 then none else if p a then some a else none := by
|
||||
simp [mkArray_eq_toArray_replicate, List.find?_replicate]
|
||||
|
||||
@[simp] theorem find?_mkArray_of_length_pos (h : 0 < n) :
|
||||
find? p (mkArray n a) = if p a then some a else none := by
|
||||
simp [find?_mkArray, Nat.ne_of_gt h]
|
||||
|
||||
@[simp] theorem find?_mkArray_of_pos (h : p a) :
|
||||
find? p (mkArray n a) = if n = 0 then none else some a := by
|
||||
simp [find?_mkArray, h]
|
||||
|
||||
@[simp] theorem find?_mkArray_of_neg (h : ¬ p a) : find? p (mkArray n a) = none := by
|
||||
simp [find?_mkArray, h]
|
||||
|
||||
-- This isn't a `@[simp]` lemma since there is already a lemma for `l.find? p = none` for any `l`.
|
||||
theorem find?_mkArray_eq_none {n : Nat} {a : α} {p : α → Bool} :
|
||||
(mkArray n a).find? p = none ↔ n = 0 ∨ !p a := by
|
||||
simp [mkArray_eq_toArray_replicate, List.find?_replicate_eq_none, Classical.or_iff_not_imp_left]
|
||||
|
||||
@[simp] theorem find?_mkArray_eq_some {n : Nat} {a b : α} {p : α → Bool} :
|
||||
(mkArray n a).find? p = some b ↔ n ≠ 0 ∧ p a ∧ a = b := by
|
||||
simp [mkArray_eq_toArray_replicate]
|
||||
|
||||
@[simp] theorem get_find?_mkArray (n : Nat) (a : α) (p : α → Bool) (h) :
|
||||
((mkArray n a).find? p).get h = a := by
|
||||
simp [mkArray_eq_toArray_replicate]
|
||||
|
||||
theorem find?_pmap {P : α → Prop} (f : (a : α) → P a → β) (xs : Array α)
|
||||
(H : ∀ (a : α), a ∈ xs → P a) (p : β → Bool) :
|
||||
(xs.pmap f H).find? p = (xs.attach.find? (fun ⟨a, m⟩ => p (f a (H a m)))).map fun ⟨a, m⟩ => f a (H a m) := by
|
||||
simp only [pmap_eq_map_attach, find?_map]
|
||||
rfl
|
||||
|
||||
end Array
|
||||
@@ -23,6 +23,9 @@ import Init.TacticsExtra
|
||||
|
||||
namespace Array
|
||||
|
||||
@[simp] theorem mem_toArray {a : α} {l : List α} : a ∈ l.toArray ↔ a ∈ l := by
|
||||
simp [mem_def]
|
||||
|
||||
@[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] := rfl
|
||||
@@ -36,12 +39,21 @@ theorem getElem?_eq_getElem {a : Array α} {i : Nat} (h : i < a.size) : a[i]? =
|
||||
· rw [getElem?_neg a i h]
|
||||
simp_all
|
||||
|
||||
@[simp] theorem none_eq_getElem?_iff {a : Array α} {i : Nat} : none = a[i]? ↔ a.size ≤ i := by
|
||||
simp [eq_comm (a := none)]
|
||||
|
||||
theorem getElem?_eq {a : Array α} {i : Nat} :
|
||||
a[i]? = if h : i < a.size then some a[i] else none := by
|
||||
split
|
||||
· simp_all [getElem?_eq_getElem]
|
||||
· simp_all
|
||||
|
||||
theorem getElem?_eq_some_iff {a : Array α} : a[i]? = some b ↔ ∃ h : i < a.size, a[i] = b := by
|
||||
simp [getElem?_eq]
|
||||
|
||||
theorem some_eq_getElem?_iff {a : Array α} : some b = a[i]? ↔ ∃ h : i < a.size, a[i] = b := by
|
||||
rw [eq_comm, getElem?_eq_some_iff]
|
||||
|
||||
theorem getElem?_eq_getElem?_toList (a : Array α) (i : Nat) : a[i]? = a.toList[i]? := by
|
||||
rw [getElem?_eq]
|
||||
split <;> simp_all
|
||||
@@ -66,6 +78,35 @@ theorem getElem_push (a : Array α) (x : α) (i : Nat) (h : i < (a.push x).size)
|
||||
@[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 mem_push {a : Array α} {x y : α} : x ∈ a.push y ↔ x ∈ a ∨ x = y := by
|
||||
simp [mem_def]
|
||||
|
||||
theorem mem_push_self {a : Array α} {x : α} : x ∈ a.push x :=
|
||||
mem_push.2 (Or.inr rfl)
|
||||
|
||||
theorem mem_push_of_mem {a : Array α} {x : α} (y : α) (h : x ∈ a) : x ∈ a.push y :=
|
||||
mem_push.2 (Or.inl h)
|
||||
|
||||
theorem getElem_of_mem {a} {l : Array α} (h : a ∈ l) : ∃ (n : Nat) (h : n < l.size), l[n]'h = a := by
|
||||
cases l
|
||||
simp [List.getElem_of_mem (by simpa using h)]
|
||||
|
||||
theorem getElem?_of_mem {a} {l : Array α} (h : a ∈ l) : ∃ n : Nat, l[n]? = some a :=
|
||||
let ⟨n, _, e⟩ := getElem_of_mem h; ⟨n, e ▸ getElem?_eq_getElem _⟩
|
||||
|
||||
theorem mem_of_getElem? {l : Array α} {n : Nat} {a : α} (e : l[n]? = some a) : a ∈ l :=
|
||||
let ⟨_, e⟩ := getElem?_eq_some_iff.1 e; e ▸ getElem_mem ..
|
||||
|
||||
theorem mem_iff_getElem {a} {l : Array α} : a ∈ l ↔ ∃ (n : Nat) (h : n < l.size), l[n]'h = a :=
|
||||
⟨getElem_of_mem, fun ⟨_, _, e⟩ => e ▸ getElem_mem ..⟩
|
||||
|
||||
theorem mem_iff_getElem? {a} {l : Array α} : a ∈ l ↔ ∃ n : Nat, l[n]? = some a := by
|
||||
simp [getElem?_eq_some_iff, mem_iff_getElem]
|
||||
|
||||
theorem forall_getElem {l : Array α} {p : α → Prop} :
|
||||
(∀ (n : Nat) h, p (l[n]'h)) ↔ ∀ a, a ∈ l → p a := by
|
||||
cases l; simp [List.forall_getElem]
|
||||
|
||||
@[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
|
||||
@@ -93,9 +134,6 @@ We prefer to pull `List.toArray` outwards.
|
||||
(a.toArrayAux b).size = b.size + a.length := by
|
||||
simp [size]
|
||||
|
||||
@[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'
|
||||
simp
|
||||
@@ -151,15 +189,15 @@ theorem foldrM_toArray [Monad m] (f : α → β → m β) (init : β) (l : List
|
||||
|
||||
theorem foldlM_toArray [Monad m] (f : β → α → m β) (init : β) (l : List α) :
|
||||
l.toArray.foldlM f init = l.foldlM f init := by
|
||||
rw [foldlM_eq_foldlM_toList]
|
||||
rw [foldlM_toList]
|
||||
|
||||
theorem foldr_toArray (f : α → β → β) (init : β) (l : List α) :
|
||||
l.toArray.foldr f init = l.foldr f init := by
|
||||
rw [foldr_eq_foldr_toList]
|
||||
rw [foldr_toList]
|
||||
|
||||
theorem foldl_toArray (f : β → α → β) (init : β) (l : List α) :
|
||||
l.toArray.foldl f init = l.foldl f init := by
|
||||
rw [foldl_eq_foldl_toList]
|
||||
rw [foldl_toList]
|
||||
|
||||
/-- Variant of `foldrM_toArray` with a side condition for the `start` argument. -/
|
||||
@[simp] theorem foldrM_toArray' [Monad m] (f : α → β → m β) (init : β) (l : List α)
|
||||
@@ -174,21 +212,21 @@ theorem foldl_toArray (f : β → α → β) (init : β) (l : List α) :
|
||||
(h : stop = l.toArray.size) :
|
||||
l.toArray.foldlM f init 0 stop = l.foldlM f init := by
|
||||
subst h
|
||||
rw [foldlM_eq_foldlM_toList]
|
||||
rw [foldlM_toList]
|
||||
|
||||
/-- Variant of `foldr_toArray` with a side condition for the `start` argument. -/
|
||||
@[simp] theorem foldr_toArray' (f : α → β → β) (init : β) (l : List α)
|
||||
(h : start = l.toArray.size) :
|
||||
l.toArray.foldr f init start 0 = l.foldr f init := by
|
||||
subst h
|
||||
rw [foldr_eq_foldr_toList]
|
||||
rw [foldr_toList]
|
||||
|
||||
/-- Variant of `foldl_toArray` with a side condition for the `stop` argument. -/
|
||||
@[simp] theorem foldl_toArray' (f : β → α → β) (init : β) (l : List α)
|
||||
(h : stop = l.toArray.size) :
|
||||
l.toArray.foldl f init 0 stop = l.foldl f init := by
|
||||
subst h
|
||||
rw [foldl_eq_foldl_toList]
|
||||
rw [foldl_toList]
|
||||
|
||||
@[simp] theorem append_toArray (l₁ l₂ : List α) :
|
||||
l₁.toArray ++ l₂.toArray = (l₁ ++ l₂).toArray := by
|
||||
@@ -202,6 +240,9 @@ theorem foldl_toArray (f : β → α → β) (init : β) (l : List α) :
|
||||
@[simp] theorem foldl_push {l : List α} {as : Array α} : l.foldl Array.push as = as ++ l.toArray := by
|
||||
induction l generalizing as <;> simp [*]
|
||||
|
||||
@[simp] theorem foldr_push {l : List α} {as : Array α} : l.foldr (fun a b => push b a) as = as ++ l.reverse.toArray := by
|
||||
rw [foldr_eq_foldl_reverse, foldl_push]
|
||||
|
||||
@[simp] theorem findSomeM?_toArray [Monad m] [LawfulMonad m] (f : α → m (Option β)) (l : List α) :
|
||||
l.toArray.findSomeM? f = l.findSomeM? f := by
|
||||
rw [Array.findSomeM?]
|
||||
@@ -362,7 +403,8 @@ namespace Array
|
||||
|
||||
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]
|
||||
simp only [foldrM_eq_reverse_foldlM_toList, push_toList, List.reverse_append, List.reverse_cons,
|
||||
List.reverse_nil, List.nil_append, List.singleton_append, List.foldlM_cons, List.foldlM_reverse]
|
||||
|
||||
/--
|
||||
Variant of `foldrM_push` with `h : start = arr.size + 1`
|
||||
@@ -388,11 +430,11 @@ rather than `(arr.push a).size` as the argument.
|
||||
@[inline] def toListRev (arr : Array α) : List α := arr.foldl (fun l t => t :: l) []
|
||||
|
||||
@[simp] theorem toListRev_eq (arr : Array α) : arr.toListRev = arr.toList.reverse := by
|
||||
rw [toListRev, foldl_eq_foldl_toList, ← List.foldr_reverse, List.foldr_cons_nil]
|
||||
rw [toListRev, ← foldl_toList, ← List.foldr_reverse, List.foldr_cons_nil]
|
||||
|
||||
theorem mapM_eq_foldlM [Monad m] [LawfulMonad m] (f : α → m β) (arr : Array α) :
|
||||
arr.mapM f = arr.foldlM (fun bs a => bs.push <$> f a) #[] := by
|
||||
rw [mapM, aux, foldlM_eq_foldlM_toList]; rfl
|
||||
rw [mapM, aux, ← foldlM_toList]; rfl
|
||||
where
|
||||
aux (i r) :
|
||||
mapM.map f arr i r = (arr.toList.drop i).foldlM (fun bs a => bs.push <$> f a) r := by
|
||||
@@ -407,7 +449,7 @@ where
|
||||
|
||||
@[simp] theorem toList_map (f : α → β) (arr : Array α) : (arr.map f).toList = arr.toList.map f := by
|
||||
rw [map, mapM_eq_foldlM]
|
||||
apply congrArg toList (foldl_eq_foldl_toList (fun bs a => push bs (f a)) #[] arr) |>.trans
|
||||
apply congrArg toList (foldl_toList (fun bs a => push bs (f a)) #[] arr).symm |>.trans
|
||||
have H (l arr) : List.foldl (fun bs a => push bs (f a)) arr l = ⟨arr.toList ++ l.map f⟩ := by
|
||||
induction l generalizing arr <;> simp [*]
|
||||
simp [H]
|
||||
@@ -597,38 +639,25 @@ theorem getElem?_mkArray (n : Nat) (v : α) (i : Nat) :
|
||||
|
||||
/-- # mem -/
|
||||
|
||||
theorem mem_toList {a : α} {l : Array α} : a ∈ l.toList ↔ a ∈ l := mem_def.symm
|
||||
@[simp] theorem mem_toList {a : α} {l : Array α} : a ∈ l.toList ↔ a ∈ l := mem_def.symm
|
||||
|
||||
theorem not_mem_nil (a : α) : ¬ a ∈ #[] := nofun
|
||||
|
||||
theorem getElem_of_mem {a : α} {as : Array α} :
|
||||
a ∈ as → (∃ (n : Nat) (h : n < as.size), as[n]'h = a) := by
|
||||
intro ha
|
||||
rcases List.getElem_of_mem ha.val with ⟨i, hbound, hi⟩
|
||||
exists i
|
||||
exists hbound
|
||||
|
||||
theorem getElem?_of_mem {a : α} {as : Array α} :
|
||||
a ∈ as → ∃ (n : Nat), as[n]? = some a := by
|
||||
intro ha
|
||||
rcases List.getElem?_of_mem ha.val with ⟨i, hi⟩
|
||||
exists i
|
||||
|
||||
@[simp] theorem mem_dite_empty_left {x : α} [Decidable p] {l : ¬ p → Array α} :
|
||||
(x ∈ if h : p then #[] else l h) ↔ ∃ h : ¬ p, x ∈ l h := by
|
||||
split <;> simp_all [mem_def]
|
||||
split <;> simp_all
|
||||
|
||||
@[simp] theorem mem_dite_empty_right {x : α} [Decidable p] {l : p → Array α} :
|
||||
(x ∈ if h : p then l h else #[]) ↔ ∃ h : p, x ∈ l h := by
|
||||
split <;> simp_all [mem_def]
|
||||
split <;> simp_all
|
||||
|
||||
@[simp] theorem mem_ite_empty_left {x : α} [Decidable p] {l : Array α} :
|
||||
(x ∈ if p then #[] else l) ↔ ¬ p ∧ x ∈ l := by
|
||||
split <;> simp_all [mem_def]
|
||||
split <;> simp_all
|
||||
|
||||
@[simp] theorem mem_ite_empty_right {x : α} [Decidable p] {l : Array α} :
|
||||
(x ∈ if p then l else #[]) ↔ p ∧ x ∈ l := by
|
||||
split <;> simp_all [mem_def]
|
||||
split <;> simp_all
|
||||
|
||||
/-- # get lemmas -/
|
||||
|
||||
@@ -655,10 +684,6 @@ theorem get?_eq_get?_toList (a : Array α) (i : Nat) : a.get? i = a.toList.get?
|
||||
theorem get!_eq_get? [Inhabited α] (a : Array α) : a.get! n = (a.get? n).getD default := by
|
||||
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]
|
||||
|
||||
theorem back!_eq_back? [Inhabited α] (a : Array α) : a.back! = a.back?.getD default := by
|
||||
simp only [back!, get!_eq_getElem?, get?_eq_getElem?, back?]
|
||||
|
||||
@@ -668,6 +693,10 @@ theorem back!_eq_back? [Inhabited α] (a : Array α) : a.back! = a.back?.getD de
|
||||
@[simp] theorem back!_push [Inhabited α] (a : Array α) : (a.push x).back! = x := by
|
||||
simp [back!_eq_back?]
|
||||
|
||||
theorem mem_of_back?_eq_some {xs : Array α} {a : α} (h : xs.back? = some a) : a ∈ xs := by
|
||||
cases xs
|
||||
simpa using List.mem_of_getLast?_eq_some (by simpa using h)
|
||||
|
||||
theorem getElem?_push_lt (a : Array α) (x : α) (i : Nat) (h : i < a.size) :
|
||||
(a.push x)[i]? = some a[i] := by
|
||||
rw [getElem?_pos, getElem_push_lt]
|
||||
@@ -1021,9 +1050,13 @@ theorem foldr_congr {as bs : Array α} (h₀ : as = bs) {f g : α → β → β}
|
||||
@[simp] theorem mem_map {f : α → β} {l : Array α} : b ∈ l.map f ↔ ∃ a, a ∈ l ∧ f a = b := by
|
||||
simp only [mem_def, toList_map, List.mem_map]
|
||||
|
||||
theorem exists_of_mem_map (h : b ∈ map f l) : ∃ a, a ∈ l ∧ f a = b := mem_map.1 h
|
||||
|
||||
theorem mem_map_of_mem (f : α → β) (h : a ∈ l) : f a ∈ map f l := mem_map.2 ⟨_, h, rfl⟩
|
||||
|
||||
theorem mapM_eq_mapM_toList [Monad m] [LawfulMonad m] (f : α → m β) (arr : Array α) :
|
||||
arr.mapM f = List.toArray <$> (arr.toList.mapM f) := by
|
||||
rw [mapM_eq_foldlM, foldlM_eq_foldlM_toList, ← List.foldrM_reverse]
|
||||
rw [mapM_eq_foldlM, ← foldlM_toList, ← List.foldrM_reverse]
|
||||
conv => rhs; rw [← List.reverse_reverse arr.toList]
|
||||
induction arr.toList.reverse with
|
||||
| nil => simp
|
||||
@@ -1148,7 +1181,7 @@ theorem getElem?_modify {as : Array α} {i : Nat} {f : α → α} {j : Nat} :
|
||||
@[simp] theorem toList_filter (p : α → Bool) (l : Array α) :
|
||||
(l.filter p).toList = l.toList.filter p := by
|
||||
dsimp only [filter]
|
||||
rw [foldl_eq_foldl_toList]
|
||||
rw [← foldl_toList]
|
||||
generalize l.toList = l
|
||||
suffices ∀ a, (List.foldl (fun r a => if p a = true then push r a else r) a l).toList =
|
||||
a.toList ++ List.filter p l by
|
||||
@@ -1179,7 +1212,7 @@ theorem filter_congr {as bs : Array α} (h : as = bs)
|
||||
@[simp] theorem toList_filterMap (f : α → Option β) (l : Array α) :
|
||||
(l.filterMap f).toList = l.toList.filterMap f := by
|
||||
dsimp only [filterMap, filterMapM]
|
||||
rw [foldlM_eq_foldlM_toList]
|
||||
rw [← foldlM_toList]
|
||||
generalize l.toList = l
|
||||
have this : ∀ a : Array β, (Id.run (List.foldlM (m := Id) ?_ a l)).toList =
|
||||
a.toList ++ List.filterMap f l := ?_
|
||||
@@ -1211,9 +1244,23 @@ theorem push_eq_append_singleton (as : Array α) (x) : as.push x = as ++ #[x] :=
|
||||
@[simp] theorem mem_append {a : α} {s t : Array α} : a ∈ s ++ t ↔ a ∈ s ∨ a ∈ t := by
|
||||
simp only [mem_def, toList_append, List.mem_append]
|
||||
|
||||
theorem mem_append_left {a : α} {l₁ : Array α} (l₂ : Array α) (h : a ∈ l₁) : a ∈ l₁ ++ l₂ :=
|
||||
mem_append.2 (Or.inl h)
|
||||
|
||||
theorem mem_append_right {a : α} (l₁ : Array α) {l₂ : Array α} (h : a ∈ l₂) : a ∈ l₁ ++ l₂ :=
|
||||
mem_append.2 (Or.inr h)
|
||||
|
||||
@[simp] theorem size_append (as bs : Array α) : (as ++ bs).size = as.size + bs.size := by
|
||||
simp only [size, toList_append, List.length_append]
|
||||
|
||||
@[simp] theorem empty_append (as : Array α) : #[] ++ as = as := by
|
||||
cases as
|
||||
simp
|
||||
|
||||
@[simp] theorem append_empty (as : Array α) : as ++ #[] = as := by
|
||||
cases as
|
||||
simp
|
||||
|
||||
theorem getElem_append {as bs : Array α} (h : i < (as ++ bs).size) :
|
||||
(as ++ bs)[i] = if h' : i < as.size then as[i] else bs[i - as.size]'(by simp at h; omega) := by
|
||||
cases as; cases bs
|
||||
@@ -1258,7 +1305,7 @@ theorem getElem?_append {as bs : Array α} {n : Nat} :
|
||||
@[simp] theorem toList_flatten {l : Array (Array α)} :
|
||||
l.flatten.toList = (l.toList.map toList).flatten := by
|
||||
dsimp [flatten]
|
||||
simp only [foldl_eq_foldl_toList]
|
||||
simp only [← foldl_toList]
|
||||
generalize l.toList = l
|
||||
have : ∀ a : Array α, (List.foldl ?_ a l).toList = a.toList ++ ?_ := ?_
|
||||
exact this #[]
|
||||
@@ -1872,6 +1919,76 @@ namespace Array
|
||||
induction as
|
||||
simp
|
||||
|
||||
/-! ### map -/
|
||||
|
||||
@[simp] theorem map_map {f : α → β} {g : β → γ} {as : Array α} :
|
||||
(as.map f).map g = as.map (g ∘ f) := by
|
||||
cases as; simp
|
||||
|
||||
@[simp] theorem map_id_fun : map (id : α → α) = id := by
|
||||
funext l
|
||||
induction l <;> simp_all
|
||||
|
||||
/-- `map_id_fun'` differs from `map_id_fun` by representing the identity function as a lambda, rather than `id`. -/
|
||||
@[simp] theorem map_id_fun' : map (fun (a : α) => a) = id := map_id_fun
|
||||
|
||||
-- This is not a `@[simp]` lemma because `map_id_fun` will apply.
|
||||
theorem map_id (as : Array α) : map (id : α → α) as = as := by
|
||||
cases as <;> simp_all
|
||||
|
||||
/-- `map_id'` differs from `map_id` by representing the identity function as a lambda, rather than `id`. -/
|
||||
-- This is not a `@[simp]` lemma because `map_id_fun'` will apply.
|
||||
theorem map_id' (as : Array α) : map (fun (a : α) => a) as = as := map_id as
|
||||
|
||||
/-- Variant of `map_id`, with a side condition that the function is pointwise the identity. -/
|
||||
theorem map_id'' {f : α → α} (h : ∀ x, f x = x) (as : Array α) : map f as = as := by
|
||||
simp [show f = id from funext h]
|
||||
|
||||
theorem array_array_induction (P : Array (Array α) → Prop) (h : ∀ (xss : List (List α)), P (xss.map List.toArray).toArray)
|
||||
(ass : Array (Array α)) : P ass := by
|
||||
specialize h (ass.toList.map toList)
|
||||
simpa [← toList_map, Function.comp_def, map_id] using h
|
||||
|
||||
theorem foldl_map (f : β₁ → β₂) (g : α → β₂ → α) (l : Array β₁) (init : α) :
|
||||
(l.map f).foldl g init = l.foldl (fun x y => g x (f y)) init := by
|
||||
cases l; simp [List.foldl_map]
|
||||
|
||||
theorem foldr_map (f : α₁ → α₂) (g : α₂ → β → β) (l : Array α₁) (init : β) :
|
||||
(l.map f).foldr g init = l.foldr (fun x y => g (f x) y) init := by
|
||||
cases l; simp [List.foldr_map]
|
||||
|
||||
theorem foldl_filterMap (f : α → Option β) (g : γ → β → γ) (l : Array α) (init : γ) :
|
||||
(l.filterMap f).foldl g init = l.foldl (fun x y => match f y with | some b => g x b | none => x) init := by
|
||||
cases l
|
||||
simp [List.foldl_filterMap]
|
||||
rfl
|
||||
|
||||
theorem foldr_filterMap (f : α → Option β) (g : β → γ → γ) (l : Array α) (init : γ) :
|
||||
(l.filterMap f).foldr g init = l.foldr (fun x y => match f x with | some b => g b y | none => y) init := by
|
||||
cases l
|
||||
simp [List.foldr_filterMap]
|
||||
rfl
|
||||
|
||||
/-! ### flatten -/
|
||||
|
||||
@[simp] theorem flatten_empty : flatten (#[] : Array (Array α)) = #[] := rfl
|
||||
|
||||
@[simp] theorem flatten_toArray_map_toArray (xss : List (List α)) :
|
||||
(xss.map List.toArray).toArray.flatten = xss.flatten.toArray := by
|
||||
simp [flatten]
|
||||
suffices ∀ as, List.foldl (fun r a => r ++ a) as (List.map List.toArray xss) = as ++ xss.flatten.toArray by
|
||||
simpa using this #[]
|
||||
intro as
|
||||
induction xss generalizing as with
|
||||
| nil => simp
|
||||
| cons xs xss ih => simp [ih]
|
||||
|
||||
/-! ### reverse -/
|
||||
|
||||
@[simp] theorem mem_reverse {x : α} {as : Array α} : x ∈ as.reverse ↔ x ∈ as := by
|
||||
cases as
|
||||
simp
|
||||
|
||||
/-! ### findSomeRevM?, findRevM?, findSomeRev?, findRev? -/
|
||||
|
||||
@[simp] theorem findSomeRevM?_eq_findSomeM?_reverse
|
||||
@@ -1936,6 +2053,27 @@ namespace Array
|
||||
cases as
|
||||
simp
|
||||
|
||||
@[simp] theorem flatMap_empty {β} (f : α → Array β) : (#[] : Array α).flatMap f = #[] := rfl
|
||||
|
||||
@[simp] theorem flatMap_toArray_cons {β} (f : α → Array β) (a : α) (as : List α) :
|
||||
(a :: as).toArray.flatMap f = f a ++ as.toArray.flatMap f := by
|
||||
simp [flatMap]
|
||||
suffices ∀ cs, List.foldl (fun bs a => bs ++ f a) (f a ++ cs) as =
|
||||
f a ++ List.foldl (fun bs a => bs ++ f a) cs as by
|
||||
erw [empty_append] -- Why doesn't this work via `simp`?
|
||||
simpa using this #[]
|
||||
intro cs
|
||||
induction as generalizing cs <;> simp_all
|
||||
|
||||
@[simp] theorem flatMap_toArray {β} (f : α → Array β) (as : List α) :
|
||||
as.toArray.flatMap f = (as.flatMap (fun a => (f a).toList)).toArray := by
|
||||
induction as with
|
||||
| nil => simp
|
||||
| cons a as ih =>
|
||||
apply ext'
|
||||
simp [ih]
|
||||
|
||||
|
||||
end Array
|
||||
|
||||
/-! ### Deprecations -/
|
||||
|
||||
159
src/Init/Data/Array/Monadic.lean
Normal file
159
src/Init/Data/Array/Monadic.lean
Normal file
@@ -0,0 +1,159 @@
|
||||
/-
|
||||
Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Kim Morrison
|
||||
-/
|
||||
prelude
|
||||
import Init.Data.Array.Lemmas
|
||||
import Init.Data.Array.Attach
|
||||
import Init.Data.List.Monadic
|
||||
|
||||
/-!
|
||||
# Lemmas about `Array.forIn'` and `Array.forIn`.
|
||||
-/
|
||||
|
||||
namespace Array
|
||||
|
||||
open Nat
|
||||
|
||||
/-! ## Monadic operations -/
|
||||
|
||||
/-! ### mapM -/
|
||||
|
||||
theorem mapM_eq_foldlM_push [Monad m] [LawfulMonad m] (f : α → m β) (l : Array α) :
|
||||
mapM f l = l.foldlM (fun acc a => return (acc.push (← f a))) #[] := by
|
||||
rcases l with ⟨l⟩
|
||||
simp only [List.mapM_toArray, bind_pure_comp, size_toArray, List.foldlM_toArray']
|
||||
rw [List.mapM_eq_reverse_foldlM_cons]
|
||||
simp only [bind_pure_comp, Functor.map_map]
|
||||
suffices ∀ (k), (fun a => a.reverse.toArray) <$> List.foldlM (fun acc a => (fun a => a :: acc) <$> f a) k l =
|
||||
List.foldlM (fun acc a => acc.push <$> f a) k.reverse.toArray l by
|
||||
exact this []
|
||||
intro k
|
||||
induction l generalizing k with
|
||||
| nil => simp
|
||||
| cons a as ih =>
|
||||
simp [ih, List.foldlM_cons]
|
||||
|
||||
/-! ### foldlM and foldrM -/
|
||||
|
||||
theorem foldlM_map [Monad m] (f : β₁ → β₂) (g : α → β₂ → m α) (l : Array β₁) (init : α) :
|
||||
(l.map f).foldlM g init = l.foldlM (fun x y => g x (f y)) init := by
|
||||
cases l
|
||||
rw [List.map_toArray] -- Why doesn't this fire via `simp`?
|
||||
simp [List.foldlM_map]
|
||||
|
||||
theorem foldrM_map [Monad m] [LawfulMonad m] (f : β₁ → β₂) (g : β₂ → α → m α) (l : Array β₁)
|
||||
(init : α) : (l.map f).foldrM g init = l.foldrM (fun x y => g (f x) y) init := by
|
||||
cases l
|
||||
rw [List.map_toArray] -- Why doesn't this fire via `simp`?
|
||||
simp [List.foldrM_map]
|
||||
|
||||
theorem foldlM_filterMap [Monad m] [LawfulMonad m] (f : α → Option β) (g : γ → β → m γ) (l : Array α) (init : γ) :
|
||||
(l.filterMap f).foldlM g init =
|
||||
l.foldlM (fun x y => match f y with | some b => g x b | none => pure x) init := by
|
||||
cases l
|
||||
rw [List.filterMap_toArray] -- Why doesn't this fire via `simp`?
|
||||
simp [List.foldlM_filterMap]
|
||||
rfl
|
||||
|
||||
theorem foldrM_filterMap [Monad m] [LawfulMonad m] (f : α → Option β) (g : β → γ → m γ) (l : Array α) (init : γ) :
|
||||
(l.filterMap f).foldrM g init =
|
||||
l.foldrM (fun x y => match f x with | some b => g b y | none => pure y) init := by
|
||||
cases l
|
||||
rw [List.filterMap_toArray] -- Why doesn't this fire via `simp`?
|
||||
simp [List.foldrM_filterMap]
|
||||
rfl
|
||||
|
||||
theorem foldlM_filter [Monad m] [LawfulMonad m] (p : α → Bool) (g : β → α → m β) (l : Array α) (init : β) :
|
||||
(l.filter p).foldlM g init =
|
||||
l.foldlM (fun x y => if p y then g x y else pure x) init := by
|
||||
cases l
|
||||
rw [List.filter_toArray] -- Why doesn't this fire via `simp`?
|
||||
simp [List.foldlM_filter]
|
||||
|
||||
theorem foldrM_filter [Monad m] [LawfulMonad m] (p : α → Bool) (g : α → β → m β) (l : Array α) (init : β) :
|
||||
(l.filter p).foldrM g init =
|
||||
l.foldrM (fun x y => if p x then g x y else pure y) init := by
|
||||
cases l
|
||||
rw [List.filter_toArray] -- Why doesn't this fire via `simp`?
|
||||
simp [List.foldrM_filter]
|
||||
|
||||
/-! ### forIn' -/
|
||||
|
||||
/--
|
||||
We can express a for loop over an array as a fold,
|
||||
in which whenever we reach `.done b` we keep that value through the rest of the fold.
|
||||
-/
|
||||
theorem forIn'_eq_foldlM [Monad m] [LawfulMonad m]
|
||||
(l : Array α) (f : (a : α) → a ∈ l → β → m (ForInStep β)) (init : β) :
|
||||
forIn' l init f = ForInStep.value <$>
|
||||
l.attach.foldlM (fun b ⟨a, m⟩ => match b with
|
||||
| .yield b => f a m b
|
||||
| .done b => pure (.done b)) (ForInStep.yield init) := by
|
||||
cases l
|
||||
rw [List.attach_toArray] -- Why doesn't this fire via `simp`?
|
||||
simp only [List.forIn'_toArray, List.forIn'_eq_foldlM, List.attachWith_mem_toArray, size_toArray,
|
||||
List.length_map, List.length_attach, List.foldlM_toArray', List.foldlM_map]
|
||||
congr
|
||||
|
||||
/-- We can express a for loop over an array which always yields as a fold. -/
|
||||
@[simp] theorem forIn'_yield_eq_foldlM [Monad m] [LawfulMonad m]
|
||||
(l : Array α) (f : (a : α) → a ∈ l → β → m γ) (g : (a : α) → a ∈ l → β → γ → β) (init : β) :
|
||||
forIn' l init (fun a m b => (fun c => .yield (g a m b c)) <$> f a m b) =
|
||||
l.attach.foldlM (fun b ⟨a, m⟩ => g a m b <$> f a m b) init := by
|
||||
cases l
|
||||
rw [List.attach_toArray] -- Why doesn't this fire via `simp`?
|
||||
simp [List.foldlM_map]
|
||||
|
||||
theorem forIn'_pure_yield_eq_foldl [Monad m] [LawfulMonad m]
|
||||
(l : Array α) (f : (a : α) → a ∈ l → β → β) (init : β) :
|
||||
forIn' l init (fun a m b => pure (.yield (f a m b))) =
|
||||
pure (f := m) (l.attach.foldl (fun b ⟨a, h⟩ => f a h b) init) := by
|
||||
cases l
|
||||
simp [List.forIn'_pure_yield_eq_foldl, List.foldl_map]
|
||||
|
||||
@[simp] theorem forIn'_yield_eq_foldl
|
||||
(l : Array α) (f : (a : α) → a ∈ l → β → β) (init : β) :
|
||||
forIn' (m := Id) l init (fun a m b => .yield (f a m b)) =
|
||||
l.attach.foldl (fun b ⟨a, h⟩ => f a h b) init := by
|
||||
cases l
|
||||
simp [List.foldl_map]
|
||||
|
||||
/--
|
||||
We can express a for loop over an array as a fold,
|
||||
in which whenever we reach `.done b` we keep that value through the rest of the fold.
|
||||
-/
|
||||
theorem forIn_eq_foldlM [Monad m] [LawfulMonad m]
|
||||
(f : α → β → m (ForInStep β)) (init : β) (l : Array α) :
|
||||
forIn l init f = ForInStep.value <$>
|
||||
l.foldlM (fun b a => match b with
|
||||
| .yield b => f a b
|
||||
| .done b => pure (.done b)) (ForInStep.yield init) := by
|
||||
cases l
|
||||
simp only [List.forIn_toArray, List.forIn_eq_foldlM, size_toArray, List.foldlM_toArray']
|
||||
congr
|
||||
|
||||
/-- We can express a for loop over an array which always yields as a fold. -/
|
||||
@[simp] theorem forIn_yield_eq_foldlM [Monad m] [LawfulMonad m]
|
||||
(l : Array α) (f : α → β → m γ) (g : α → β → γ → β) (init : β) :
|
||||
forIn l init (fun a b => (fun c => .yield (g a b c)) <$> f a b) =
|
||||
l.foldlM (fun b a => g a b <$> f a b) init := by
|
||||
cases l
|
||||
simp [List.foldlM_map]
|
||||
|
||||
theorem forIn_pure_yield_eq_foldl [Monad m] [LawfulMonad m]
|
||||
(l : Array α) (f : α → β → β) (init : β) :
|
||||
forIn l init (fun a b => pure (.yield (f a b))) =
|
||||
pure (f := m) (l.foldl (fun b a => f a b) init) := by
|
||||
cases l
|
||||
simp [List.forIn_pure_yield_eq_foldl, List.foldl_map]
|
||||
|
||||
@[simp] theorem forIn_yield_eq_foldl
|
||||
(l : Array α) (f : α → β → β) (init : β) :
|
||||
forIn (m := Id) l init (fun a b => .yield (f a b)) =
|
||||
l.foldl (fun b a => f a b) init := by
|
||||
cases l
|
||||
simp [List.foldl_map]
|
||||
|
||||
end Array
|
||||
@@ -15,15 +15,6 @@ structure Subarray (α : Type u) where
|
||||
start_le_stop : start ≤ stop
|
||||
stop_le_array_size : stop ≤ array.size
|
||||
|
||||
@[deprecated Subarray.array (since := "2024-04-13")]
|
||||
abbrev Subarray.as (s : Subarray α) : Array α := s.array
|
||||
|
||||
@[deprecated Subarray.start_le_stop (since := "2024-04-13")]
|
||||
theorem Subarray.h₁ (s : Subarray α) : s.start ≤ s.stop := s.start_le_stop
|
||||
|
||||
@[deprecated Subarray.stop_le_array_size (since := "2024-04-13")]
|
||||
theorem Subarray.h₂ (s : Subarray α) : s.stop ≤ s.array.size := s.stop_le_array_size
|
||||
|
||||
namespace Subarray
|
||||
|
||||
def size (s : Subarray α) : Nat :=
|
||||
|
||||
@@ -29,9 +29,6 @@ section Nat
|
||||
|
||||
instance natCastInst : NatCast (BitVec w) := ⟨BitVec.ofNat w⟩
|
||||
|
||||
@[deprecated isLt (since := "2024-03-12")]
|
||||
theorem toNat_lt (x : BitVec n) : x.toNat < 2^n := x.isLt
|
||||
|
||||
/-- Theorem for normalizing the bit vector literal representation. -/
|
||||
-- TODO: This needs more usage data to assess which direction the simp should go.
|
||||
@[simp, bv_toNat] theorem ofNat_eq_ofNat : @OfNat.ofNat (BitVec n) i _ = .ofNat n i := rfl
|
||||
|
||||
@@ -403,7 +403,7 @@ theorem getLsbD_neg {i : Nat} {x : BitVec w} :
|
||||
rw [carry_succ_one _ _ (by omega), ← Bool.xor_not, ← decide_not]
|
||||
simp only [add_one_ne_zero, decide_false, getLsbD_not, and_eq_true, decide_eq_true_eq,
|
||||
not_eq_eq_eq_not, Bool.not_true, false_bne, not_exists, _root_.not_and, not_eq_true,
|
||||
bne_left_inj, decide_eq_decide]
|
||||
bne_right_inj, decide_eq_decide]
|
||||
constructor
|
||||
· rintro h j hj; exact And.right <| h j (by omega)
|
||||
· rintro h j hj; exact ⟨by omega, h j (by omega)⟩
|
||||
@@ -419,7 +419,7 @@ theorem getMsbD_neg {i : Nat} {x : BitVec w} :
|
||||
simp [hi]; omega
|
||||
case pos =>
|
||||
have h₁ : w - 1 - i < w := by omega
|
||||
simp only [hi, decide_true, h₁, Bool.true_and, Bool.bne_left_inj, decide_eq_decide]
|
||||
simp only [hi, decide_true, h₁, Bool.true_and, Bool.bne_right_inj, decide_eq_decide]
|
||||
constructor
|
||||
· rintro ⟨j, hj, h⟩
|
||||
refine ⟨w - 1 - j, by omega, by omega, by omega, _root_.cast ?_ h⟩
|
||||
|
||||
@@ -238,8 +238,8 @@ theorem not_bne_not : ∀ (x y : Bool), ((!x) != (!y)) = (x != y) := by simp
|
||||
@[simp] theorem bne_assoc : ∀ (x y z : Bool), ((x != y) != z) = (x != (y != z)) := by decide
|
||||
instance : Std.Associative (· != ·) := ⟨bne_assoc⟩
|
||||
|
||||
@[simp] theorem bne_left_inj : ∀ {x y z : Bool}, (x != y) = (x != z) ↔ y = z := by decide
|
||||
@[simp] theorem bne_right_inj : ∀ {x y z : Bool}, (x != z) = (y != z) ↔ x = y := by decide
|
||||
@[simp] theorem bne_right_inj : ∀ {x y z : Bool}, (x != y) = (x != z) ↔ y = z := by decide
|
||||
@[simp] theorem bne_left_inj : ∀ {x y z : Bool}, (x != z) = (y != z) ↔ x = y := by decide
|
||||
|
||||
theorem eq_not_of_ne : ∀ {x y : Bool}, x ≠ y → x = !y := by decide
|
||||
|
||||
@@ -295,9 +295,9 @@ theorem xor_right_comm : ∀ (x y z : Bool), ((x ^^ y) ^^ z) = ((x ^^ z) ^^ y) :
|
||||
|
||||
theorem xor_assoc : ∀ (x y z : Bool), ((x ^^ y) ^^ z) = (x ^^ (y ^^ z)) := bne_assoc
|
||||
|
||||
theorem xor_left_inj : ∀ {x y z : Bool}, (x ^^ y) = (x ^^ z) ↔ y = z := bne_left_inj
|
||||
theorem xor_right_inj : ∀ {x y z : Bool}, (x ^^ y) = (x ^^ z) ↔ y = z := bne_right_inj
|
||||
|
||||
theorem xor_right_inj : ∀ {x y z : Bool}, (x ^^ z) = (y ^^ z) ↔ x = y := bne_right_inj
|
||||
theorem xor_left_inj : ∀ {x y z : Bool}, (x ^^ z) = (y ^^ z) ↔ x = y := bne_left_inj
|
||||
|
||||
/-! ### le/lt -/
|
||||
|
||||
|
||||
@@ -642,7 +642,7 @@ theorem pred_add_one (i : Fin (n + 2)) (h : (i : Nat) < n + 1) :
|
||||
ext
|
||||
simp
|
||||
|
||||
@[simp] theorem subNat_one_succ (i : Fin (n + 1)) (h : 1 ≤ ↑i) : (subNat 1 i h).succ = i := by
|
||||
@[simp] theorem subNat_one_succ (i : Fin (n + 1)) (h : 1 ≤ (i : Nat)) : (subNat 1 i h).succ = i := by
|
||||
ext
|
||||
simp
|
||||
omega
|
||||
|
||||
@@ -47,6 +47,25 @@ def Float.lt : Float → Float → Prop := fun a b =>
|
||||
def Float.le : Float → Float → Prop := fun a b =>
|
||||
floatSpec.le a.val b.val
|
||||
|
||||
/--
|
||||
Raw transmutation from `UInt64`.
|
||||
|
||||
Floats and UInts have the same endianness on all supported platforms.
|
||||
IEEE 754 very precisely specifies the bit layout of floats.
|
||||
-/
|
||||
@[extern "lean_float_of_bits"] opaque Float.ofBits : UInt64 → Float
|
||||
|
||||
/--
|
||||
Raw transmutation to `UInt64`.
|
||||
|
||||
Floats and UInts have the same endianness on all supported platforms.
|
||||
IEEE 754 very precisely specifies the bit layout of floats.
|
||||
|
||||
Note that this function is distinct from `Float.toUInt64`, which attempts
|
||||
to preserve the numeric value, and not the bitwise value.
|
||||
-/
|
||||
@[extern "lean_float_to_bits"] opaque Float.toBits : Float → UInt64
|
||||
|
||||
instance : Add Float := ⟨Float.add⟩
|
||||
instance : Sub Float := ⟨Float.sub⟩
|
||||
instance : Mul Float := ⟨Float.mul⟩
|
||||
|
||||
@@ -329,22 +329,22 @@ theorem toNat_sub (m n : Nat) : toNat (m - n) = m - n := by
|
||||
/- ## add/sub injectivity -/
|
||||
|
||||
@[simp]
|
||||
protected theorem add_right_inj {i j : Int} (k : Int) : (i + k = j + k) ↔ i = j := by
|
||||
protected theorem add_left_inj {i j : Int} (k : Int) : (i + k = j + k) ↔ i = j := by
|
||||
apply Iff.intro
|
||||
· intro p
|
||||
rw [←Int.add_sub_cancel i k, ←Int.add_sub_cancel j k, p]
|
||||
· exact congrArg (· + k)
|
||||
|
||||
@[simp]
|
||||
protected theorem add_left_inj {i j : Int} (k : Int) : (k + i = k + j) ↔ i = j := by
|
||||
protected theorem add_right_inj {i j : Int} (k : Int) : (k + i = k + j) ↔ i = j := by
|
||||
simp [Int.add_comm k]
|
||||
|
||||
@[simp]
|
||||
protected theorem sub_left_inj {i j : Int} (k : Int) : (k - i = k - j) ↔ i = j := by
|
||||
protected theorem sub_right_inj {i j : Int} (k : Int) : (k - i = k - j) ↔ i = j := by
|
||||
simp [Int.sub_eq_add_neg, Int.neg_inj]
|
||||
|
||||
@[simp]
|
||||
protected theorem sub_right_inj {i j : Int} (k : Int) : (i - k = j - k) ↔ i = j := by
|
||||
protected theorem sub_left_inj {i j : Int} (k : Int) : (i - k = j - k) ↔ i = j := by
|
||||
simp [Int.sub_eq_add_neg]
|
||||
|
||||
/- ## Ring properties -/
|
||||
|
||||
@@ -13,7 +13,7 @@ namespace List
|
||||
`a : α` satisfying `P`, then `pmap f l h` is essentially the same as `map f l`
|
||||
but is defined only when all members of `l` satisfy `P`, using the proof
|
||||
to apply `f`. -/
|
||||
@[simp] def pmap {P : α → Prop} (f : ∀ a, P a → β) : ∀ l : List α, (H : ∀ a ∈ l, P a) → List β
|
||||
def pmap {P : α → Prop} (f : ∀ a, P a → β) : ∀ l : List α, (H : ∀ a ∈ l, P a) → List β
|
||||
| [], _ => []
|
||||
| a :: l, H => f a (forall_mem_cons.1 H).1 :: pmap f l (forall_mem_cons.1 H).2
|
||||
|
||||
@@ -46,6 +46,11 @@ Unsafe implementation of `attachWith`, taking advantage of the fact that the rep
|
||||
| cons _ L', hL' => congrArg _ <| go L' fun _ hx => hL' (.tail _ hx)
|
||||
exact go L h'
|
||||
|
||||
@[simp] theorem pmap_nil {P : α → Prop} (f : ∀ a, P a → β) : pmap f [] (by simp) = [] := rfl
|
||||
|
||||
@[simp] theorem pmap_cons {P : α → Prop} (f : ∀ a, P a → β) (a : α) (l : List α) (h : ∀ b ∈ a :: l, P b) :
|
||||
pmap f (a :: l) h = f a (forall_mem_cons.1 h).1 :: pmap f l (forall_mem_cons.1 h).2 := rfl
|
||||
|
||||
@[simp] theorem attach_nil : ([] : List α).attach = [] := rfl
|
||||
|
||||
@[simp] theorem attachWith_nil : ([] : List α).attachWith P H = [] := rfl
|
||||
@@ -148,7 +153,7 @@ theorem mem_pmap_of_mem {p : α → Prop} {f : ∀ a, p a → β} {l H} {a} (h :
|
||||
exact ⟨a, h, rfl⟩
|
||||
|
||||
@[simp]
|
||||
theorem length_pmap {p : α → Prop} {f : ∀ a, p a → β} {l H} : length (pmap f l H) = length l := by
|
||||
theorem length_pmap {p : α → Prop} {f : ∀ a, p a → β} {l H} : (pmap f l H).length = l.length := by
|
||||
induction l
|
||||
· rfl
|
||||
· simp only [*, pmap, length]
|
||||
@@ -199,7 +204,7 @@ theorem attachWith_ne_nil_iff {l : List α} {P : α → Prop} {H : ∀ a ∈ l,
|
||||
|
||||
@[simp]
|
||||
theorem getElem?_pmap {p : α → Prop} (f : ∀ a, p a → β) {l : List α} (h : ∀ a ∈ l, p a) (n : Nat) :
|
||||
(pmap f l h)[n]? = Option.pmap f l[n]? fun x H => h x (getElem?_mem H) := by
|
||||
(pmap f l h)[n]? = Option.pmap f l[n]? fun x H => h x (mem_of_getElem? H) := by
|
||||
induction l generalizing n with
|
||||
| nil => simp
|
||||
| cons hd tl hl =>
|
||||
@@ -215,7 +220,7 @@ theorem getElem?_pmap {p : α → Prop} (f : ∀ a, p a → β) {l : List α} (h
|
||||
· simp_all
|
||||
|
||||
theorem get?_pmap {p : α → Prop} (f : ∀ a, p a → β) {l : List α} (h : ∀ a ∈ l, p a) (n : Nat) :
|
||||
get? (pmap f l h) n = Option.pmap f (get? l n) fun x H => h x (get?_mem H) := by
|
||||
get? (pmap f l h) n = Option.pmap f (get? l n) fun x H => h x (mem_of_get? H) := by
|
||||
simp only [get?_eq_getElem?]
|
||||
simp [getElem?_pmap, h]
|
||||
|
||||
@@ -238,18 +243,18 @@ theorem get_pmap {p : α → Prop} (f : ∀ a, p a → β) {l : List α} (h :
|
||||
(hn : n < (pmap f l h).length) :
|
||||
get (pmap f l h) ⟨n, hn⟩ =
|
||||
f (get l ⟨n, @length_pmap _ _ p f l h ▸ hn⟩)
|
||||
(h _ (get_mem l n (@length_pmap _ _ p f l h ▸ hn))) := by
|
||||
(h _ (getElem_mem (@length_pmap _ _ p f l h ▸ hn))) := by
|
||||
simp only [get_eq_getElem]
|
||||
simp [getElem_pmap]
|
||||
|
||||
@[simp]
|
||||
theorem getElem?_attachWith {xs : List α} {i : Nat} {P : α → Prop} {H : ∀ a ∈ xs, P a} :
|
||||
(xs.attachWith P H)[i]? = xs[i]?.pmap Subtype.mk (fun _ a => H _ (getElem?_mem a)) :=
|
||||
(xs.attachWith P H)[i]? = xs[i]?.pmap Subtype.mk (fun _ a => H _ (mem_of_getElem? a)) :=
|
||||
getElem?_pmap ..
|
||||
|
||||
@[simp]
|
||||
theorem getElem?_attach {xs : List α} {i : Nat} :
|
||||
xs.attach[i]? = xs[i]?.pmap Subtype.mk (fun _ a => getElem?_mem a) :=
|
||||
xs.attach[i]? = xs[i]?.pmap Subtype.mk (fun _ a => mem_of_getElem? a) :=
|
||||
getElem?_attachWith
|
||||
|
||||
@[simp]
|
||||
@@ -333,6 +338,7 @@ This is useful when we need to use `attach` to show termination.
|
||||
|
||||
Unfortunately this can't be applied by `simp` because of the higher order unification problem,
|
||||
and even when rewriting we need to specify the function explicitly.
|
||||
See however `foldl_subtype` below.
|
||||
-/
|
||||
theorem foldl_attach (l : List α) (f : β → α → β) (b : β) :
|
||||
l.attach.foldl (fun acc t => f acc t.1) b = l.foldl f b := by
|
||||
@@ -348,6 +354,7 @@ This is useful when we need to use `attach` to show termination.
|
||||
|
||||
Unfortunately this can't be applied by `simp` because of the higher order unification problem,
|
||||
and even when rewriting we need to specify the function explicitly.
|
||||
See however `foldr_subtype` below.
|
||||
-/
|
||||
theorem foldr_attach (l : List α) (f : α → β → β) (b : β) :
|
||||
l.attach.foldr (fun t acc => f t.1 acc) b = l.foldr f b := by
|
||||
@@ -452,16 +459,16 @@ theorem pmap_append' {p : α → Prop} (f : ∀ a : α, p a → β) (l₁ l₂ :
|
||||
pmap_append f l₁ l₂ _
|
||||
|
||||
@[simp] theorem attach_append (xs ys : List α) :
|
||||
(xs ++ ys).attach = xs.attach.map (fun ⟨x, h⟩ => ⟨x, mem_append_of_mem_left ys h⟩) ++
|
||||
ys.attach.map fun ⟨x, h⟩ => ⟨x, mem_append_of_mem_right xs h⟩ := by
|
||||
(xs ++ ys).attach = xs.attach.map (fun ⟨x, h⟩ => ⟨x, mem_append_left ys h⟩) ++
|
||||
ys.attach.map fun ⟨x, h⟩ => ⟨x, mem_append_right xs h⟩ := by
|
||||
simp only [attach, attachWith, pmap, map_pmap, pmap_append]
|
||||
congr 1 <;>
|
||||
exact pmap_congr_left _ fun _ _ _ _ => rfl
|
||||
|
||||
@[simp] theorem attachWith_append {P : α → Prop} {xs ys : List α}
|
||||
{H : ∀ (a : α), a ∈ xs ++ ys → P a} :
|
||||
(xs ++ ys).attachWith P H = xs.attachWith P (fun a h => H a (mem_append_of_mem_left ys h)) ++
|
||||
ys.attachWith P (fun a h => H a (mem_append_of_mem_right xs h)) := by
|
||||
(xs ++ ys).attachWith P H = xs.attachWith P (fun a h => H a (mem_append_left ys h)) ++
|
||||
ys.attachWith P (fun a h => H a (mem_append_right xs h)) := by
|
||||
simp only [attachWith, attach_append, map_pmap, pmap_append]
|
||||
|
||||
@[simp] theorem pmap_reverse {P : α → Prop} (f : (a : α) → P a → β) (xs : List α)
|
||||
@@ -598,6 +605,15 @@ def unattach {α : Type _} {p : α → Prop} (l : List { x // p x }) := l.map (
|
||||
| nil => simp
|
||||
| cons a l ih => simp [ih, Function.comp_def]
|
||||
|
||||
@[simp] theorem getElem?_unattach {p : α → Prop} {l : List { x // p x }} (i : Nat) :
|
||||
l.unattach[i]? = l[i]?.map Subtype.val := by
|
||||
simp [unattach]
|
||||
|
||||
@[simp] theorem getElem_unattach
|
||||
{p : α → Prop} {l : List { x // p x }} (i : Nat) (h : i < l.unattach.length) :
|
||||
l.unattach[i] = (l[i]'(by simpa using h)).1 := by
|
||||
simp [unattach]
|
||||
|
||||
/-! ### Recognizing higher order functions on subtypes using a function that only depends on the value. -/
|
||||
|
||||
/--
|
||||
|
||||
@@ -551,7 +551,7 @@ theorem reverseAux_eq_append (as bs : List α) : reverseAux as bs = reverseAux a
|
||||
/-! ### flatten -/
|
||||
|
||||
/--
|
||||
`O(|flatten L|)`. `join L` concatenates all the lists in `L` into one list.
|
||||
`O(|flatten L|)`. `flatten L` concatenates all the lists in `L` into one list.
|
||||
* `flatten [[a], [], [b, c], [d, e, f]] = [a, b, c, d, e, f]`
|
||||
-/
|
||||
def flatten : List (List α) → List α
|
||||
@@ -726,13 +726,13 @@ theorem elem_eq_true_of_mem [BEq α] [LawfulBEq α] {a : α} {as : List α} (h :
|
||||
instance [BEq α] [LawfulBEq α] (a : α) (as : List α) : Decidable (a ∈ as) :=
|
||||
decidable_of_decidable_of_iff (Iff.intro mem_of_elem_eq_true elem_eq_true_of_mem)
|
||||
|
||||
theorem mem_append_of_mem_left {a : α} {as : List α} (bs : List α) : a ∈ as → a ∈ as ++ bs := by
|
||||
theorem mem_append_left {a : α} {as : List α} (bs : List α) : a ∈ as → a ∈ as ++ bs := by
|
||||
intro h
|
||||
induction h with
|
||||
| head => apply Mem.head
|
||||
| tail => apply Mem.tail; assumption
|
||||
|
||||
theorem mem_append_of_mem_right {b : α} {bs : List α} (as : List α) : b ∈ bs → b ∈ as ++ bs := by
|
||||
theorem mem_append_right {b : α} {bs : List α} (as : List α) : b ∈ bs → b ∈ as ++ bs := by
|
||||
intro h
|
||||
induction as with
|
||||
| nil => simp [h]
|
||||
|
||||
@@ -256,7 +256,7 @@ theorem findM?_eq_findSomeM? [Monad m] [LawfulMonad m] (p : α → m Bool) (as :
|
||||
have : a ∈ as := by
|
||||
have ⟨bs, h⟩ := h
|
||||
subst h
|
||||
exact mem_append_of_mem_right _ (Mem.head ..)
|
||||
exact mem_append_right _ (Mem.head ..)
|
||||
match (← f a this b) with
|
||||
| ForInStep.done b => pure b
|
||||
| ForInStep.yield b =>
|
||||
|
||||
@@ -91,7 +91,7 @@ The following operations are given `@[csimp]` replacements below:
|
||||
@[specialize] def foldrTR (f : α → β → β) (init : β) (l : List α) : β := l.toArray.foldr f init
|
||||
|
||||
@[csimp] theorem foldr_eq_foldrTR : @foldr = @foldrTR := by
|
||||
funext α β f init l; simp [foldrTR, Array.foldr_eq_foldr_toList, -Array.size_toArray]
|
||||
funext α β f init l; simp [foldrTR, ← Array.foldr_toList, -Array.size_toArray]
|
||||
|
||||
/-! ### flatMap -/
|
||||
|
||||
@@ -331,7 +331,7 @@ def enumFromTR (n : Nat) (l : List α) : List (Nat × α) :=
|
||||
| a::as, n => by
|
||||
rw [← show _ + as.length = n + (a::as).length from Nat.succ_add .., foldr, go as]
|
||||
simp [enumFrom, f]
|
||||
rw [Array.foldr_eq_foldr_toList]
|
||||
rw [← Array.foldr_toList]
|
||||
simp [go]
|
||||
|
||||
/-! ## Other list operations -/
|
||||
|
||||
@@ -372,6 +372,17 @@ theorem getElem?_concat_length (l : List α) (a : α) : (l ++ [a])[l.length]? =
|
||||
@[deprecated getElem?_concat_length (since := "2024-06-12")]
|
||||
theorem get?_concat_length (l : List α) (a : α) : (l ++ [a]).get? l.length = some a := by simp
|
||||
|
||||
@[simp] theorem isSome_getElem? {l : List α} {n : Nat} : l[n]?.isSome ↔ n < l.length := by
|
||||
by_cases h : n < l.length
|
||||
· simp_all
|
||||
· simp [h]
|
||||
simp_all
|
||||
|
||||
@[simp] theorem isNone_getElem? {l : List α} {n : Nat} : l[n]?.isNone ↔ l.length ≤ n := by
|
||||
by_cases h : n < l.length
|
||||
· simp_all
|
||||
· simp [h]
|
||||
|
||||
/-! ### mem -/
|
||||
|
||||
@[simp] theorem not_mem_nil (a : α) : ¬ a ∈ [] := nofun
|
||||
@@ -383,9 +394,9 @@ theorem get?_concat_length (l : List α) (a : α) : (l ++ [a]).get? l.length = s
|
||||
theorem mem_cons_self (a : α) (l : List α) : a ∈ a :: l := .head ..
|
||||
|
||||
theorem mem_concat_self (xs : List α) (a : α) : a ∈ xs ++ [a] :=
|
||||
mem_append_of_mem_right xs (mem_cons_self a _)
|
||||
mem_append_right xs (mem_cons_self a _)
|
||||
|
||||
theorem mem_append_cons_self : a ∈ xs ++ a :: ys := mem_append_of_mem_right _ (mem_cons_self _ _)
|
||||
theorem mem_append_cons_self : a ∈ xs ++ a :: ys := mem_append_right _ (mem_cons_self _ _)
|
||||
|
||||
theorem eq_append_cons_of_mem {a : α} {xs : List α} (h : a ∈ xs) :
|
||||
∃ as bs, xs = as ++ a :: bs ∧ a ∉ as := by
|
||||
@@ -492,16 +503,20 @@ 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 _⟩
|
||||
|
||||
theorem get_mem : ∀ (l : List α) n h, get l ⟨n, h⟩ ∈ l
|
||||
| _ :: _, 0, _ => .head ..
|
||||
| _ :: l, _+1, _ => .tail _ (get_mem l ..)
|
||||
theorem get_mem : ∀ (l : List α) n, get l n ∈ l
|
||||
| _ :: _, ⟨0, _⟩ => .head ..
|
||||
| _ :: l, ⟨_+1, _⟩ => .tail _ (get_mem l ..)
|
||||
|
||||
theorem getElem?_mem {l : List α} {n : Nat} {a : α} (e : l[n]? = some a) : a ∈ l :=
|
||||
theorem mem_of_getElem? {l : List α} {n : Nat} {a : α} (e : l[n]? = some a) : a ∈ l :=
|
||||
let ⟨_, e⟩ := getElem?_eq_some_iff.1 e; e ▸ getElem_mem ..
|
||||
|
||||
theorem get?_mem {l : List α} {n a} (e : l.get? n = some a) : a ∈ l :=
|
||||
@[deprecated mem_of_getElem? (since := "2024-09-06")] abbrev getElem?_mem := @mem_of_getElem?
|
||||
|
||||
theorem mem_of_get? {l : List α} {n a} (e : l.get? n = some a) : a ∈ l :=
|
||||
let ⟨_, e⟩ := get?_eq_some.1 e; e ▸ get_mem ..
|
||||
|
||||
@[deprecated mem_of_get? (since := "2024-09-06")] abbrev get?_mem := @mem_of_get?
|
||||
|
||||
theorem mem_iff_getElem {a} {l : List α} : a ∈ l ↔ ∃ (n : Nat) (h : n < l.length), l[n]'h = a :=
|
||||
⟨getElem_of_mem, fun ⟨_, _, e⟩ => e ▸ getElem_mem ..⟩
|
||||
|
||||
@@ -1025,6 +1040,10 @@ theorem getLast_eq_getElem : ∀ (l : List α) (h : l ≠ []),
|
||||
| _ :: _ :: _, _ => by
|
||||
simp [getLast, get, Nat.succ_sub_succ, getLast_eq_getElem]
|
||||
|
||||
theorem getElem_length_sub_one_eq_getLast (l : List α) (h) :
|
||||
l[l.length - 1] = getLast l (by cases l; simp at h; simp) := by
|
||||
rw [← getLast_eq_getElem]
|
||||
|
||||
@[deprecated getLast_eq_getElem (since := "2024-07-15")]
|
||||
theorem getLast_eq_get (l : List α) (h : l ≠ []) :
|
||||
getLast l h = l.get ⟨l.length - 1, by
|
||||
@@ -1149,6 +1168,11 @@ theorem head_eq_getElem (l : List α) (h : l ≠ []) : head l h = l[0]'(length_p
|
||||
| nil => simp at h
|
||||
| cons _ _ => simp
|
||||
|
||||
theorem getElem_zero_eq_head (l : List α) (h) : l[0] = head l (by simpa [length_pos] using h) := by
|
||||
cases l with
|
||||
| nil => simp at h
|
||||
| cons _ _ => simp
|
||||
|
||||
theorem head_eq_iff_head?_eq_some {xs : List α} (h) : xs.head h = a ↔ xs.head? = some a := by
|
||||
cases xs with
|
||||
| nil => simp at h
|
||||
@@ -1977,11 +2001,8 @@ theorem not_mem_append {a : α} {s t : List α} (h₁ : a ∉ s) (h₂ : a ∉ t
|
||||
theorem mem_append_eq (a : α) (s t : List α) : (a ∈ s ++ t) = (a ∈ s ∨ a ∈ t) :=
|
||||
propext mem_append
|
||||
|
||||
theorem mem_append_left {a : α} {l₁ : List α} (l₂ : List α) (h : a ∈ l₁) : a ∈ l₁ ++ l₂ :=
|
||||
mem_append.2 (Or.inl h)
|
||||
|
||||
theorem mem_append_right {a : α} (l₁ : List α) {l₂ : List α} (h : a ∈ l₂) : a ∈ l₁ ++ l₂ :=
|
||||
mem_append.2 (Or.inr h)
|
||||
@[deprecated mem_append_left (since := "2024-11-20")] abbrev mem_append_of_mem_left := @mem_append_left
|
||||
@[deprecated mem_append_right (since := "2024-11-20")] abbrev mem_append_of_mem_right := @mem_append_right
|
||||
|
||||
theorem mem_iff_append {a : α} {l : List α} : a ∈ l ↔ ∃ s t : List α, l = s ++ a :: t :=
|
||||
⟨append_of_mem, fun ⟨s, t, e⟩ => e ▸ by simp⟩
|
||||
@@ -2395,7 +2416,7 @@ theorem forall_mem_replicate {p : α → Prop} {a : α} {n} :
|
||||
|
||||
@[simp] theorem getElem_replicate (a : α) {n : Nat} {m} (h : m < (replicate n a).length) :
|
||||
(replicate n a)[m] = a :=
|
||||
eq_of_mem_replicate (get_mem _ _ _)
|
||||
eq_of_mem_replicate (getElem_mem _)
|
||||
|
||||
@[deprecated getElem_replicate (since := "2024-06-12")]
|
||||
theorem get_replicate (a : α) {n : Nat} (m : Fin _) : (replicate n a).get m = a := by
|
||||
|
||||
@@ -417,7 +417,7 @@ theorem Sublist.of_sublist_append_left (w : ∀ a, a ∈ l → a ∉ l₂) (h :
|
||||
obtain ⟨l₁', l₂', rfl, h₁, h₂⟩ := h
|
||||
have : l₂' = [] := by
|
||||
rw [eq_nil_iff_forall_not_mem]
|
||||
exact fun x m => w x (mem_append_of_mem_right l₁' m) (h₂.mem m)
|
||||
exact fun x m => w x (mem_append_right l₁' m) (h₂.mem m)
|
||||
simp_all
|
||||
|
||||
theorem Sublist.of_sublist_append_right (w : ∀ a, a ∈ l → a ∉ l₁) (h : l <+ l₁ ++ l₂) : l <+ l₂ := by
|
||||
@@ -425,7 +425,7 @@ theorem Sublist.of_sublist_append_right (w : ∀ a, a ∈ l → a ∉ l₁) (h :
|
||||
obtain ⟨l₁', l₂', rfl, h₁, h₂⟩ := h
|
||||
have : l₁' = [] := by
|
||||
rw [eq_nil_iff_forall_not_mem]
|
||||
exact fun x m => w x (mem_append_of_mem_left l₂' m) (h₁.mem m)
|
||||
exact fun x m => w x (mem_append_left l₂' m) (h₁.mem m)
|
||||
simp_all
|
||||
|
||||
theorem Sublist.middle {l : List α} (h : l <+ l₁ ++ l₂) (a : α) : l <+ l₁ ++ a :: l₂ := by
|
||||
|
||||
@@ -1029,3 +1029,12 @@ instance decidableExistsLT [h : DecidablePred p] : DecidablePred fun n => ∃ m
|
||||
instance decidableExistsLE [DecidablePred p] : DecidablePred fun n => ∃ m : Nat, m ≤ n ∧ p m :=
|
||||
fun n => decidable_of_iff (∃ m, m < n + 1 ∧ p m)
|
||||
(exists_congr fun _ => and_congr_left' Nat.lt_succ_iff)
|
||||
|
||||
/-! ### Results about `List.sum` specialized to `Nat` -/
|
||||
|
||||
protected theorem sum_pos_iff_exists_pos {l : List Nat} : 0 < l.sum ↔ ∃ x ∈ l, 0 < x := by
|
||||
induction l with
|
||||
| nil => simp
|
||||
| cons x xs ih =>
|
||||
simp [← ih]
|
||||
omega
|
||||
|
||||
@@ -6,6 +6,7 @@ Authors: Leonardo de Moura
|
||||
prelude
|
||||
import Init.ByCases
|
||||
import Init.Data.Prod
|
||||
import Init.Data.RArray
|
||||
|
||||
namespace Nat.Linear
|
||||
|
||||
@@ -15,7 +16,7 @@ namespace Nat.Linear
|
||||
|
||||
abbrev Var := Nat
|
||||
|
||||
abbrev Context := List Nat
|
||||
abbrev Context := Lean.RArray Nat
|
||||
|
||||
/--
|
||||
When encoding polynomials. We use `fixedVar` for encoding numerals.
|
||||
@@ -23,12 +24,7 @@ abbrev Context := List Nat
|
||||
def fixedVar := 100000000 -- Any big number should work here
|
||||
|
||||
def Var.denote (ctx : Context) (v : Var) : Nat :=
|
||||
bif v == fixedVar then 1 else go ctx v
|
||||
where
|
||||
go : List Nat → Nat → Nat
|
||||
| [], _ => 0
|
||||
| a::_, 0 => a
|
||||
| _::as, i+1 => go as i
|
||||
bif v == fixedVar then 1 else ctx.get v
|
||||
|
||||
inductive Expr where
|
||||
| num (v : Nat)
|
||||
@@ -52,25 +48,23 @@ def Poly.denote (ctx : Context) (p : Poly) : Nat :=
|
||||
| [] => 0
|
||||
| (k, v) :: p => Nat.add (Nat.mul k (v.denote ctx)) (denote ctx p)
|
||||
|
||||
def Poly.insertSorted (k : Nat) (v : Var) (p : Poly) : Poly :=
|
||||
def Poly.insert (k : Nat) (v : Var) (p : Poly) : Poly :=
|
||||
match p with
|
||||
| [] => [(k, v)]
|
||||
| (k', v') :: p => bif Nat.blt v v' then (k, v) :: (k', v') :: p else (k', v') :: insertSorted k v p
|
||||
| (k', v') :: p =>
|
||||
bif Nat.blt v v' then
|
||||
(k, v) :: (k', v') :: p
|
||||
else bif Nat.beq v v' then
|
||||
(k + k', v') :: p
|
||||
else
|
||||
(k', v') :: insert k v p
|
||||
|
||||
def Poly.sort (p : Poly) : Poly :=
|
||||
let rec go (p : Poly) (r : Poly) : Poly :=
|
||||
def Poly.norm (p : Poly) : Poly := go p []
|
||||
where
|
||||
go (p : Poly) (r : Poly) : Poly :=
|
||||
match p with
|
||||
| [] => r
|
||||
| (k, v) :: p => go p (r.insertSorted k v)
|
||||
go p []
|
||||
|
||||
def Poly.fuse (p : Poly) : Poly :=
|
||||
match p with
|
||||
| [] => []
|
||||
| (k, v) :: p =>
|
||||
match fuse p with
|
||||
| [] => [(k, v)]
|
||||
| (k', v') :: p' => bif v == v' then (Nat.add k k', v)::p' else (k, v) :: (k', v') :: p'
|
||||
| (k, v) :: p => go p (r.insert k v)
|
||||
|
||||
def Poly.mul (k : Nat) (p : Poly) : Poly :=
|
||||
bif k == 0 then
|
||||
@@ -146,15 +140,17 @@ def Poly.combineAux (fuel : Nat) (p₁ p₂ : Poly) : Poly :=
|
||||
def Poly.combine (p₁ p₂ : Poly) : Poly :=
|
||||
combineAux hugeFuel p₁ p₂
|
||||
|
||||
def Expr.toPoly : Expr → Poly
|
||||
| Expr.num k => bif k == 0 then [] else [ (k, fixedVar) ]
|
||||
| Expr.var i => [(1, i)]
|
||||
| Expr.add a b => a.toPoly ++ b.toPoly
|
||||
| Expr.mulL k a => a.toPoly.mul k
|
||||
| Expr.mulR a k => a.toPoly.mul k
|
||||
|
||||
def Poly.norm (p : Poly) : Poly :=
|
||||
p.sort.fuse
|
||||
def Expr.toPoly (e : Expr) :=
|
||||
go 1 e []
|
||||
where
|
||||
-- Implementation note: This assembles the result using difference lists
|
||||
-- to avoid `++` on lists.
|
||||
go (coeff : Nat) : Expr → (Poly → Poly)
|
||||
| Expr.num k => bif k == 0 then id else ((coeff * k, fixedVar) :: ·)
|
||||
| Expr.var i => ((coeff, i) :: ·)
|
||||
| Expr.add a b => go coeff a ∘ go coeff b
|
||||
| Expr.mulL k a
|
||||
| Expr.mulR a k => bif k == 0 then id else go (coeff * k) a
|
||||
|
||||
def Expr.toNormPoly (e : Expr) : Poly :=
|
||||
e.toPoly.norm
|
||||
@@ -201,7 +197,7 @@ def PolyCnstr.denote (ctx : Context) (c : PolyCnstr) : Prop :=
|
||||
Poly.denote_le ctx (c.lhs, c.rhs)
|
||||
|
||||
def PolyCnstr.norm (c : PolyCnstr) : PolyCnstr :=
|
||||
let (lhs, rhs) := Poly.cancel c.lhs.sort.fuse c.rhs.sort.fuse
|
||||
let (lhs, rhs) := Poly.cancel c.lhs.norm c.rhs.norm
|
||||
{ eq := c.eq, lhs, rhs }
|
||||
|
||||
def PolyCnstr.isUnsat (c : PolyCnstr) : Bool :=
|
||||
@@ -268,24 +264,32 @@ def PolyCnstr.toExpr (c : PolyCnstr) : ExprCnstr :=
|
||||
{ c with lhs := c.lhs.toExpr, rhs := c.rhs.toExpr }
|
||||
|
||||
attribute [local simp] Nat.add_comm Nat.add_assoc Nat.add_left_comm Nat.right_distrib Nat.left_distrib Nat.mul_assoc Nat.mul_comm
|
||||
attribute [local simp] Poly.denote Expr.denote Poly.insertSorted Poly.sort Poly.sort.go Poly.fuse Poly.cancelAux
|
||||
attribute [local simp] Poly.denote Expr.denote Poly.insert Poly.norm Poly.norm.go Poly.cancelAux
|
||||
attribute [local simp] Poly.mul Poly.mul.go
|
||||
|
||||
theorem Poly.denote_insertSorted (ctx : Context) (k : Nat) (v : Var) (p : Poly) : (p.insertSorted k v).denote ctx = p.denote ctx + k * v.denote ctx := by
|
||||
theorem Poly.denote_insert (ctx : Context) (k : Nat) (v : Var) (p : Poly) :
|
||||
(p.insert k v).denote ctx = p.denote ctx + k * v.denote ctx := by
|
||||
match p with
|
||||
| [] => simp
|
||||
| (k', v') :: p => by_cases h : Nat.blt v v' <;> simp [h, denote_insertSorted]
|
||||
| (k', v') :: p =>
|
||||
by_cases h₁ : Nat.blt v v'
|
||||
· simp [h₁]
|
||||
· by_cases h₂ : Nat.beq v v'
|
||||
· simp only [insert, h₁, h₂, cond_false, cond_true]
|
||||
simp [Nat.eq_of_beq_eq_true h₂]
|
||||
· simp only [insert, h₁, h₂, cond_false, cond_true]
|
||||
simp [denote_insert]
|
||||
|
||||
attribute [local simp] Poly.denote_insertSorted
|
||||
attribute [local simp] Poly.denote_insert
|
||||
|
||||
theorem Poly.denote_sort_go (ctx : Context) (p : Poly) (r : Poly) : (sort.go p r).denote ctx = p.denote ctx + r.denote ctx := by
|
||||
theorem Poly.denote_norm_go (ctx : Context) (p : Poly) (r : Poly) : (norm.go p r).denote ctx = p.denote ctx + r.denote ctx := by
|
||||
match p with
|
||||
| [] => simp
|
||||
| (k, v):: p => simp [denote_sort_go]
|
||||
| (k, v):: p => simp [denote_norm_go]
|
||||
|
||||
attribute [local simp] Poly.denote_sort_go
|
||||
attribute [local simp] Poly.denote_norm_go
|
||||
|
||||
theorem Poly.denote_sort (ctx : Context) (m : Poly) : m.sort.denote ctx = m.denote ctx := by
|
||||
theorem Poly.denote_sort (ctx : Context) (m : Poly) : m.norm.denote ctx = m.denote ctx := by
|
||||
simp
|
||||
|
||||
attribute [local simp] Poly.denote_sort
|
||||
@@ -316,18 +320,6 @@ theorem Poly.denote_reverse (ctx : Context) (p : Poly) : denote ctx (List.revers
|
||||
|
||||
attribute [local simp] Poly.denote_reverse
|
||||
|
||||
theorem Poly.denote_fuse (ctx : Context) (p : Poly) : p.fuse.denote ctx = p.denote ctx := by
|
||||
match p with
|
||||
| [] => rfl
|
||||
| (k, v) :: p =>
|
||||
have ih := denote_fuse ctx p
|
||||
simp
|
||||
split
|
||||
case _ h => simp [← ih, h]
|
||||
case _ k' v' p' h => by_cases he : v == v' <;> simp [he, ← ih, h]; rw [eq_of_beq he]
|
||||
|
||||
attribute [local simp] Poly.denote_fuse
|
||||
|
||||
theorem Poly.denote_mul (ctx : Context) (k : Nat) (p : Poly) : (p.mul k).denote ctx = k * p.denote ctx := by
|
||||
simp
|
||||
by_cases h : k == 0 <;> simp [h]; simp [eq_of_beq h]
|
||||
@@ -516,13 +508,25 @@ theorem Poly.denote_combine (ctx : Context) (p₁ p₂ : Poly) : (p₁.combine p
|
||||
|
||||
attribute [local simp] Poly.denote_combine
|
||||
|
||||
theorem Expr.denote_toPoly_go (ctx : Context) (e : Expr) :
|
||||
(toPoly.go k e p).denote ctx = k * e.denote ctx + p.denote ctx := by
|
||||
induction k, e using Expr.toPoly.go.induct generalizing p with
|
||||
| case1 k k' =>
|
||||
simp only [toPoly.go]
|
||||
by_cases h : k' == 0
|
||||
· simp [h, eq_of_beq h]
|
||||
· simp [h, Var.denote]
|
||||
| case2 k i => simp [toPoly.go]
|
||||
| case3 k a b iha ihb => simp [toPoly.go, iha, ihb]
|
||||
| case4 k k' a ih
|
||||
| case5 k a k' ih =>
|
||||
simp only [toPoly.go, denote, mul_eq]
|
||||
by_cases h : k' == 0
|
||||
· simp [h, eq_of_beq h]
|
||||
· simp [h, cond_false, ih, Nat.mul_assoc]
|
||||
|
||||
theorem Expr.denote_toPoly (ctx : Context) (e : Expr) : e.toPoly.denote ctx = e.denote ctx := by
|
||||
induction e with
|
||||
| num k => by_cases h : k == 0 <;> simp [toPoly, h, Var.denote]; simp [eq_of_beq h]
|
||||
| var i => simp [toPoly]
|
||||
| add a b iha ihb => simp [toPoly, iha, ihb]
|
||||
| mulL k a ih => simp [toPoly, ih, -Poly.mul]
|
||||
| mulR k a ih => simp [toPoly, ih, -Poly.mul]
|
||||
simp [toPoly, Expr.denote_toPoly_go]
|
||||
|
||||
attribute [local simp] Expr.denote_toPoly
|
||||
|
||||
@@ -554,8 +558,8 @@ theorem ExprCnstr.denote_toPoly (ctx : Context) (c : ExprCnstr) : c.toPoly.denot
|
||||
cases c; rename_i eq lhs rhs
|
||||
simp [ExprCnstr.denote, PolyCnstr.denote, ExprCnstr.toPoly];
|
||||
by_cases h : eq = true <;> simp [h]
|
||||
· simp [Poly.denote_eq, Expr.toPoly]
|
||||
· simp [Poly.denote_le, Expr.toPoly]
|
||||
· simp [Poly.denote_eq]
|
||||
· simp [Poly.denote_le]
|
||||
|
||||
attribute [local simp] ExprCnstr.denote_toPoly
|
||||
|
||||
|
||||
@@ -16,10 +16,6 @@ def getM [Alternative m] : Option α → m α
|
||||
| none => failure
|
||||
| some a => pure a
|
||||
|
||||
@[deprecated getM (since := "2024-04-17")]
|
||||
-- `[Monad m]` is not needed here.
|
||||
def toMonad [Monad m] [Alternative m] : Option α → m α := getM
|
||||
|
||||
/-- Returns `true` on `some x` and `false` on `none`. -/
|
||||
@[inline] def isSome : Option α → Bool
|
||||
| some _ => true
|
||||
@@ -28,8 +24,6 @@ def toMonad [Monad m] [Alternative m] : Option α → m α := getM
|
||||
@[simp] theorem isSome_none : @isSome α none = false := rfl
|
||||
@[simp] theorem isSome_some : isSome (some a) = true := rfl
|
||||
|
||||
@[deprecated isSome (since := "2024-04-17"), inline] def toBool : Option α → Bool := isSome
|
||||
|
||||
/-- Returns `true` on `none` and `false` on `some x`. -/
|
||||
@[inline] def isNone : Option α → Bool
|
||||
| some _ => false
|
||||
|
||||
@@ -55,7 +55,9 @@ theorem get_eq_getD {fallback : α} : (o : Option α) → {h : o.isSome} → o.g
|
||||
theorem some_get! [Inhabited α] : (o : Option α) → o.isSome → some (o.get!) = o
|
||||
| some _, _ => rfl
|
||||
|
||||
theorem get!_eq_getD_default [Inhabited α] (o : Option α) : o.get! = o.getD default := rfl
|
||||
theorem get!_eq_getD [Inhabited α] (o : Option α) : o.get! = o.getD default := rfl
|
||||
|
||||
@[deprecated get!_eq_getD (since := "2024-11-18")] abbrev get!_eq_getD_default := @get!_eq_getD
|
||||
|
||||
theorem mem_unique {o : Option α} {a b : α} (ha : a ∈ o) (hb : b ∈ o) : a = b :=
|
||||
some.inj <| ha ▸ hb
|
||||
|
||||
69
src/Init/Data/RArray.lean
Normal file
69
src/Init/Data/RArray.lean
Normal file
@@ -0,0 +1,69 @@
|
||||
/-
|
||||
Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Joachim Breitner
|
||||
-/
|
||||
|
||||
prelude
|
||||
import Init.PropLemmas
|
||||
|
||||
namespace Lean
|
||||
|
||||
/--
|
||||
A `RArray` can model `Fin n → α` or `Array α`, but is optimized for a fast kernel-reducible `get`
|
||||
operation.
|
||||
|
||||
The primary intended use case is the “denote” function of a typical proof by reflection proof, where
|
||||
only the `get` operation is necessary. It is not suitable as a general-purpose data structure.
|
||||
|
||||
There is no well-formedness invariant attached to this data structure, to keep it concise; it's
|
||||
semantics is given through `RArray.get`. In that way one can also view an `RArray` as a decision
|
||||
tree implementing `Nat → α`.
|
||||
|
||||
See `RArray.ofFn` and `RArray.ofArray` in module `Lean.Data.RArray` for functions that construct an
|
||||
`RArray`.
|
||||
|
||||
It is not universe-polymorphic. ; smaller proof objects and no complication with the `ToExpr` type
|
||||
class.
|
||||
-/
|
||||
inductive RArray (α : Type) : Type where
|
||||
| leaf : α → RArray α
|
||||
| branch : Nat → RArray α → RArray α → RArray α
|
||||
|
||||
variable {α : Type}
|
||||
|
||||
/-- The crucial operation, written with very little abstractional overhead -/
|
||||
noncomputable def RArray.get (a : RArray α) (n : Nat) : α :=
|
||||
RArray.rec (fun x => x) (fun p _ _ l r => (Nat.ble p n).rec l r) a
|
||||
|
||||
private theorem RArray.get_eq_def (a : RArray α) (n : Nat) :
|
||||
a.get n = match a with
|
||||
| .leaf x => x
|
||||
| .branch p l r => (Nat.ble p n).rec (l.get n) (r.get n) := by
|
||||
conv => lhs; unfold RArray.get
|
||||
split <;> rfl
|
||||
|
||||
/-- `RArray.get`, implemented conventionally -/
|
||||
def RArray.getImpl (a : RArray α) (n : Nat) : α :=
|
||||
match a with
|
||||
| .leaf x => x
|
||||
| .branch p l r => if n < p then l.getImpl n else r.getImpl n
|
||||
|
||||
@[csimp]
|
||||
theorem RArray.get_eq_getImpl : @RArray.get = @RArray.getImpl := by
|
||||
funext α a n
|
||||
induction a with
|
||||
| leaf _ => rfl
|
||||
| branch p l r ihl ihr =>
|
||||
rw [RArray.getImpl, RArray.get_eq_def]
|
||||
simp only [ihl, ihr, ← Nat.not_le, ← Nat.ble_eq, ite_not]
|
||||
cases hnp : Nat.ble p n <;> rfl
|
||||
|
||||
instance : GetElem (RArray α) Nat α (fun _ _ => True) where
|
||||
getElem a n _ := a.get n
|
||||
|
||||
def RArray.size : RArray α → Nat
|
||||
| leaf _ => 1
|
||||
| branch _ l r => l.size + r.size
|
||||
|
||||
end Lean
|
||||
@@ -113,10 +113,10 @@ initialize IO.stdGenRef : IO.Ref StdGen ←
|
||||
let seed := UInt64.toNat (ByteArray.toUInt64LE! (← IO.getRandomBytes 8))
|
||||
IO.mkRef (mkStdGen seed)
|
||||
|
||||
def IO.setRandSeed (n : Nat) : IO Unit :=
|
||||
def IO.setRandSeed (n : Nat) : BaseIO Unit :=
|
||||
IO.stdGenRef.set (mkStdGen n)
|
||||
|
||||
def IO.rand (lo hi : Nat) : IO Nat := do
|
||||
def IO.rand (lo hi : Nat) : BaseIO Nat := do
|
||||
let gen ← IO.stdGenRef.get
|
||||
let (r, gen) := randNat gen lo hi
|
||||
IO.stdGenRef.set gen
|
||||
|
||||
@@ -148,6 +148,9 @@ instance : ShiftLeft Int8 := ⟨Int8.shiftLeft⟩
|
||||
instance : ShiftRight Int8 := ⟨Int8.shiftRight⟩
|
||||
instance : DecidableEq Int8 := Int8.decEq
|
||||
|
||||
@[extern "lean_bool_to_int8"]
|
||||
def Bool.toInt8 (b : Bool) : Int8 := if b then 1 else 0
|
||||
|
||||
@[extern "lean_int8_dec_lt"]
|
||||
def Int8.decLt (a b : Int8) : Decidable (a < b) :=
|
||||
inferInstanceAs (Decidable (a.toBitVec.slt b.toBitVec))
|
||||
@@ -249,6 +252,9 @@ instance : ShiftLeft Int16 := ⟨Int16.shiftLeft⟩
|
||||
instance : ShiftRight Int16 := ⟨Int16.shiftRight⟩
|
||||
instance : DecidableEq Int16 := Int16.decEq
|
||||
|
||||
@[extern "lean_bool_to_int16"]
|
||||
def Bool.toInt16 (b : Bool) : Int16 := if b then 1 else 0
|
||||
|
||||
@[extern "lean_int16_dec_lt"]
|
||||
def Int16.decLt (a b : Int16) : Decidable (a < b) :=
|
||||
inferInstanceAs (Decidable (a.toBitVec.slt b.toBitVec))
|
||||
@@ -354,6 +360,9 @@ instance : ShiftLeft Int32 := ⟨Int32.shiftLeft⟩
|
||||
instance : ShiftRight Int32 := ⟨Int32.shiftRight⟩
|
||||
instance : DecidableEq Int32 := Int32.decEq
|
||||
|
||||
@[extern "lean_bool_to_int32"]
|
||||
def Bool.toInt32 (b : Bool) : Int32 := if b then 1 else 0
|
||||
|
||||
@[extern "lean_int32_dec_lt"]
|
||||
def Int32.decLt (a b : Int32) : Decidable (a < b) :=
|
||||
inferInstanceAs (Decidable (a.toBitVec.slt b.toBitVec))
|
||||
@@ -463,6 +472,9 @@ instance : ShiftLeft Int64 := ⟨Int64.shiftLeft⟩
|
||||
instance : ShiftRight Int64 := ⟨Int64.shiftRight⟩
|
||||
instance : DecidableEq Int64 := Int64.decEq
|
||||
|
||||
@[extern "lean_bool_to_int64"]
|
||||
def Bool.toInt64 (b : Bool) : Int64 := if b then 1 else 0
|
||||
|
||||
@[extern "lean_int64_dec_lt"]
|
||||
def Int64.decLt (a b : Int64) : Decidable (a < b) :=
|
||||
inferInstanceAs (Decidable (a.toBitVec.slt b.toBitVec))
|
||||
@@ -574,6 +586,9 @@ instance : ShiftLeft ISize := ⟨ISize.shiftLeft⟩
|
||||
instance : ShiftRight ISize := ⟨ISize.shiftRight⟩
|
||||
instance : DecidableEq ISize := ISize.decEq
|
||||
|
||||
@[extern "lean_bool_to_isize"]
|
||||
def Bool.toISize (b : Bool) : ISize := if b then 1 else 0
|
||||
|
||||
@[extern "lean_isize_dec_lt"]
|
||||
def ISize.decLt (a b : ISize) : Decidable (a < b) :=
|
||||
inferInstanceAs (Decidable (a.toBitVec.slt b.toBitVec))
|
||||
|
||||
@@ -514,9 +514,6 @@ instance : Inhabited String := ⟨""⟩
|
||||
|
||||
instance : Append String := ⟨String.append⟩
|
||||
|
||||
@[deprecated push (since := "2024-04-06")]
|
||||
def str : String → Char → String := push
|
||||
|
||||
@[inline] def pushn (s : String) (c : Char) (n : Nat) : String :=
|
||||
n.repeat (fun s => s.push c) s
|
||||
|
||||
|
||||
@@ -56,6 +56,9 @@ instance : Xor UInt8 := ⟨UInt8.xor⟩
|
||||
instance : ShiftLeft UInt8 := ⟨UInt8.shiftLeft⟩
|
||||
instance : ShiftRight UInt8 := ⟨UInt8.shiftRight⟩
|
||||
|
||||
@[extern "lean_bool_to_uint8"]
|
||||
def Bool.toUInt8 (b : Bool) : UInt8 := if b then 1 else 0
|
||||
|
||||
@[extern "lean_uint8_dec_lt"]
|
||||
def UInt8.decLt (a b : UInt8) : Decidable (a < b) :=
|
||||
inferInstanceAs (Decidable (a.toBitVec < b.toBitVec))
|
||||
@@ -116,6 +119,9 @@ instance : Xor UInt16 := ⟨UInt16.xor⟩
|
||||
instance : ShiftLeft UInt16 := ⟨UInt16.shiftLeft⟩
|
||||
instance : ShiftRight UInt16 := ⟨UInt16.shiftRight⟩
|
||||
|
||||
@[extern "lean_bool_to_uint16"]
|
||||
def Bool.toUInt16 (b : Bool) : UInt16 := if b then 1 else 0
|
||||
|
||||
set_option bootstrap.genMatcherCode false in
|
||||
@[extern "lean_uint16_dec_lt"]
|
||||
def UInt16.decLt (a b : UInt16) : Decidable (a < b) :=
|
||||
@@ -174,6 +180,9 @@ instance : Xor UInt32 := ⟨UInt32.xor⟩
|
||||
instance : ShiftLeft UInt32 := ⟨UInt32.shiftLeft⟩
|
||||
instance : ShiftRight UInt32 := ⟨UInt32.shiftRight⟩
|
||||
|
||||
@[extern "lean_bool_to_uint32"]
|
||||
def Bool.toUInt32 (b : Bool) : UInt32 := if b then 1 else 0
|
||||
|
||||
@[extern "lean_uint64_add"]
|
||||
def UInt64.add (a b : UInt64) : UInt64 := ⟨a.toBitVec + b.toBitVec⟩
|
||||
@[extern "lean_uint64_sub"]
|
||||
@@ -278,5 +287,8 @@ instance : Xor USize := ⟨USize.xor⟩
|
||||
instance : ShiftLeft USize := ⟨USize.shiftLeft⟩
|
||||
instance : ShiftRight USize := ⟨USize.shiftRight⟩
|
||||
|
||||
@[extern "lean_bool_to_usize"]
|
||||
def Bool.toUSize (b : Bool) : USize := if b then 1 else 0
|
||||
|
||||
instance : Max USize := maxOfLe
|
||||
instance : Min USize := minOfLe
|
||||
|
||||
@@ -374,6 +374,9 @@ partial def structEq : Syntax → Syntax → Bool
|
||||
instance : BEq Lean.Syntax := ⟨structEq⟩
|
||||
instance : BEq (Lean.TSyntax k) := ⟨(·.raw == ·.raw)⟩
|
||||
|
||||
/--
|
||||
Finds the first `SourceInfo` from the back of `stx` or `none` if no `SourceInfo` can be found.
|
||||
-/
|
||||
partial def getTailInfo? : Syntax → Option SourceInfo
|
||||
| atom info _ => info
|
||||
| ident info .. => info
|
||||
@@ -382,14 +385,39 @@ partial def getTailInfo? : Syntax → Option SourceInfo
|
||||
| node info _ _ => info
|
||||
| _ => none
|
||||
|
||||
/--
|
||||
Finds the first `SourceInfo` from the back of `stx` or `SourceInfo.none`
|
||||
if no `SourceInfo` can be found.
|
||||
-/
|
||||
def getTailInfo (stx : Syntax) : SourceInfo :=
|
||||
stx.getTailInfo?.getD SourceInfo.none
|
||||
|
||||
/--
|
||||
Finds the trailing size of the first `SourceInfo` from the back of `stx`.
|
||||
If no `SourceInfo` can be found or the first `SourceInfo` from the back of `stx` contains no
|
||||
trailing whitespace, the result is `0`.
|
||||
-/
|
||||
def getTrailingSize (stx : Syntax) : Nat :=
|
||||
match stx.getTailInfo? with
|
||||
| some (SourceInfo.original (trailing := trailing) ..) => trailing.bsize
|
||||
| _ => 0
|
||||
|
||||
/--
|
||||
Finds the trailing whitespace substring of the first `SourceInfo` from the back of `stx`.
|
||||
If no `SourceInfo` can be found or the first `SourceInfo` from the back of `stx` contains
|
||||
no trailing whitespace, the result is `none`.
|
||||
-/
|
||||
def getTrailing? (stx : Syntax) : Option Substring :=
|
||||
stx.getTailInfo.getTrailing?
|
||||
|
||||
/--
|
||||
Finds the tail position of the trailing whitespace of the first `SourceInfo` from the back of `stx`.
|
||||
If no `SourceInfo` can be found or the first `SourceInfo` from the back of `stx` contains
|
||||
no trailing whitespace and lacks a tail position, the result is `none`.
|
||||
-/
|
||||
def getTrailingTailPos? (stx : Syntax) (canonicalOnly := false) : Option String.Pos :=
|
||||
stx.getTailInfo.getTrailingTailPos? canonicalOnly
|
||||
|
||||
/--
|
||||
Return substring of original input covering `stx`.
|
||||
Result is meaningful only if all involved `SourceInfo.original`s refer to the same string (as is the case after parsing). -/
|
||||
|
||||
@@ -3654,7 +3654,8 @@ namespace SourceInfo
|
||||
|
||||
/--
|
||||
Gets the position information from a `SourceInfo`, if available.
|
||||
If `originalOnly` is true, then `.synthetic` syntax will also return `none`.
|
||||
If `canonicalOnly` is true, then `.synthetic` syntax with `canonical := false`
|
||||
will also return `none`.
|
||||
-/
|
||||
def getPos? (info : SourceInfo) (canonicalOnly := false) : Option String.Pos :=
|
||||
match info, canonicalOnly with
|
||||
@@ -3665,7 +3666,8 @@ def getPos? (info : SourceInfo) (canonicalOnly := false) : Option String.Pos :=
|
||||
|
||||
/--
|
||||
Gets the end position information from a `SourceInfo`, if available.
|
||||
If `originalOnly` is true, then `.synthetic` syntax will also return `none`.
|
||||
If `canonicalOnly` is true, then `.synthetic` syntax with `canonical := false`
|
||||
will also return `none`.
|
||||
-/
|
||||
def getTailPos? (info : SourceInfo) (canonicalOnly := false) : Option String.Pos :=
|
||||
match info, canonicalOnly with
|
||||
@@ -3674,6 +3676,24 @@ def getTailPos? (info : SourceInfo) (canonicalOnly := false) : Option String.Pos
|
||||
| synthetic (endPos := endPos) .., false => some endPos
|
||||
| _, _ => none
|
||||
|
||||
/--
|
||||
Gets the substring representing the trailing whitespace of a `SourceInfo`, if available.
|
||||
-/
|
||||
def getTrailing? (info : SourceInfo) : Option Substring :=
|
||||
match info with
|
||||
| original (trailing := trailing) .. => some trailing
|
||||
| _ => none
|
||||
|
||||
/--
|
||||
Gets the end position information of the trailing whitespace of a `SourceInfo`, if available.
|
||||
If `canonicalOnly` is true, then `.synthetic` syntax with `canonical := false`
|
||||
will also return `none`.
|
||||
-/
|
||||
def getTrailingTailPos? (info : SourceInfo) (canonicalOnly := false) : Option String.Pos :=
|
||||
match info.getTrailing? with
|
||||
| some trailing => some trailing.stopPos
|
||||
| none => info.getTailPos? canonicalOnly
|
||||
|
||||
end SourceInfo
|
||||
|
||||
/--
|
||||
@@ -3972,7 +3992,6 @@ position information.
|
||||
def getPos? (stx : Syntax) (canonicalOnly := false) : Option String.Pos :=
|
||||
stx.getHeadInfo.getPos? canonicalOnly
|
||||
|
||||
|
||||
/--
|
||||
Get the ending position of the syntax, if possible.
|
||||
If `canonicalOnly` is true, non-canonical `synthetic` nodes are treated as not carrying
|
||||
|
||||
@@ -802,6 +802,9 @@ def run (args : SpawnArgs) : IO String := do
|
||||
|
||||
end Process
|
||||
|
||||
/-- Returns the thread ID of the calling thread. -/
|
||||
@[extern "lean_io_get_tid"] opaque getTID : BaseIO UInt64
|
||||
|
||||
structure AccessRight where
|
||||
read : Bool := false
|
||||
write : Bool := false
|
||||
|
||||
@@ -466,7 +466,7 @@ hypotheses or the goal. It can have one of the forms:
|
||||
* `at h₁ h₂ ⊢`: target the hypotheses `h₁` and `h₂`, and the goal
|
||||
* `at *`: target all hypotheses and the goal
|
||||
-/
|
||||
syntax location := withPosition(" at" (locationWildcard <|> locationHyp))
|
||||
syntax location := withPosition(ppGroup(" at" (locationWildcard <|> locationHyp)))
|
||||
|
||||
/--
|
||||
* `change tgt'` will change the goal from `tgt` to `tgt'`,
|
||||
@@ -1155,7 +1155,7 @@ Configuration for the `decide` tactic family.
|
||||
structure DecideConfig where
|
||||
/-- If true (default: false), then use only kernel reduction when reducing the `Decidable` instance.
|
||||
This is more efficient, since the default mode reduces twice (once in the elaborator and again in the kernel),
|
||||
however kernel reduction ignores transparency settings. The `decide!` tactic is a synonym for `decide +kernel`. -/
|
||||
however kernel reduction ignores transparency settings. -/
|
||||
kernel : Bool := false
|
||||
/-- If true (default: false), then uses the native code compiler to evaluate the `Decidable` instance,
|
||||
admitting the result via the axiom `Lean.ofReduceBool`. This can be significantly more efficient,
|
||||
@@ -1165,7 +1165,9 @@ structure DecideConfig where
|
||||
native : Bool := false
|
||||
/-- If true (default: true), then when preprocessing the goal, do zeta reduction to attempt to eliminate free variables. -/
|
||||
zetaReduce : Bool := true
|
||||
/-- If true (default: false), then when preprocessing reverts free variables. -/
|
||||
/-- If true (default: false), then when preprocessing, removes irrelevant variables and reverts the local context.
|
||||
A variable is *relevant* if it appears in the target, if it appears in a relevant variable,
|
||||
or if it is a proposition that refers to a relevant variable. -/
|
||||
revert : Bool := false
|
||||
|
||||
/--
|
||||
@@ -1240,17 +1242,6 @@ example : 1 + 1 = 2 := by rfl
|
||||
-/
|
||||
syntax (name := decide) "decide" optConfig : tactic
|
||||
|
||||
/--
|
||||
`decide!` is a variant of the `decide` tactic that uses kernel reduction to prove the goal.
|
||||
It has the following properties:
|
||||
- Since it uses kernel reduction instead of elaborator reduction, it ignores transparency and can unfold everything.
|
||||
- While `decide` needs to reduce the `Decidable` instance twice (once during elaboration to verify whether the tactic succeeds,
|
||||
and once during kernel type checking), the `decide!` tactic reduces it exactly once.
|
||||
|
||||
The `decide!` syntax is short for `decide +kernel`.
|
||||
-/
|
||||
syntax (name := decideBang) "decide!" optConfig : tactic
|
||||
|
||||
/--
|
||||
`native_decide` is a synonym for `decide +native`.
|
||||
It will attempt to prove a goal of type `p` by synthesizing an instance
|
||||
|
||||
@@ -133,8 +133,8 @@ def foldNatBinBoolPred (fn : Nat → Nat → Bool) (a₁ a₂ : Expr) : Option E
|
||||
return mkConst ``Bool.false
|
||||
|
||||
def foldNatBeq := fun _ : Bool => foldNatBinBoolPred (fun a b => a == b)
|
||||
def foldNatBle := fun _ : Bool => foldNatBinBoolPred (fun a b => a < b)
|
||||
def foldNatBlt := fun _ : Bool => foldNatBinBoolPred (fun a b => a ≤ b)
|
||||
def foldNatBlt := fun _ : Bool => foldNatBinBoolPred (fun a b => a < b)
|
||||
def foldNatBle := fun _ : Bool => foldNatBinBoolPred (fun a b => a ≤ b)
|
||||
|
||||
def natFoldFns : List (Name × BinFoldFn) :=
|
||||
[(``Nat.add, foldNatAdd),
|
||||
|
||||
@@ -29,4 +29,4 @@ import Lean.Data.Xml
|
||||
import Lean.Data.NameTrie
|
||||
import Lean.Data.RBTree
|
||||
import Lean.Data.RBMap
|
||||
import Lean.Data.Rat
|
||||
import Lean.Data.RArray
|
||||
|
||||
@@ -365,6 +365,7 @@ structure TextDocumentRegistrationOptions where
|
||||
|
||||
inductive MarkupKind where
|
||||
| plaintext | markdown
|
||||
deriving DecidableEq, Hashable
|
||||
|
||||
instance : FromJson MarkupKind := ⟨fun
|
||||
| str "plaintext" => Except.ok MarkupKind.plaintext
|
||||
@@ -378,7 +379,7 @@ instance : ToJson MarkupKind := ⟨fun
|
||||
structure MarkupContent where
|
||||
kind : MarkupKind
|
||||
value : String
|
||||
deriving ToJson, FromJson
|
||||
deriving ToJson, FromJson, DecidableEq, Hashable
|
||||
|
||||
/-- Reference to the progress of some in-flight piece of work.
|
||||
|
||||
|
||||
@@ -25,7 +25,7 @@ inductive CompletionItemKind where
|
||||
| unit | value | enum | keyword | snippet
|
||||
| color | file | reference | folder | enumMember
|
||||
| constant | struct | event | operator | typeParameter
|
||||
deriving Inhabited, DecidableEq, Repr
|
||||
deriving Inhabited, DecidableEq, Repr, Hashable
|
||||
|
||||
instance : ToJson CompletionItemKind where
|
||||
toJson a := toJson (a.toCtorIdx + 1)
|
||||
@@ -39,11 +39,11 @@ structure InsertReplaceEdit where
|
||||
newText : String
|
||||
insert : Range
|
||||
replace : Range
|
||||
deriving FromJson, ToJson
|
||||
deriving FromJson, ToJson, BEq, Hashable
|
||||
|
||||
inductive CompletionItemTag where
|
||||
| deprecated
|
||||
deriving Inhabited, DecidableEq, Repr
|
||||
deriving Inhabited, DecidableEq, Repr, Hashable
|
||||
|
||||
instance : ToJson CompletionItemTag where
|
||||
toJson t := toJson (t.toCtorIdx + 1)
|
||||
@@ -73,7 +73,7 @@ structure CompletionItem where
|
||||
commitCharacters? : string[]
|
||||
command? : Command
|
||||
-/
|
||||
deriving FromJson, ToJson, Inhabited
|
||||
deriving FromJson, ToJson, Inhabited, BEq, Hashable
|
||||
|
||||
structure CompletionList where
|
||||
isIncomplete : Bool
|
||||
|
||||
@@ -33,6 +33,16 @@ def find? (m : NameMap α) (n : Name) : Option α := RBMap.find? m n
|
||||
instance : ForIn m (NameMap α) (Name × α) :=
|
||||
inferInstanceAs (ForIn _ (RBMap ..) ..)
|
||||
|
||||
/-- `filter f m` returns the `NameMap` consisting of all
|
||||
"`key`/`val`"-pairs in `m` where `f key val` returns `true`. -/
|
||||
def filter (f : Name → α → Bool) (m : NameMap α) : NameMap α := RBMap.filter f m
|
||||
|
||||
/-- `filterMap f m` filters an `NameMap` and simultaneously modifies the filtered values.
|
||||
|
||||
It takes a function `f : Name → α → Option β` and applies `f name` to the value with key `name`.
|
||||
The resulting entries with non-`none` value are collected to form the output `NameMap`. -/
|
||||
def filterMap (f : Name → α → Option β) (m : NameMap α) : NameMap β := RBMap.filterMap f m
|
||||
|
||||
end NameMap
|
||||
|
||||
def NameSet := RBTree Name Name.quickCmp
|
||||
@@ -53,6 +63,9 @@ def append (s t : NameSet) : NameSet :=
|
||||
instance : Append NameSet where
|
||||
append := NameSet.append
|
||||
|
||||
/-- `filter f s` returns the `NameSet` consisting of all `x` in `s` where `f x` returns `true`. -/
|
||||
def filter (f : Name → Bool) (s : NameSet) : NameSet := RBTree.filter f s
|
||||
|
||||
end NameSet
|
||||
|
||||
def NameSSet := SSet Name
|
||||
@@ -73,6 +86,9 @@ instance : EmptyCollection NameHashSet := ⟨empty⟩
|
||||
instance : Inhabited NameHashSet := ⟨{}⟩
|
||||
def insert (s : NameHashSet) (n : Name) := Std.HashSet.insert s n
|
||||
def contains (s : NameHashSet) (n : Name) : Bool := Std.HashSet.contains s n
|
||||
|
||||
/-- `filter f s` returns the `NameHashSet` consisting of all `x` in `s` where `f x` returns `true`. -/
|
||||
def filter (f : Name → Bool) (s : NameHashSet) : NameHashSet := Std.HashSet.filter f s
|
||||
end NameHashSet
|
||||
|
||||
def MacroScopesView.isPrefixOf (v₁ v₂ : MacroScopesView) : Bool :=
|
||||
|
||||
75
src/Lean/Data/RArray.lean
Normal file
75
src/Lean/Data/RArray.lean
Normal file
@@ -0,0 +1,75 @@
|
||||
/-
|
||||
Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Joachim Breitner
|
||||
-/
|
||||
|
||||
prelude
|
||||
import Init.Data.RArray
|
||||
import Lean.ToExpr
|
||||
|
||||
/-!
|
||||
Auxillary definitions related to `Lean.RArray` that are typically only used in meta-code, in
|
||||
particular the `ToExpr` instance.
|
||||
-/
|
||||
|
||||
namespace Lean
|
||||
|
||||
-- This function could live in Init/Data/RArray.lean, but without omega it's tedious to implement
|
||||
def RArray.ofFn {n : Nat} (f : Fin n → α) (h : 0 < n) : RArray α :=
|
||||
go 0 n h (Nat.le_refl _)
|
||||
where
|
||||
go (lb ub : Nat) (h1 : lb < ub) (h2 : ub ≤ n) : RArray α :=
|
||||
if h : lb + 1 = ub then
|
||||
.leaf (f ⟨lb, Nat.lt_of_lt_of_le h1 h2⟩)
|
||||
else
|
||||
let mid := (lb + ub)/2
|
||||
.branch mid (go lb mid (by omega) (by omega)) (go mid ub (by omega) h2)
|
||||
|
||||
def RArray.ofArray (xs : Array α) (h : 0 < xs.size) : RArray α :=
|
||||
.ofFn (xs[·]) h
|
||||
|
||||
/-- The correctness theorem for `ofFn` -/
|
||||
theorem RArray.get_ofFn {n : Nat} (f : Fin n → α) (h : 0 < n) (i : Fin n) :
|
||||
(ofFn f h).get i = f i :=
|
||||
go 0 n h (Nat.le_refl _) (Nat.zero_le _) i.2
|
||||
where
|
||||
go lb ub h1 h2 (h3 : lb ≤ i.val) (h3 : i.val < ub) : (ofFn.go f lb ub h1 h2).get i = f i := by
|
||||
induction lb, ub, h1, h2 using RArray.ofFn.go.induct (f := f) (n := n)
|
||||
case case1 =>
|
||||
simp [ofFn.go, RArray.get_eq_getImpl, RArray.getImpl]
|
||||
congr
|
||||
omega
|
||||
case case2 ih1 ih2 hiu =>
|
||||
rw [ofFn.go]; simp only [↓reduceDIte, *]
|
||||
simp [RArray.get_eq_getImpl, RArray.getImpl] at *
|
||||
split
|
||||
· rw [ih1] <;> omega
|
||||
· rw [ih2] <;> omega
|
||||
|
||||
@[simp]
|
||||
theorem RArray.size_ofFn {n : Nat} (f : Fin n → α) (h : 0 < n) :
|
||||
(ofFn f h).size = n :=
|
||||
go 0 n h (Nat.le_refl _)
|
||||
where
|
||||
go lb ub h1 h2 : (ofFn.go f lb ub h1 h2).size = ub - lb := by
|
||||
induction lb, ub, h1, h2 using RArray.ofFn.go.induct (f := f) (n := n)
|
||||
case case1 => simp [ofFn.go, size]; omega
|
||||
case case2 ih1 ih2 hiu => rw [ofFn.go]; simp [size, *]; omega
|
||||
|
||||
section Meta
|
||||
open Lean
|
||||
|
||||
def RArray.toExpr (ty : Expr) (f : α → Expr) : RArray α → Expr
|
||||
| .leaf x =>
|
||||
mkApp2 (mkConst ``RArray.leaf) ty (f x)
|
||||
| .branch p l r =>
|
||||
mkApp4 (mkConst ``RArray.branch) ty (mkRawNatLit p) (l.toExpr ty f) (r.toExpr ty f)
|
||||
|
||||
instance [ToExpr α] : ToExpr (RArray α) where
|
||||
toTypeExpr := mkApp (mkConst ``RArray) (toTypeExpr α)
|
||||
toExpr a := a.toExpr (toTypeExpr α) toExpr
|
||||
|
||||
end Meta
|
||||
|
||||
end Lean
|
||||
@@ -404,6 +404,24 @@ def intersectBy {γ : Type v₁} {δ : Type v₂} (mergeFn : α → β → γ
|
||||
| some b₂ => acc.insert a <| mergeFn a b₁ b₂
|
||||
| none => acc
|
||||
|
||||
/--
|
||||
`filter f m` returns the `RBMap` consisting of all
|
||||
"`key`/`val`"-pairs in `m` where `f key val` returns `true`.
|
||||
-/
|
||||
def filter (f : α → β → Bool) (m : RBMap α β cmp) : RBMap α β cmp :=
|
||||
m.fold (fun r k v => if f k v then r.insert k v else r) {}
|
||||
|
||||
/--
|
||||
`filterMap f m` filters an `RBMap` and simultaneously modifies the filtered values.
|
||||
|
||||
It takes a function `f : α → β → Option γ` and applies `f k v` to the value with key `k`.
|
||||
The resulting entries with non-`none` value are collected to form the output `RBMap`.
|
||||
-/
|
||||
def filterMap (f : α → β → Option γ) (m : RBMap α β cmp) : RBMap α γ cmp :=
|
||||
m.fold (fun r k v => match f k v with
|
||||
| none => r
|
||||
| some b => r.insert k b) {}
|
||||
|
||||
end RBMap
|
||||
|
||||
def rbmapOf {α : Type u} {β : Type v} (l : List (α × β)) (cmp : α → α → Ordering) : RBMap α β cmp :=
|
||||
|
||||
@@ -114,6 +114,13 @@ def union (t₁ t₂ : RBTree α cmp) : RBTree α cmp :=
|
||||
def diff (t₁ t₂ : RBTree α cmp) : RBTree α cmp :=
|
||||
t₂.fold .erase t₁
|
||||
|
||||
/--
|
||||
`filter f m` returns the `RBTree` consisting of all
|
||||
`x` in `m` where `f x` returns `true`.
|
||||
-/
|
||||
def filter (f : α → Bool) (m : RBTree α cmp) : RBTree α cmp :=
|
||||
RBMap.filter (fun a _ => f a) m
|
||||
|
||||
end RBTree
|
||||
|
||||
def rbtreeOf {α : Type u} (l : List α) (cmp : α → α → Ordering) : RBTree α cmp :=
|
||||
|
||||
@@ -1399,8 +1399,8 @@ private def elabAppLValsAux (namedArgs : Array NamedArg) (args : Array Arg) (exp
|
||||
let rec loop : Expr → List LVal → TermElabM Expr
|
||||
| f, [] => elabAppArgs f namedArgs args expectedType? explicit ellipsis
|
||||
| f, lval::lvals => do
|
||||
if let LVal.fieldName (fullRef := fullRef) .. := lval then
|
||||
addDotCompletionInfo fullRef f expectedType?
|
||||
if let LVal.fieldName (ref := ref) .. := lval then
|
||||
addDotCompletionInfo ref f expectedType?
|
||||
let hasArgs := !namedArgs.isEmpty || !args.isEmpty
|
||||
let (f, lvalRes) ← resolveLVal f lval hasArgs
|
||||
match lvalRes with
|
||||
@@ -1650,6 +1650,14 @@ private def getSuccesses (candidates : Array (TermElabResult Expr)) : TermElabM
|
||||
-/
|
||||
private def mergeFailures (failures : Array (TermElabResult Expr)) : TermElabM α := do
|
||||
let exs := failures.map fun | .error ex _ => ex | _ => unreachable!
|
||||
let trees := failures.map (fun | .error _ s => s.meta.core.infoState.trees | _ => unreachable!)
|
||||
|>.filterMap (·[0]?)
|
||||
-- Retain partial `InfoTree` subtrees in an `.ofChoiceInfo` node in case of multiple failures.
|
||||
-- This ensures that the language server still has `Info` to work with when multiple overloaded
|
||||
-- elaborators fail.
|
||||
withInfoContext (mkInfo := pure <| .ofChoiceInfo { elaborator := .anonymous, stx := ← getRef }) do
|
||||
for tree in trees do
|
||||
pushInfoTree tree
|
||||
throwErrorWithNestedErrors "overloaded" exs
|
||||
|
||||
private def elabAppAux (f : Syntax) (namedArgs : Array NamedArg) (args : Array Arg) (ellipsis : Bool) (expectedType? : Option Expr) : TermElabM Expr := do
|
||||
|
||||
@@ -42,16 +42,15 @@ private def elabOptLevel (stx : Syntax) : TermElabM Level :=
|
||||
@[builtin_term_elab «completion»] def elabCompletion : TermElab := fun stx expectedType? => do
|
||||
/- `ident.` is ambiguous in Lean, we may try to be completing a declaration name or access a "field". -/
|
||||
if stx[0].isIdent then
|
||||
/- If we can elaborate the identifier successfully, we assume it is a dot-completion. Otherwise, we treat it as
|
||||
identifier completion with a dangling `.`.
|
||||
Recall that the server falls back to identifier completion when dot-completion fails. -/
|
||||
-- Add both an `id` and a `dot` `CompletionInfo` and have the language server figure out which
|
||||
-- one to use.
|
||||
addCompletionInfo <| CompletionInfo.id stx stx[0].getId (danglingDot := true) (← getLCtx) expectedType?
|
||||
let s ← saveState
|
||||
try
|
||||
let e ← elabTerm stx[0] none
|
||||
addDotCompletionInfo stx e expectedType?
|
||||
catch _ =>
|
||||
s.restore
|
||||
addCompletionInfo <| CompletionInfo.id stx stx[0].getId (danglingDot := true) (← getLCtx) expectedType?
|
||||
throwErrorAt stx[1] "invalid field notation, identifier or numeral expected"
|
||||
else
|
||||
elabPipeCompletion stx expectedType?
|
||||
@@ -328,7 +327,7 @@ private def mkSilentAnnotationIfHole (e : Expr) : TermElabM Expr := do
|
||||
@[builtin_term_elab withAnnotateTerm] def elabWithAnnotateTerm : TermElab := fun stx expectedType? => do
|
||||
match stx with
|
||||
| `(with_annotate_term $stx $e) =>
|
||||
withInfoContext' stx (elabTerm e expectedType?) (mkTermInfo .anonymous (expectedType? := expectedType?) stx)
|
||||
withTermInfoContext' .anonymous stx (expectedType? := expectedType?) (elabTerm e expectedType?)
|
||||
| _ => throwUnsupportedSyntax
|
||||
|
||||
private unsafe def evalFilePathUnsafe (stx : Syntax) : TermElabM System.FilePath :=
|
||||
|
||||
@@ -214,7 +214,7 @@ private def addTraceAsMessagesCore (ctx : Context) (log : MessageLog) (traceStat
|
||||
let mut log := log
|
||||
let traces' := traces.toArray.qsort fun ((a, _), _) ((b, _), _) => a < b
|
||||
for ((pos, endPos), traceMsg) in traces' do
|
||||
let data := .tagged `_traceMsg <| .joinSep traceMsg.toList "\n"
|
||||
let data := .tagged `trace <| .joinSep traceMsg.toList "\n"
|
||||
log := log.add <| mkMessageCore ctx.fileName ctx.fileMap data .information pos endPos
|
||||
return log
|
||||
|
||||
@@ -555,7 +555,11 @@ private def getVarDecls (s : State) : Array Syntax :=
|
||||
instance {α} : Inhabited (CommandElabM α) where
|
||||
default := throw default
|
||||
|
||||
private def mkMetaContext : Meta.Context := {
|
||||
/--
|
||||
The environment linter framework needs to be able to run linters with the same context
|
||||
as `liftTermElabM`, so we expose that context as a public function here.
|
||||
-/
|
||||
def mkMetaContext : Meta.Context := {
|
||||
config := { foApprox := true, ctxApprox := true, quasiPatternApprox := true }
|
||||
}
|
||||
|
||||
|
||||
@@ -327,15 +327,18 @@ private def toExprCore (t : Tree) : TermElabM Expr := do
|
||||
| .term _ trees e =>
|
||||
modifyInfoState (fun s => { s with trees := s.trees ++ trees }); return e
|
||||
| .binop ref kind f lhs rhs =>
|
||||
withRef ref <| withInfoContext' ref (mkInfo := mkTermInfo .anonymous ref) do
|
||||
mkBinOp (kind == .lazy) f (← toExprCore lhs) (← toExprCore rhs)
|
||||
withRef ref <|
|
||||
withTermInfoContext' .anonymous ref do
|
||||
mkBinOp (kind == .lazy) f (← toExprCore lhs) (← toExprCore rhs)
|
||||
| .unop ref f arg =>
|
||||
withRef ref <| withInfoContext' ref (mkInfo := mkTermInfo .anonymous ref) do
|
||||
mkUnOp f (← toExprCore arg)
|
||||
withRef ref <|
|
||||
withTermInfoContext' .anonymous ref do
|
||||
mkUnOp f (← toExprCore arg)
|
||||
| .macroExpansion macroName stx stx' nested =>
|
||||
withRef stx <| withInfoContext' stx (mkInfo := mkTermInfo macroName stx) do
|
||||
withMacroExpansion stx stx' do
|
||||
toExprCore nested
|
||||
withRef stx <|
|
||||
withTermInfoContext' macroName stx <|
|
||||
withMacroExpansion stx stx' <|
|
||||
toExprCore nested
|
||||
|
||||
/--
|
||||
Auxiliary function to decide whether we should coerce `f`'s argument to `maxType` or not.
|
||||
|
||||
@@ -139,12 +139,16 @@ def TermInfo.runMetaM (info : TermInfo) (ctx : ContextInfo) (x : MetaM α) : IO
|
||||
|
||||
def TermInfo.format (ctx : ContextInfo) (info : TermInfo) : IO Format := do
|
||||
info.runMetaM ctx do
|
||||
let ty : Format ← try
|
||||
Meta.ppExpr (← Meta.inferType info.expr)
|
||||
catch _ =>
|
||||
pure "<failed-to-infer-type>"
|
||||
let ty : Format ←
|
||||
try
|
||||
Meta.ppExpr (← Meta.inferType info.expr)
|
||||
catch _ =>
|
||||
pure "<failed-to-infer-type>"
|
||||
return f!"{← Meta.ppExpr info.expr} {if info.isBinder then "(isBinder := true) " else ""}: {ty} @ {formatElabInfo ctx info.toElabInfo}"
|
||||
|
||||
def PartialTermInfo.format (ctx : ContextInfo) (info : PartialTermInfo) : Format :=
|
||||
f!"Partial term @ {formatElabInfo ctx info.toElabInfo}"
|
||||
|
||||
def CompletionInfo.format (ctx : ContextInfo) (info : CompletionInfo) : IO Format :=
|
||||
match info with
|
||||
| .dot i (expectedType? := expectedType?) .. => return f!"[.] {← i.format ctx} : {expectedType?}"
|
||||
@@ -191,9 +195,13 @@ def FieldRedeclInfo.format (ctx : ContextInfo) (info : FieldRedeclInfo) : Format
|
||||
def OmissionInfo.format (ctx : ContextInfo) (info : OmissionInfo) : IO Format := do
|
||||
return f!"Omission @ {← TermInfo.format ctx info.toTermInfo}\nReason: {info.reason}"
|
||||
|
||||
def ChoiceInfo.format (ctx : ContextInfo) (info : ChoiceInfo) : Format :=
|
||||
f!"Choice @ {formatElabInfo ctx info.toElabInfo}"
|
||||
|
||||
def Info.format (ctx : ContextInfo) : Info → IO Format
|
||||
| ofTacticInfo i => i.format ctx
|
||||
| ofTermInfo i => i.format ctx
|
||||
| ofPartialTermInfo i => pure <| i.format ctx
|
||||
| ofCommandInfo i => i.format ctx
|
||||
| ofMacroExpansionInfo i => i.format ctx
|
||||
| ofOptionInfo i => i.format ctx
|
||||
@@ -204,10 +212,12 @@ def Info.format (ctx : ContextInfo) : Info → IO Format
|
||||
| ofFVarAliasInfo i => pure <| i.format
|
||||
| ofFieldRedeclInfo i => pure <| i.format ctx
|
||||
| ofOmissionInfo i => i.format ctx
|
||||
| ofChoiceInfo i => pure <| i.format ctx
|
||||
|
||||
def Info.toElabInfo? : Info → Option ElabInfo
|
||||
| ofTacticInfo i => some i.toElabInfo
|
||||
| ofTermInfo i => some i.toElabInfo
|
||||
| ofPartialTermInfo i => some i.toElabInfo
|
||||
| ofCommandInfo i => some i.toElabInfo
|
||||
| ofMacroExpansionInfo _ => none
|
||||
| ofOptionInfo _ => none
|
||||
@@ -218,6 +228,7 @@ def Info.toElabInfo? : Info → Option ElabInfo
|
||||
| ofFVarAliasInfo _ => none
|
||||
| ofFieldRedeclInfo _ => none
|
||||
| ofOmissionInfo i => some i.toElabInfo
|
||||
| ofChoiceInfo i => some i.toElabInfo
|
||||
|
||||
/--
|
||||
Helper function for propagating the tactic metavariable context to its children nodes.
|
||||
@@ -311,24 +322,36 @@ def realizeGlobalNameWithInfos (ref : Syntax) (id : Name) : CoreM (List (Name ×
|
||||
addConstInfo ref n
|
||||
return ns
|
||||
|
||||
/-- Use this to descend a node on the infotree that is being built.
|
||||
/--
|
||||
Adds a node containing the `InfoTree`s generated by `x` to the `InfoTree`s in `m`.
|
||||
|
||||
It saves the current list of trees `t₀` and resets it and then runs `x >>= mkInfo`, producing either an `i : Info` or a hole id.
|
||||
Running `x >>= mkInfo` will modify the trees state and produce a new list of trees `t₁`.
|
||||
In the `i : Info` case, `t₁` become the children of a node `node i t₁` that is appended to `t₀`.
|
||||
-/
|
||||
def withInfoContext' [MonadFinally m] (x : m α) (mkInfo : α → m (Sum Info MVarId)) : m α := do
|
||||
If `x` succeeds and `mkInfo` yields an `Info`, the `InfoTree`s of `x` become subtrees of a node
|
||||
containing the `Info` produced by `mkInfo`, which is then added to the `InfoTree`s in `m`.
|
||||
If `x` succeeds and `mkInfo` yields an `MVarId`, the `InfoTree`s of `x` are discarded and a `hole`
|
||||
node is added to the `InfoTree`s in `m`.
|
||||
If `x` fails, the `InfoTree`s of `x` become subtrees of a node containing the `Info` produced by
|
||||
`mkInfoOnError`, which is then added to the `InfoTree`s in `m`.
|
||||
|
||||
The `InfoTree`s in `m` are reset before `x` is executed and restored with the addition of a new tree
|
||||
after `x` is executed.
|
||||
-/
|
||||
def withInfoContext'
|
||||
[MonadFinally m]
|
||||
(x : m α)
|
||||
(mkInfo : α → m (Sum Info MVarId))
|
||||
(mkInfoOnError : m Info) :
|
||||
m α := do
|
||||
if (← getInfoState).enabled then
|
||||
let treesSaved ← getResetInfoTrees
|
||||
Prod.fst <$> MonadFinally.tryFinally' x fun a? => do
|
||||
match a? with
|
||||
| none => modifyInfoTrees fun _ => treesSaved
|
||||
| some a =>
|
||||
let info ← mkInfo a
|
||||
modifyInfoTrees fun trees =>
|
||||
match info with
|
||||
| Sum.inl info => treesSaved.push <| InfoTree.node info trees
|
||||
| Sum.inr mvarId => treesSaved.push <| InfoTree.hole mvarId
|
||||
let info ← do
|
||||
match a? with
|
||||
| none => pure <| .inl <| ← mkInfoOnError
|
||||
| some a => mkInfo a
|
||||
modifyInfoTrees fun trees =>
|
||||
match info with
|
||||
| Sum.inl info => treesSaved.push <| InfoTree.node info trees
|
||||
| Sum.inr mvarId => treesSaved.push <| InfoTree.hole mvarId
|
||||
else
|
||||
x
|
||||
|
||||
|
||||
@@ -70,6 +70,18 @@ structure TermInfo extends ElabInfo where
|
||||
isBinder : Bool := false
|
||||
deriving Inhabited
|
||||
|
||||
/--
|
||||
Used instead of `TermInfo` when a term couldn't successfully be elaborated,
|
||||
and so there is no complete expression available.
|
||||
|
||||
The main purpose of `PartialTermInfo` is to ensure that the sub-`InfoTree`s of a failed elaborator
|
||||
are retained so that they can still be used in the language server.
|
||||
-/
|
||||
structure PartialTermInfo extends ElabInfo where
|
||||
lctx : LocalContext -- The local context when the term was elaborated.
|
||||
expectedType? : Option Expr
|
||||
deriving Inhabited
|
||||
|
||||
structure CommandInfo extends ElabInfo where
|
||||
deriving Inhabited
|
||||
|
||||
@@ -79,7 +91,7 @@ inductive CompletionInfo where
|
||||
| dot (termInfo : TermInfo) (expectedType? : Option Expr)
|
||||
| id (stx : Syntax) (id : Name) (danglingDot : Bool) (lctx : LocalContext) (expectedType? : Option Expr)
|
||||
| dotId (stx : Syntax) (id : Name) (lctx : LocalContext) (expectedType? : Option Expr)
|
||||
| fieldId (stx : Syntax) (id : Name) (lctx : LocalContext) (structName : Name)
|
||||
| fieldId (stx : Syntax) (id : Option Name) (lctx : LocalContext) (structName : Name)
|
||||
| namespaceId (stx : Syntax)
|
||||
| option (stx : Syntax)
|
||||
| endSection (stx : Syntax) (scopeNames : List String)
|
||||
@@ -165,10 +177,18 @@ regular delaboration settings.
|
||||
structure OmissionInfo extends TermInfo where
|
||||
reason : String
|
||||
|
||||
/--
|
||||
Indicates that all overloaded elaborators failed. The subtrees of a `ChoiceInfo` node are the
|
||||
partial `InfoTree`s of those failed elaborators. Retaining these partial `InfoTree`s helps
|
||||
the language server provide interactivity even when all overloaded elaborators failed.
|
||||
-/
|
||||
structure ChoiceInfo extends ElabInfo where
|
||||
|
||||
/-- Header information for a node in `InfoTree`. -/
|
||||
inductive Info where
|
||||
| ofTacticInfo (i : TacticInfo)
|
||||
| ofTermInfo (i : TermInfo)
|
||||
| ofPartialTermInfo (i : PartialTermInfo)
|
||||
| ofCommandInfo (i : CommandInfo)
|
||||
| ofMacroExpansionInfo (i : MacroExpansionInfo)
|
||||
| ofOptionInfo (i : OptionInfo)
|
||||
@@ -179,6 +199,7 @@ inductive Info where
|
||||
| ofFVarAliasInfo (i : FVarAliasInfo)
|
||||
| ofFieldRedeclInfo (i : FieldRedeclInfo)
|
||||
| ofOmissionInfo (i : OmissionInfo)
|
||||
| ofChoiceInfo (i : ChoiceInfo)
|
||||
deriving Inhabited
|
||||
|
||||
/-- The InfoTree is a structure that is generated during elaboration and used
|
||||
|
||||
@@ -90,9 +90,12 @@ private def elabLetRecDeclValues (view : LetRecView) : TermElabM (Array Expr) :=
|
||||
for i in [0:view.binderIds.size] do
|
||||
addLocalVarInfo view.binderIds[i]! xs[i]!
|
||||
withDeclName view.declName do
|
||||
withInfoContext' view.valStx (mkInfo := (pure <| .inl <| mkBodyInfo view.valStx ·)) do
|
||||
let value ← elabTermEnsuringType view.valStx type
|
||||
mkLambdaFVars xs value
|
||||
withInfoContext' view.valStx
|
||||
(mkInfo := (pure <| .inl <| mkBodyInfo view.valStx ·))
|
||||
(mkInfoOnError := (pure <| mkBodyInfo view.valStx none))
|
||||
do
|
||||
let value ← elabTermEnsuringType view.valStx type
|
||||
mkLambdaFVars xs value
|
||||
|
||||
private def registerLetRecsToLift (views : Array LetRecDeclView) (fvars : Array Expr) (values : Array Expr) : TermElabM Unit := do
|
||||
let letRecsToLiftCurr := (← get).letRecsToLift
|
||||
|
||||
@@ -644,7 +644,7 @@ where
|
||||
if inaccessible? p |>.isSome then
|
||||
return mkMData k (← withReader (fun _ => true) (go b))
|
||||
else if let some (stx, p) := patternWithRef? p then
|
||||
Elab.withInfoContext' (go p) fun p => do
|
||||
Elab.withInfoContext' (go p) (mkInfoOnError := mkPartialTermInfo .anonymous stx) fun p => do
|
||||
/- If `p` is a free variable and we are not inside of an "inaccessible" pattern, this `p` is a binder. -/
|
||||
mkTermInfo Name.anonymous stx p (isBinder := p.isFVar && !(← read))
|
||||
else
|
||||
|
||||
@@ -283,7 +283,7 @@ private partial def withFunLocalDecls {α} (headers : Array DefViewElabHeader) (
|
||||
loop 0 #[]
|
||||
|
||||
private def expandWhereStructInst : Macro
|
||||
| `(Parser.Command.whereStructInst|where $[$decls:letDecl];* $[$whereDecls?:whereDecls]?) => do
|
||||
| whereStx@`(Parser.Command.whereStructInst|where%$whereTk $[$decls:letDecl];* $[$whereDecls?:whereDecls]?) => do
|
||||
let letIdDecls ← decls.mapM fun stx => match stx with
|
||||
| `(letDecl|$_decl:letPatDecl) => Macro.throwErrorAt stx "patterns are not allowed here"
|
||||
| `(letDecl|$decl:letEqnsDecl) => expandLetEqnsDecl decl (useExplicit := false)
|
||||
@@ -300,7 +300,30 @@ private def expandWhereStructInst : Macro
|
||||
`(structInstField|$id:ident := $val)
|
||||
| stx@`(letIdDecl|_ $_* $[: $_]? := $_) => Macro.throwErrorAt stx "'_' is not allowed here"
|
||||
| _ => Macro.throwUnsupported
|
||||
|
||||
let startOfStructureTkInfo : SourceInfo :=
|
||||
match whereTk.getPos? with
|
||||
| some pos => .synthetic pos ⟨pos.byteIdx + 1⟩ true
|
||||
| none => .none
|
||||
-- Position the closing `}` at the end of the trailing whitespace of `where $[$_:letDecl];*`.
|
||||
-- We need an accurate range of the generated structure instance in the generated `TermInfo`
|
||||
-- so that we can determine the expected type in structure field completion.
|
||||
let structureStxTailInfo :=
|
||||
whereStx[1].getTailInfo?
|
||||
<|> whereStx[0].getTailInfo?
|
||||
let endOfStructureTkInfo : SourceInfo :=
|
||||
match structureStxTailInfo with
|
||||
| some (SourceInfo.original _ _ trailing _) =>
|
||||
let tokenPos := trailing.str.prev trailing.stopPos
|
||||
let tokenEndPos := trailing.stopPos
|
||||
.synthetic tokenPos tokenEndPos true
|
||||
| _ => .none
|
||||
|
||||
let body ← `(structInst| { $structInstFields,* })
|
||||
let body := body.raw.setInfo <|
|
||||
match startOfStructureTkInfo.getPos?, endOfStructureTkInfo.getTailPos? with
|
||||
| some startPos, some endPos => .synthetic startPos endPos true
|
||||
| _, _ => .none
|
||||
match whereDecls? with
|
||||
| some whereDecls => expandWhereDecls whereDecls body
|
||||
| none => return body
|
||||
@@ -417,12 +440,15 @@ private def elabFunValues (headers : Array DefViewElabHeader) (vars : Array Expr
|
||||
-- Store instantiated body in info tree for the benefit of the unused variables linter
|
||||
-- and other metaprograms that may want to inspect it without paying for the instantiation
|
||||
-- again
|
||||
withInfoContext' valStx (mkInfo := (pure <| .inl <| mkBodyInfo valStx ·)) do
|
||||
-- synthesize mvars here to force the top-level tactic block (if any) to run
|
||||
let val ← elabTermEnsuringType valStx type <* synthesizeSyntheticMVarsNoPostponing
|
||||
-- NOTE: without this `instantiatedMVars`, `mkLambdaFVars` may leave around a redex that
|
||||
-- leads to more section variables being included than necessary
|
||||
instantiateMVarsProfiling val
|
||||
withInfoContext' valStx
|
||||
(mkInfo := (pure <| .inl <| mkBodyInfo valStx ·))
|
||||
(mkInfoOnError := (pure <| mkBodyInfo valStx none))
|
||||
do
|
||||
-- synthesize mvars here to force the top-level tactic block (if any) to run
|
||||
let val ← elabTermEnsuringType valStx type <* synthesizeSyntheticMVarsNoPostponing
|
||||
-- NOTE: without this `instantiatedMVars`, `mkLambdaFVars` may leave around a redex that
|
||||
-- leads to more section variables being included than necessary
|
||||
instantiateMVarsProfiling val
|
||||
let val ← mkLambdaFVars xs val
|
||||
if linter.unusedSectionVars.get (← getOptions) && !header.type.hasSorry && !val.hasSorry then
|
||||
let unusedVars ← vars.filterMapM fun var => do
|
||||
|
||||
@@ -50,7 +50,9 @@ private partial def mkProof (declName : Name) (type : Expr) : MetaM Expr := do
|
||||
go mvarId
|
||||
else if let some mvarId ← whnfReducibleLHS? mvarId then
|
||||
go mvarId
|
||||
else match (← simpTargetStar mvarId { config.dsimp := false } (simprocs := {})).1 with
|
||||
else
|
||||
let ctx ← Simp.mkContext (config := { dsimp := false })
|
||||
match (← simpTargetStar mvarId ctx (simprocs := {})).1 with
|
||||
| TacticResultCNM.closed => return ()
|
||||
| TacticResultCNM.modified mvarId => go mvarId
|
||||
| TacticResultCNM.noChange =>
|
||||
|
||||
@@ -45,7 +45,9 @@ where
|
||||
go mvarId
|
||||
else if let some mvarId ← simpIf? mvarId then
|
||||
go mvarId
|
||||
else match (← simpTargetStar mvarId {} (simprocs := {})).1 with
|
||||
else
|
||||
let ctx ← Simp.mkContext
|
||||
match (← simpTargetStar mvarId ctx (simprocs := {})).1 with
|
||||
| TacticResultCNM.closed => return ()
|
||||
| TacticResultCNM.modified mvarId => go mvarId
|
||||
| TacticResultCNM.noChange =>
|
||||
|
||||
@@ -243,7 +243,7 @@ def tryAllArgs (fnNames : Array Name) (xs : Array Expr) (values : Array Expr)
|
||||
recArgInfoss := recArgInfoss.push recArgInfos
|
||||
-- Put non-indices first
|
||||
recArgInfoss := recArgInfoss.map nonIndicesFirst
|
||||
trace[Elab.definition.structural] "recArgInfoss: {recArgInfoss.map (·.map (·.recArgPos))}"
|
||||
trace[Elab.definition.structural] "recArgInfos:{indentD (.joinSep (recArgInfoss.flatten.toList.map (repr ·)) Format.line)}"
|
||||
-- Inductive groups to consider
|
||||
let groups ← inductiveGroups recArgInfoss.flatten
|
||||
trace[Elab.definition.structural] "inductive groups: {groups}"
|
||||
|
||||
@@ -27,7 +27,7 @@ constituents.
|
||||
structure IndGroupInfo where
|
||||
all : Array Name
|
||||
numNested : Nat
|
||||
deriving BEq, Inhabited
|
||||
deriving BEq, Inhabited, Repr
|
||||
|
||||
def IndGroupInfo.ofInductiveVal (indInfo : InductiveVal) : IndGroupInfo where
|
||||
all := indInfo.all.toArray
|
||||
@@ -56,7 +56,7 @@ mutual structural recursion on such incompatible types.
|
||||
structure IndGroupInst extends IndGroupInfo where
|
||||
levels : List Level
|
||||
params : Array Expr
|
||||
deriving Inhabited
|
||||
deriving Inhabited, Repr
|
||||
|
||||
def IndGroupInst.toMessageData (igi : IndGroupInst) : MessageData :=
|
||||
mkAppN (.const igi.all[0]! igi.levels) igi.params
|
||||
|
||||
@@ -23,9 +23,9 @@ structure RecArgInfo where
|
||||
fnName : Name
|
||||
/-- the fixed prefix of arguments of the function we are trying to justify termination using structural recursion. -/
|
||||
numFixed : Nat
|
||||
/-- position of the argument (counted including fixed prefix) we are recursing on -/
|
||||
/-- position (counted including fixed prefix) of the argument we are recursing on -/
|
||||
recArgPos : Nat
|
||||
/-- position of the indices (counted including fixed prefix) of the inductive datatype indices we are recursing on -/
|
||||
/-- position (counted including fixed prefix) of the indices of the inductive datatype we are recursing on -/
|
||||
indicesPos : Array Nat
|
||||
/-- The inductive group (with parameters) of the argument's type -/
|
||||
indGroupInst : IndGroupInst
|
||||
@@ -34,20 +34,23 @@ structure RecArgInfo where
|
||||
If `< indAll.all`, a normal data type, else an auxiliary data type due to nested recursion
|
||||
-/
|
||||
indIdx : Nat
|
||||
deriving Inhabited
|
||||
deriving Inhabited, Repr
|
||||
|
||||
/--
|
||||
If `xs` are the parameters of the functions (excluding fixed prefix), partitions them
|
||||
into indices and major arguments, and other parameters.
|
||||
-/
|
||||
def RecArgInfo.pickIndicesMajor (info : RecArgInfo) (xs : Array Expr) : (Array Expr × Array Expr) := Id.run do
|
||||
-- First indices and major arg, using the order they appear in `info.indicesPos`
|
||||
let mut indexMajorArgs := #[]
|
||||
let indexMajorPos := info.indicesPos.push info.recArgPos
|
||||
for j in indexMajorPos do
|
||||
assert! info.numFixed ≤ j && j - info.numFixed < xs.size
|
||||
indexMajorArgs := indexMajorArgs.push xs[j - info.numFixed]!
|
||||
-- Then the other arguments, in the order they appear in `xs`
|
||||
let mut otherArgs := #[]
|
||||
for h : i in [:xs.size] do
|
||||
let j := i + info.numFixed
|
||||
if j = info.recArgPos || info.indicesPos.contains j then
|
||||
indexMajorArgs := indexMajorArgs.push xs[i]
|
||||
else
|
||||
unless indexMajorPos.contains (i + info.numFixed) do
|
||||
otherArgs := otherArgs.push xs[i]
|
||||
return (indexMajorArgs, otherArgs)
|
||||
|
||||
|
||||
@@ -57,7 +57,9 @@ private partial def mkProof (declName : Name) (type : Expr) : MetaM Expr := do
|
||||
go mvarId
|
||||
else if let some mvarId ← whnfReducibleLHS? mvarId then
|
||||
go mvarId
|
||||
else match (← simpTargetStar mvarId { config.dsimp := false } (simprocs := {})).1 with
|
||||
else
|
||||
let ctx ← Simp.mkContext (config := { dsimp := false })
|
||||
match (← simpTargetStar mvarId ctx (simprocs := {})).1 with
|
||||
| TacticResultCNM.closed => return ()
|
||||
| TacticResultCNM.modified mvarId => go mvarId
|
||||
| TacticResultCNM.noChange =>
|
||||
|
||||
@@ -227,7 +227,7 @@ def mkFix (preDef : PreDefinition) (prefixArgs : Array Expr) (argsPacker : ArgsP
|
||||
-- decreasing goals when the function has only one non fixed argument.
|
||||
-- This renaming is irrelevant if the function has multiple non fixed arguments. See `process*` functions above.
|
||||
let lctx := (← getLCtx).setUserName x.fvarId! varName
|
||||
withTheReader Meta.Context (fun ctx => { ctx with lctx }) do
|
||||
withLCtx' lctx do
|
||||
let F := xs[1]!
|
||||
let val := preDef.value.beta (prefixArgs.push x)
|
||||
let val ← processSumCasesOn x F val fun x F val => do
|
||||
|
||||
@@ -166,7 +166,7 @@ def mayOmitSizeOf (is_mutual : Bool) (args : Array Expr) (x : Expr) : MetaM Bool
|
||||
def withUserNames {α} (xs : Array Expr) (ns : Array Name) (k : MetaM α) : MetaM α := do
|
||||
let mut lctx ← getLCtx
|
||||
for x in xs, n in ns do lctx := lctx.setUserName x.fvarId! n
|
||||
withTheReader Meta.Context (fun ctx => { ctx with lctx }) k
|
||||
withLCtx' lctx k
|
||||
|
||||
/-- Create one measure for each (eligible) parameter of the given predefintion. -/
|
||||
def simpleMeasures (preDefs : Array PreDefinition) (fixedPrefixSize : Nat)
|
||||
|
||||
@@ -22,7 +22,7 @@ private def levelParamsToMessageData (levelParams : List Name) : MessageData :=
|
||||
m := m ++ ", " ++ toMessageData u
|
||||
return m ++ "}"
|
||||
|
||||
private def mkHeader (kind : String) (id : Name) (levelParams : List Name) (type : Expr) (safety : DefinitionSafety) : CommandElabM MessageData := do
|
||||
private def mkHeader (kind : String) (id : Name) (levelParams : List Name) (type : Expr) (safety : DefinitionSafety) (sig : Bool := true) : CommandElabM MessageData := do
|
||||
let m : MessageData :=
|
||||
match (← getReducibilityStatus id) with
|
||||
| ReducibilityStatus.irreducible => "@[irreducible] "
|
||||
@@ -38,11 +38,13 @@ private def mkHeader (kind : String) (id : Name) (levelParams : List Name) (type
|
||||
let (m, id) := match privateToUserName? id with
|
||||
| some id => (m ++ "private ", id)
|
||||
| none => (m, id)
|
||||
let m := m ++ kind ++ " " ++ id ++ levelParamsToMessageData levelParams ++ " : " ++ type
|
||||
pure m
|
||||
if sig then
|
||||
return m!"{m}{kind} {id}{levelParamsToMessageData levelParams} : {type}"
|
||||
else
|
||||
return m!"{m}{kind}"
|
||||
|
||||
private def mkHeader' (kind : String) (id : Name) (levelParams : List Name) (type : Expr) (isUnsafe : Bool) : CommandElabM MessageData :=
|
||||
mkHeader kind id levelParams type (if isUnsafe then DefinitionSafety.unsafe else DefinitionSafety.safe)
|
||||
private def mkHeader' (kind : String) (id : Name) (levelParams : List Name) (type : Expr) (isUnsafe : Bool) (sig : Bool := true) : CommandElabM MessageData :=
|
||||
mkHeader kind id levelParams type (if isUnsafe then DefinitionSafety.unsafe else DefinitionSafety.safe) (sig := sig)
|
||||
|
||||
private def printDefLike (kind : String) (id : Name) (levelParams : List Name) (type : Expr) (value : Expr) (safety := DefinitionSafety.safe) : CommandElabM Unit := do
|
||||
let m ← mkHeader kind id levelParams type safety
|
||||
@@ -65,32 +67,63 @@ private def printInduct (id : Name) (levelParams : List Name) (numParams : Nat)
|
||||
m := m ++ Format.line ++ ctor ++ " : " ++ cinfo.type
|
||||
logInfo m
|
||||
|
||||
/--
|
||||
Computes the origin of a field. Returns its projection function at the origin.
|
||||
Multiple parents could be the origin of a field, but we say the first parent that provides it is the one that determines the origin.
|
||||
-/
|
||||
private partial def getFieldOrigin (structName field : Name) : MetaM Name := do
|
||||
let env ← getEnv
|
||||
for parent in getStructureParentInfo env structName do
|
||||
if (findField? env parent.structName field).isSome then
|
||||
return ← getFieldOrigin parent.structName field
|
||||
let some fi := getFieldInfo? env structName field
|
||||
| throwError "no such field {field} in {structName}"
|
||||
return fi.projFn
|
||||
|
||||
open Meta in
|
||||
private def printStructure (id : Name) (levelParams : List Name) (numParams : Nat) (type : Expr)
|
||||
(ctor : Name) (fields : Array Name) (isUnsafe : Bool) (isClass : Bool) : CommandElabM Unit := do
|
||||
let kind := if isClass then "class" else "structure"
|
||||
let mut m ← mkHeader' kind id levelParams type isUnsafe
|
||||
m := m ++ Format.line ++ "number of parameters: " ++ toString numParams
|
||||
m := m ++ Format.line ++ "constructor:"
|
||||
let cinfo ← getConstInfo ctor
|
||||
m := m ++ Format.line ++ ctor ++ " : " ++ cinfo.type
|
||||
m := m ++ Format.line ++ "fields:" ++ (← doFields)
|
||||
logInfo m
|
||||
where
|
||||
doFields := liftTermElabM do
|
||||
forallTelescope (← getConstInfo id).type fun params _ =>
|
||||
withLocalDeclD `self (mkAppN (Expr.const id (levelParams.map .param)) params) fun self => do
|
||||
let params := params.push self
|
||||
let mut m : MessageData := ""
|
||||
(isUnsafe : Bool) : CommandElabM Unit := do
|
||||
let env ← getEnv
|
||||
let kind := if isClass env id then "class" else "structure"
|
||||
let header ← mkHeader' kind id levelParams type isUnsafe (sig := false)
|
||||
liftTermElabM <| forallTelescope (← getConstInfo id).type fun params _ =>
|
||||
let s := Expr.const id (levelParams.map .param)
|
||||
withLocalDeclD `self (mkAppN s params) fun self => do
|
||||
let mut m : MessageData := header
|
||||
-- Signature
|
||||
m := m ++ " " ++ .ofFormatWithInfosM do
|
||||
let (stx, infos) ← PrettyPrinter.delabCore s (delab := PrettyPrinter.Delaborator.delabConstWithSignature)
|
||||
pure ⟨← PrettyPrinter.ppTerm ⟨stx⟩, infos⟩
|
||||
m := m ++ Format.line ++ m!"number of parameters: {numParams}"
|
||||
-- Parents
|
||||
let parents := getStructureParentInfo env id
|
||||
unless parents.isEmpty do
|
||||
m := m ++ Format.line ++ "parents:"
|
||||
for parent in parents do
|
||||
let ptype ← inferType (mkApp (mkAppN (.const parent.projFn (levelParams.map .param)) params) self)
|
||||
m := m ++ indentD m!"{.ofConstName parent.projFn (fullNames := true)} : {ptype}"
|
||||
-- Fields
|
||||
let fields := getStructureFieldsFlattened env id (includeSubobjectFields := false)
|
||||
if fields.isEmpty then
|
||||
m := m ++ Format.line ++ "fields: (none)"
|
||||
else
|
||||
m := m ++ Format.line ++ "fields:"
|
||||
for field in fields do
|
||||
match getProjFnForField? (← getEnv) id field with
|
||||
| some proj =>
|
||||
let field : Format := if isPrivateName proj then "private " ++ toString field else toString field
|
||||
let cinfo ← getConstInfo proj
|
||||
let ftype ← instantiateForall cinfo.type params
|
||||
m := m ++ Format.line ++ field ++ " : " ++ ftype
|
||||
| none => panic! "missing structure field info"
|
||||
addMessageContext m
|
||||
let some source := findField? env id field | panic! "missing structure field info"
|
||||
let proj ← getFieldOrigin source field
|
||||
let modifier := if isPrivateName proj then "private " else ""
|
||||
let ftype ← inferType (← mkProjection self field)
|
||||
m := m ++ indentD (m!"{modifier}{.ofConstName proj (fullNames := true)} : {ftype}")
|
||||
-- Constructor
|
||||
let cinfo := getStructureCtor (← getEnv) id
|
||||
let ctorModifier := if isPrivateName cinfo.name then "private " else ""
|
||||
m := m ++ Format.line ++ "constructor:" ++ indentD (ctorModifier ++ .signature cinfo.name)
|
||||
-- Resolution order
|
||||
let resOrder ← getStructureResolutionOrder id
|
||||
if resOrder.size > 1 then
|
||||
m := m ++ Format.line ++ "resolution order:"
|
||||
++ indentD (MessageData.joinSep (resOrder.map (.ofConstName · (fullNames := true))).toList ", ")
|
||||
logInfo m
|
||||
|
||||
private def printIdCore (id : Name) : CommandElabM Unit := do
|
||||
let env ← getEnv
|
||||
@@ -103,11 +136,10 @@ private def printIdCore (id : Name) : CommandElabM Unit := do
|
||||
| ConstantInfo.ctorInfo { levelParams := us, type := t, isUnsafe := u, .. } => printAxiomLike "constructor" id us t u
|
||||
| ConstantInfo.recInfo { levelParams := us, type := t, isUnsafe := u, .. } => printAxiomLike "recursor" id us t u
|
||||
| ConstantInfo.inductInfo { levelParams := us, numParams, type := t, ctors, isUnsafe := u, .. } =>
|
||||
match getStructureInfo? env id with
|
||||
| some { fieldNames, .. } =>
|
||||
let [ctor] := ctors | panic! "structures have only one constructor"
|
||||
printStructure id us numParams t ctor fieldNames u (isClass env id)
|
||||
| none => printInduct id us numParams t ctors u
|
||||
if isStructure env id then
|
||||
printStructure id us numParams t u
|
||||
else
|
||||
printInduct id us numParams t ctors u
|
||||
| none => throwUnknownId id
|
||||
|
||||
private def printId (id : Syntax) : CommandElabM Unit := do
|
||||
|
||||
@@ -11,21 +11,40 @@ import Lean.Elab.App
|
||||
import Lean.Elab.Binders
|
||||
import Lean.PrettyPrinter
|
||||
|
||||
/-!
|
||||
# Structure instance elaborator
|
||||
|
||||
A *structure instance* is notation to construct a term of a `structure`.
|
||||
Examples: `{ x := 2, y.z := true }`, `{ s with cache := c' }`, and `{ s with values[2] := v }`.
|
||||
Structure instances are the preferred way to invoke a `structure`'s constructor,
|
||||
since they hide Lean implementation details such as whether parents are represented as subobjects,
|
||||
and also they do correct processing of default values, which are complicated due to the fact that `structure`s can override default values of their parents.
|
||||
|
||||
This module elaborates structure instance notation.
|
||||
Note that the `where` syntax to define structures (`Lean.Parser.Command.whereStructInst`)
|
||||
macro expands into the structure instance notation elaborated by this module.
|
||||
-/
|
||||
|
||||
namespace Lean.Elab.Term.StructInst
|
||||
|
||||
open Meta
|
||||
open TSyntax.Compat
|
||||
|
||||
/-
|
||||
Structure instances are of the form:
|
||||
|
||||
"{" >> optional (atomic (sepBy1 termParser ", " >> " with "))
|
||||
>> manyIndent (group ((structInstFieldAbbrev <|> structInstField) >> optional ", "))
|
||||
>> optEllipsis
|
||||
>> optional (" : " >> termParser)
|
||||
>> " }"
|
||||
/-!
|
||||
Recall that structure instances are of the form:
|
||||
```
|
||||
"{" >> optional (atomic (sepBy1 termParser ", " >> " with "))
|
||||
>> manyIndent (group ((structInstFieldAbbrev <|> structInstField) >> optional ", "))
|
||||
>> optEllipsis
|
||||
>> optional (" : " >> termParser)
|
||||
>> " }"
|
||||
```
|
||||
-/
|
||||
|
||||
/--
|
||||
Transforms structure instances such as `{ x := 0 : Foo }` into `({ x := 0 } : Foo)`.
|
||||
Structure instance notation makes use of the expected type.
|
||||
-/
|
||||
@[builtin_macro Lean.Parser.Term.structInst] def expandStructInstExpectedType : Macro := fun stx =>
|
||||
let expectedArg := stx[4]
|
||||
if expectedArg.isNone then
|
||||
@@ -35,7 +54,10 @@ open TSyntax.Compat
|
||||
let stxNew := stx.setArg 4 mkNullNode
|
||||
`(($stxNew : $expected))
|
||||
|
||||
/-- Expand field abbreviations. Example: `{ x, y := 0 }` expands to `{ x := x, y := 0 }` -/
|
||||
/--
|
||||
Expands field abbreviation notation.
|
||||
Example: `{ x, y := 0 }` expands to `{ x := x, y := 0 }`.
|
||||
-/
|
||||
@[builtin_macro Lean.Parser.Term.structInst] def expandStructInstFieldAbbrev : Macro
|
||||
| `({ $[$srcs,* with]? $fields,* $[..%$ell]? $[: $ty]? }) =>
|
||||
if fields.getElems.raw.any (·.getKind == ``Lean.Parser.Term.structInstFieldAbbrev) then do
|
||||
@@ -49,9 +71,12 @@ open TSyntax.Compat
|
||||
| _ => Macro.throwUnsupported
|
||||
|
||||
/--
|
||||
If `stx` is of the form `{ s₁, ..., sₙ with ... }` and `sᵢ` is not a local variable, expand into `let src := sᵢ; { ..., src, ... with ... }`.
|
||||
If `stx` is of the form `{ s₁, ..., sₙ with ... }` and `sᵢ` is not a local variable,
|
||||
expands into `let __src := sᵢ; { ..., __src, ... with ... }`.
|
||||
The significance of `__src` is that the variable is treated as an implementation-detail local variable,
|
||||
which can be unfolded by `simp` when `zetaDelta := false`.
|
||||
|
||||
Note that this one is not a `Macro` because we need to access the local context.
|
||||
Note that this one is not a `Macro` because we need to access the local context.
|
||||
-/
|
||||
private def expandNonAtomicExplicitSources (stx : Syntax) : TermElabM (Option Syntax) := do
|
||||
let sourcesOpt := stx[1]
|
||||
@@ -100,27 +125,44 @@ where
|
||||
let r ← go sources (sourcesNew.push sourceNew)
|
||||
`(let __src := $source; $r)
|
||||
|
||||
structure ExplicitSourceInfo where
|
||||
/--
|
||||
An *explicit source* is one of the structures `sᵢ` that appear in `{ s₁, …, sₙ with … }`.
|
||||
-/
|
||||
structure ExplicitSourceView where
|
||||
/-- The syntax of the explicit source. -/
|
||||
stx : Syntax
|
||||
/-- The name of the structure for the type of the explicit source. -/
|
||||
structName : Name
|
||||
deriving Inhabited
|
||||
|
||||
structure Source where
|
||||
explicit : Array ExplicitSourceInfo -- `s₁ ... sₙ with`
|
||||
implicit : Option Syntax -- `..`
|
||||
/--
|
||||
A view of the sources of fields for the structure instance notation.
|
||||
-/
|
||||
structure SourcesView where
|
||||
/-- Explicit sources (i.e., one of the structures `sᵢ` that appear in `{ s₁, …, sₙ with … }`). -/
|
||||
explicit : Array ExplicitSourceView
|
||||
/-- The syntax for a trailing `..`. This is "ellipsis mode" for missing fields, similar to ellipsis mode for applications. -/
|
||||
implicit : Option Syntax
|
||||
deriving Inhabited
|
||||
|
||||
def Source.isNone : Source → Bool
|
||||
/-- Returns `true` if the structure instance has no sources (neither explicit sources nor a `..`). -/
|
||||
def SourcesView.isNone : SourcesView → Bool
|
||||
| { explicit := #[], implicit := none } => true
|
||||
| _ => false
|
||||
|
||||
/-- `optional (atomic (sepBy1 termParser ", " >> " with ")` -/
|
||||
/--
|
||||
Given an array of explicit sources, returns syntax of the form
|
||||
`optional (atomic (sepBy1 termParser ", " >> " with ")`
|
||||
-/
|
||||
private def mkSourcesWithSyntax (sources : Array Syntax) : Syntax :=
|
||||
let ref := sources[0]!
|
||||
let stx := Syntax.mkSep sources (mkAtomFrom ref ", ")
|
||||
mkNullNode #[stx, mkAtomFrom ref "with "]
|
||||
|
||||
private def getStructSource (structStx : Syntax) : TermElabM Source :=
|
||||
/--
|
||||
Creates a structure source view from structure instance notation.
|
||||
-/
|
||||
private def getStructSources (structStx : Syntax) : TermElabM SourcesView :=
|
||||
withRef structStx do
|
||||
let explicitSource := structStx[1]
|
||||
let implicitSource := structStx[3]
|
||||
@@ -138,13 +180,13 @@ private def getStructSource (structStx : Syntax) : TermElabM Source :=
|
||||
return { explicit, implicit }
|
||||
|
||||
/--
|
||||
We say a `{ ... }` notation is a `modifyOp` if it contains only one
|
||||
```
|
||||
def structInstArrayRef := leading_parser "[" >> termParser >>"]"
|
||||
```
|
||||
We say a structure instance notation is a "modifyOp" if it contains only a single array update.
|
||||
```lean
|
||||
def structInstArrayRef := leading_parser "[" >> termParser >>"]"
|
||||
```
|
||||
-/
|
||||
private def isModifyOp? (stx : Syntax) : TermElabM (Option Syntax) := do
|
||||
let s? ← stx[2].getSepArgs.foldlM (init := none) fun s? arg => do
|
||||
let s? ← stx[2][0].getSepArgs.foldlM (init := none) fun s? arg => do
|
||||
/- arg is of the form `structInstFieldAbbrev <|> structInstField` -/
|
||||
if arg.getKind == ``Lean.Parser.Term.structInstField then
|
||||
/- Remark: the syntax for `structInstField` is
|
||||
@@ -177,7 +219,11 @@ private def isModifyOp? (stx : Syntax) : TermElabM (Option Syntax) := do
|
||||
| none => return none
|
||||
| some s => if s[0][0].getKind == ``Lean.Parser.Term.structInstArrayRef then return s? else return none
|
||||
|
||||
private def elabModifyOp (stx modifyOp : Syntax) (sources : Array ExplicitSourceInfo) (expectedType? : Option Expr) : TermElabM Expr := do
|
||||
/--
|
||||
Given a `stx` that is a structure instance notation that's a modifyOp (according to `isModifyOp?`), elaborates it.
|
||||
Only supports structure instances with a single source.
|
||||
-/
|
||||
private def elabModifyOp (stx modifyOp : Syntax) (sources : Array ExplicitSourceView) (expectedType? : Option Expr) : TermElabM Expr := do
|
||||
if sources.size > 1 then
|
||||
throwError "invalid \{...} notation, multiple sources and array update is not supported."
|
||||
let cont (val : Syntax) : TermElabM Expr := do
|
||||
@@ -199,17 +245,18 @@ private def elabModifyOp (stx modifyOp : Syntax) (sources : Array ExplicitSource
|
||||
let valField := modifyOp.setArg 0 <| mkNode ``Parser.Term.structInstLVal #[valFirst, valRest]
|
||||
let valSource := mkSourcesWithSyntax #[s]
|
||||
let val := stx.setArg 1 valSource
|
||||
let val := val.setArg 2 <| mkNullNode #[valField]
|
||||
let val := val.setArg 2 <| mkNode ``Parser.Term.structInstFields #[mkNullNode #[valField]]
|
||||
trace[Elab.struct.modifyOp] "{stx}\nval: {val}"
|
||||
cont val
|
||||
|
||||
/--
|
||||
Get structure name.
|
||||
This method triest to postpone execution if the expected type is not available.
|
||||
Gets the structure name for the structure instance from the expected type and the sources.
|
||||
This method tries to postpone execution if the expected type is not available.
|
||||
|
||||
If the expected type is available and it is a structure, then we use it.
|
||||
Otherwise, we use the type of the first source. -/
|
||||
private def getStructName (expectedType? : Option Expr) (sourceView : Source) : TermElabM Name := do
|
||||
If the expected type is available and it is a structure, then we use it.
|
||||
Otherwise, we use the type of the first source.
|
||||
-/
|
||||
private def getStructName (expectedType? : Option Expr) (sourceView : SourcesView) : TermElabM Name := do
|
||||
tryPostponeIfNoneOrMVar expectedType?
|
||||
let useSource : Unit → TermElabM Name := fun _ => do
|
||||
unless sourceView.explicit.isEmpty do
|
||||
@@ -226,7 +273,7 @@ private def getStructName (expectedType? : Option Expr) (sourceView : Source) :
|
||||
unless isStructure (← getEnv) constName do
|
||||
throwError "invalid \{...} notation, structure type expected{indentExpr expectedType}"
|
||||
return constName
|
||||
| _ => useSource ()
|
||||
| _ => useSource ()
|
||||
where
|
||||
throwUnknownExpectedType :=
|
||||
throwError "invalid \{...} notation, expected type is not known"
|
||||
@@ -237,72 +284,92 @@ where
|
||||
else
|
||||
throwError "invalid \{...} notation, {kind} type is not of the form (C ...){indentExpr type}"
|
||||
|
||||
/--
|
||||
A component of a left-hand side for a field appearing in structure instance syntax.
|
||||
-/
|
||||
inductive FieldLHS where
|
||||
/-- A name component for a field left-hand side. For example, `x` and `y` in `{ x.y := v }`. -/
|
||||
| fieldName (ref : Syntax) (name : Name)
|
||||
/-- A numeric index component for a field left-hand side. For example `3` in `{ x.3 := v }`. -/
|
||||
| fieldIndex (ref : Syntax) (idx : Nat)
|
||||
/-- An array indexing component for a field left-hand side. For example `[3]` in `{ arr[3] := v }`. -/
|
||||
| modifyOp (ref : Syntax) (index : Syntax)
|
||||
deriving Inhabited
|
||||
|
||||
instance : ToFormat FieldLHS := ⟨fun lhs =>
|
||||
match lhs with
|
||||
| .fieldName _ n => format n
|
||||
| .fieldIndex _ i => format i
|
||||
| .modifyOp _ i => "[" ++ i.prettyPrint ++ "]"⟩
|
||||
instance : ToFormat FieldLHS where
|
||||
format
|
||||
| .fieldName _ n => format n
|
||||
| .fieldIndex _ i => format i
|
||||
| .modifyOp _ i => "[" ++ i.prettyPrint ++ "]"
|
||||
|
||||
/--
|
||||
`FieldVal StructInstView` is a representation of a field value in the structure instance.
|
||||
-/
|
||||
inductive FieldVal (σ : Type) where
|
||||
| term (stx : Syntax) : FieldVal σ
|
||||
/-- A `term` to use for the value of the field. -/
|
||||
| term (stx : Syntax) : FieldVal σ
|
||||
/-- A `StructInstView` to use for the value of a subobject field. -/
|
||||
| nested (s : σ) : FieldVal σ
|
||||
| default : FieldVal σ -- mark that field must be synthesized using default value
|
||||
/-- A field that was not provided and should be synthesized using default values. -/
|
||||
| default : FieldVal σ
|
||||
deriving Inhabited
|
||||
|
||||
/--
|
||||
`Field StructInstView` is a representation of a field in the structure instance.
|
||||
-/
|
||||
structure Field (σ : Type) where
|
||||
/-- The whole field syntax. -/
|
||||
ref : Syntax
|
||||
/-- The LHS decomposed into components. -/
|
||||
lhs : List FieldLHS
|
||||
/-- The value of the field. -/
|
||||
val : FieldVal σ
|
||||
/-- The elaborated field value, filled in at `elabStruct`.
|
||||
Missing fields use a metavariable for the elaborated value and are later solved for in `DefaultFields.propagate`. -/
|
||||
expr? : Option Expr := none
|
||||
deriving Inhabited
|
||||
|
||||
/--
|
||||
Returns if the field has a single component in its LHS.
|
||||
-/
|
||||
def Field.isSimple {σ} : Field σ → Bool
|
||||
| { lhs := [_], .. } => true
|
||||
| _ => false
|
||||
|
||||
inductive Struct where
|
||||
/-- Remark: the field `params` is use for default value propagation. It is initially empty, and then set at `elabStruct`. -/
|
||||
| mk (ref : Syntax) (structName : Name) (params : Array (Name × Expr)) (fields : List (Field Struct)) (source : Source)
|
||||
/--
|
||||
The view for structure instance notation.
|
||||
-/
|
||||
structure StructInstView where
|
||||
/-- The syntax for the whole structure instance. -/
|
||||
ref : Syntax
|
||||
/-- The name of the structure for the type of the structure instance. -/
|
||||
structName : Name
|
||||
/-- Used for default values, to propagate structure type parameters. It is initially empty, and then set at `elabStruct`. -/
|
||||
params : Array (Name × Expr)
|
||||
/-- The fields of the structure instance. -/
|
||||
fields : List (Field StructInstView)
|
||||
/-- The additional sources for fields for the structure instance. -/
|
||||
sources : SourcesView
|
||||
deriving Inhabited
|
||||
|
||||
abbrev Fields := List (Field Struct)
|
||||
|
||||
def Struct.ref : Struct → Syntax
|
||||
| ⟨ref, _, _, _, _⟩ => ref
|
||||
|
||||
def Struct.structName : Struct → Name
|
||||
| ⟨_, structName, _, _, _⟩ => structName
|
||||
|
||||
def Struct.params : Struct → Array (Name × Expr)
|
||||
| ⟨_, _, params, _, _⟩ => params
|
||||
|
||||
def Struct.fields : Struct → Fields
|
||||
| ⟨_, _, _, fields, _⟩ => fields
|
||||
|
||||
def Struct.source : Struct → Source
|
||||
| ⟨_, _, _, _, s⟩ => s
|
||||
/-- Abbreviation for the type of `StructInstView.fields`, namely `List (Field StructInstView)`. -/
|
||||
abbrev Fields := List (Field StructInstView)
|
||||
|
||||
/-- `true` iff all fields of the given structure are marked as `default` -/
|
||||
partial def Struct.allDefault (s : Struct) : Bool :=
|
||||
partial def StructInstView.allDefault (s : StructInstView) : Bool :=
|
||||
s.fields.all fun { val := val, .. } => match val with
|
||||
| .term _ => false
|
||||
| .default => true
|
||||
| .nested s => allDefault s
|
||||
|
||||
def formatField (formatStruct : Struct → Format) (field : Field Struct) : Format :=
|
||||
def formatField (formatStruct : StructInstView → Format) (field : Field StructInstView) : Format :=
|
||||
Format.joinSep field.lhs " . " ++ " := " ++
|
||||
match field.val with
|
||||
| .term v => v.prettyPrint
|
||||
| .nested s => formatStruct s
|
||||
| .default => "<default>"
|
||||
|
||||
partial def formatStruct : Struct → Format
|
||||
partial def formatStruct : StructInstView → Format
|
||||
| ⟨_, _, _, fields, source⟩ =>
|
||||
let fieldsFmt := Format.joinSep (fields.map (formatField formatStruct)) ", "
|
||||
let implicitFmt := if source.implicit.isSome then " .. " else ""
|
||||
@@ -311,31 +378,39 @@ partial def formatStruct : Struct → Format
|
||||
else
|
||||
"{" ++ format (source.explicit.map (·.stx)) ++ " with " ++ fieldsFmt ++ implicitFmt ++ "}"
|
||||
|
||||
instance : ToFormat Struct := ⟨formatStruct⟩
|
||||
instance : ToString Struct := ⟨toString ∘ format⟩
|
||||
instance : ToFormat StructInstView := ⟨formatStruct⟩
|
||||
instance : ToString StructInstView := ⟨toString ∘ format⟩
|
||||
|
||||
instance : ToFormat (Field Struct) := ⟨formatField formatStruct⟩
|
||||
instance : ToString (Field Struct) := ⟨toString ∘ format⟩
|
||||
instance : ToFormat (Field StructInstView) := ⟨formatField formatStruct⟩
|
||||
instance : ToString (Field StructInstView) := ⟨toString ∘ format⟩
|
||||
|
||||
/--
|
||||
Converts a `FieldLHS` back into syntax. This assumes the `ref` fields have the correct structure.
|
||||
|
||||
/-
|
||||
Recall that `structInstField` elements have the form
|
||||
```
|
||||
def structInstField := leading_parser structInstLVal >> " := " >> termParser
|
||||
def structInstLVal := leading_parser (ident <|> numLit <|> structInstArrayRef) >> many (("." >> (ident <|> numLit)) <|> structInstArrayRef)
|
||||
def structInstArrayRef := leading_parser "[" >> termParser >>"]"
|
||||
```lean
|
||||
def structInstField := leading_parser structInstLVal >> " := " >> termParser
|
||||
def structInstLVal := leading_parser (ident <|> numLit <|> structInstArrayRef) >> many (("." >> (ident <|> numLit)) <|> structInstArrayRef)
|
||||
def structInstArrayRef := leading_parser "[" >> termParser >>"]"
|
||||
```
|
||||
-/
|
||||
-- Remark: this code relies on the fact that `expandStruct` only transforms `fieldLHS.fieldName`
|
||||
def FieldLHS.toSyntax (first : Bool) : FieldLHS → Syntax
|
||||
private def FieldLHS.toSyntax (first : Bool) : FieldLHS → Syntax
|
||||
| .modifyOp stx _ => stx
|
||||
| .fieldName stx name => if first then mkIdentFrom stx name else mkGroupNode #[mkAtomFrom stx ".", mkIdentFrom stx name]
|
||||
| .fieldIndex stx _ => if first then stx else mkGroupNode #[mkAtomFrom stx ".", stx]
|
||||
|
||||
def FieldVal.toSyntax : FieldVal Struct → Syntax
|
||||
/--
|
||||
Converts a `FieldVal StructInstView` back into syntax. Only supports `.term`, and it assumes the `stx` field has the correct structure.
|
||||
-/
|
||||
private def FieldVal.toSyntax : FieldVal Struct → Syntax
|
||||
| .term stx => stx
|
||||
| _ => unreachable!
|
||||
| _ => unreachable!
|
||||
|
||||
def Field.toSyntax : Field Struct → Syntax
|
||||
/--
|
||||
Converts a `Field StructInstView` back into syntax. Used to construct synthetic structure instance notation for subobjects in `StructInst.expandStruct` processing.
|
||||
-/
|
||||
private def Field.toSyntax : Field Struct → Syntax
|
||||
| field =>
|
||||
let stx := field.ref
|
||||
let stx := stx.setArg 2 field.val.toSyntax
|
||||
@@ -343,6 +418,7 @@ def Field.toSyntax : Field Struct → Syntax
|
||||
| first::rest => stx.setArg 0 <| mkNullNode #[first.toSyntax true, mkNullNode <| rest.toArray.map (FieldLHS.toSyntax false) ]
|
||||
| _ => unreachable!
|
||||
|
||||
/-- Creates a view of a field left-hand side. -/
|
||||
private def toFieldLHS (stx : Syntax) : MacroM FieldLHS :=
|
||||
if stx.getKind == ``Lean.Parser.Term.structInstArrayRef then
|
||||
return FieldLHS.modifyOp stx stx[1]
|
||||
@@ -355,11 +431,16 @@ private def toFieldLHS (stx : Syntax) : MacroM FieldLHS :=
|
||||
| some idx => return FieldLHS.fieldIndex stx idx
|
||||
| none => Macro.throwError "unexpected structure syntax"
|
||||
|
||||
private def mkStructView (stx : Syntax) (structName : Name) (source : Source) : MacroM Struct := do
|
||||
/--
|
||||
Creates a structure instance view from structure instance notation
|
||||
and the computed structure name (from `Lean.Elab.Term.StructInst.getStructName`)
|
||||
and structure source view (from `Lean.Elab.Term.StructInst.getStructSources`).
|
||||
-/
|
||||
private def mkStructView (stx : Syntax) (structName : Name) (sources : SourcesView) : MacroM StructInstView := do
|
||||
/- Recall that `stx` is of the form
|
||||
```
|
||||
leading_parser "{" >> optional (atomic (sepBy1 termParser ", " >> " with "))
|
||||
>> sepByIndent (structInstFieldAbbrev <|> structInstField) ...
|
||||
>> structInstFields (sepByIndent (structInstFieldAbbrev <|> structInstField) ...)
|
||||
>> optional ".."
|
||||
>> optional (" : " >> termParser)
|
||||
>> " }"
|
||||
@@ -367,28 +448,22 @@ private def mkStructView (stx : Syntax) (structName : Name) (source : Source) :
|
||||
|
||||
This method assumes that `structInstFieldAbbrev` had already been expanded.
|
||||
-/
|
||||
let fields ← stx[2].getSepArgs.toList.mapM fun fieldStx => do
|
||||
let fields ← stx[2][0].getSepArgs.toList.mapM fun fieldStx => do
|
||||
let val := fieldStx[2]
|
||||
let first ← toFieldLHS fieldStx[0][0]
|
||||
let rest ← fieldStx[0][1].getArgs.toList.mapM toFieldLHS
|
||||
return { ref := fieldStx, lhs := first :: rest, val := FieldVal.term val : Field Struct }
|
||||
return ⟨stx, structName, #[], fields, source⟩
|
||||
return { ref := fieldStx, lhs := first :: rest, val := FieldVal.term val : Field StructInstView }
|
||||
return { ref := stx, structName, params := #[], fields, sources }
|
||||
|
||||
def Struct.modifyFieldsM {m : Type → Type} [Monad m] (s : Struct) (f : Fields → m Fields) : m Struct :=
|
||||
def StructInstView.modifyFieldsM {m : Type → Type} [Monad m] (s : StructInstView) (f : Fields → m Fields) : m StructInstView :=
|
||||
match s with
|
||||
| ⟨ref, structName, params, fields, source⟩ => return ⟨ref, structName, params, (← f fields), source⟩
|
||||
| { ref, structName, params, fields, sources } => return { ref, structName, params, fields := (← f fields), sources }
|
||||
|
||||
def Struct.modifyFields (s : Struct) (f : Fields → Fields) : Struct :=
|
||||
def StructInstView.modifyFields (s : StructInstView) (f : Fields → Fields) : StructInstView :=
|
||||
Id.run <| s.modifyFieldsM f
|
||||
|
||||
def Struct.setFields (s : Struct) (fields : Fields) : Struct :=
|
||||
s.modifyFields fun _ => fields
|
||||
|
||||
def Struct.setParams (s : Struct) (ps : Array (Name × Expr)) : Struct :=
|
||||
match s with
|
||||
| ⟨ref, structName, _, fields, source⟩ => ⟨ref, structName, ps, fields, source⟩
|
||||
|
||||
private def expandCompositeFields (s : Struct) : Struct :=
|
||||
/-- Expands name field LHSs with multi-component names into multi-component LHSs. -/
|
||||
private def expandCompositeFields (s : StructInstView) : StructInstView :=
|
||||
s.modifyFields fun fields => fields.map fun field => match field with
|
||||
| { lhs := .fieldName _ (.str Name.anonymous ..) :: _, .. } => field
|
||||
| { lhs := .fieldName ref n@(.str ..) :: rest, .. } =>
|
||||
@@ -396,7 +471,8 @@ private def expandCompositeFields (s : Struct) : Struct :=
|
||||
{ field with lhs := newEntries ++ rest }
|
||||
| _ => field
|
||||
|
||||
private def expandNumLitFields (s : Struct) : TermElabM Struct :=
|
||||
/-- Replaces numeric index field LHSs with the corresponding named field, or throws an error if no such field exists. -/
|
||||
private def expandNumLitFields (s : StructInstView) : TermElabM StructInstView :=
|
||||
s.modifyFieldsM fun fields => do
|
||||
let env ← getEnv
|
||||
let fieldNames := getStructureFields env s.structName
|
||||
@@ -407,28 +483,31 @@ private def expandNumLitFields (s : Struct) : TermElabM Struct :=
|
||||
else return { field with lhs := .fieldName ref fieldNames[idx - 1]! :: rest }
|
||||
| _ => return field
|
||||
|
||||
/-- For example, consider the following structures:
|
||||
```
|
||||
structure A where
|
||||
x : Nat
|
||||
/--
|
||||
Expands fields that are actually represented as fields of subobject fields.
|
||||
|
||||
structure B extends A where
|
||||
y : Nat
|
||||
For example, consider the following structures:
|
||||
```
|
||||
structure A where
|
||||
x : Nat
|
||||
|
||||
structure C extends B where
|
||||
z : Bool
|
||||
```
|
||||
This method expands parent structure fields using the path to the parent structure.
|
||||
For example,
|
||||
```
|
||||
{ x := 0, y := 0, z := true : C }
|
||||
```
|
||||
is expanded into
|
||||
```
|
||||
{ toB.toA.x := 0, toB.y := 0, z := true : C }
|
||||
```
|
||||
structure B extends A where
|
||||
y : Nat
|
||||
|
||||
structure C extends B where
|
||||
z : Bool
|
||||
```
|
||||
This method expands parent structure fields using the path to the parent structure.
|
||||
For example,
|
||||
```
|
||||
{ x := 0, y := 0, z := true : C }
|
||||
```
|
||||
is expanded into
|
||||
```
|
||||
{ toB.toA.x := 0, toB.y := 0, z := true : C }
|
||||
```
|
||||
-/
|
||||
private def expandParentFields (s : Struct) : TermElabM Struct := do
|
||||
private def expandParentFields (s : StructInstView) : TermElabM StructInstView := do
|
||||
let env ← getEnv
|
||||
s.modifyFieldsM fun fields => fields.mapM fun field => do match field with
|
||||
| { lhs := .fieldName ref fieldName :: _, .. } =>
|
||||
@@ -448,6 +527,11 @@ private def expandParentFields (s : Struct) : TermElabM Struct := do
|
||||
|
||||
private abbrev FieldMap := Std.HashMap Name Fields
|
||||
|
||||
/--
|
||||
Creates a hash map collecting all fields with the same first name component.
|
||||
Throws an error if there are multiple simple fields with the same name.
|
||||
Used by `StructInst.expandStruct` processing.
|
||||
-/
|
||||
private def mkFieldMap (fields : Fields) : TermElabM FieldMap :=
|
||||
fields.foldlM (init := {}) fun fieldMap field =>
|
||||
match field.lhs with
|
||||
@@ -461,15 +545,16 @@ private def mkFieldMap (fields : Fields) : TermElabM FieldMap :=
|
||||
| _ => return fieldMap.insert fieldName [field]
|
||||
| _ => unreachable!
|
||||
|
||||
private def isSimpleField? : Fields → Option (Field Struct)
|
||||
/--
|
||||
Given a value of the hash map created by `mkFieldMap`, returns true if the value corresponds to a simple field.
|
||||
-/
|
||||
private def isSimpleField? : Fields → Option (Field StructInstView)
|
||||
| [field] => if field.isSimple then some field else none
|
||||
| _ => none
|
||||
|
||||
private def getFieldIdx (structName : Name) (fieldNames : Array Name) (fieldName : Name) : TermElabM Nat := do
|
||||
match fieldNames.findIdx? fun n => n == fieldName with
|
||||
| some idx => return idx
|
||||
| none => throwError "field '{fieldName}' is not a valid field of '{structName}'"
|
||||
|
||||
/--
|
||||
Creates projection notation for the given structure field. Used
|
||||
-/
|
||||
def mkProjStx? (s : Syntax) (structName : Name) (fieldName : Name) : TermElabM (Option Syntax) := do
|
||||
if (findField? (← getEnv) structName fieldName).isNone then
|
||||
return none
|
||||
@@ -478,7 +563,10 @@ def mkProjStx? (s : Syntax) (structName : Name) (fieldName : Name) : TermElabM (
|
||||
#[mkAtomFrom s "@",
|
||||
mkNode ``Parser.Term.proj #[s, mkAtomFrom s ".", mkIdentFrom s fieldName]]
|
||||
|
||||
def findField? (fields : Fields) (fieldName : Name) : Option (Field Struct) :=
|
||||
/--
|
||||
Finds a simple field of the given name.
|
||||
-/
|
||||
def findField? (fields : Fields) (fieldName : Name) : Option (Field StructInstView) :=
|
||||
fields.find? fun field =>
|
||||
match field.lhs with
|
||||
| [.fieldName _ n] => n == fieldName
|
||||
@@ -486,7 +574,10 @@ def findField? (fields : Fields) (fieldName : Name) : Option (Field Struct) :=
|
||||
|
||||
mutual
|
||||
|
||||
private partial def groupFields (s : Struct) : TermElabM Struct := do
|
||||
/--
|
||||
Groups compound fields according to which subobject they are from.
|
||||
-/
|
||||
private partial def groupFields (s : StructInstView) : TermElabM StructInstView := do
|
||||
let env ← getEnv
|
||||
withRef s.ref do
|
||||
s.modifyFieldsM fun fields => do
|
||||
@@ -499,26 +590,28 @@ mutual
|
||||
let field := fields.head!
|
||||
match Lean.isSubobjectField? env s.structName fieldName with
|
||||
| some substructName =>
|
||||
let substruct := Struct.mk s.ref substructName #[] substructFields s.source
|
||||
let substruct := { ref := s.ref, structName := substructName, params := #[], fields := substructFields, sources := s.sources }
|
||||
let substruct ← expandStruct substruct
|
||||
pure { field with lhs := [field.lhs.head!], val := FieldVal.nested substruct }
|
||||
| none =>
|
||||
let updateSource (structStx : Syntax) : TermElabM Syntax := do
|
||||
let sourcesNew ← s.source.explicit.filterMapM fun source => mkProjStx? source.stx source.structName fieldName
|
||||
let sourcesNew ← s.sources.explicit.filterMapM fun source => mkProjStx? source.stx source.structName fieldName
|
||||
let explicitSourceStx := if sourcesNew.isEmpty then mkNullNode else mkSourcesWithSyntax sourcesNew
|
||||
let implicitSourceStx := s.source.implicit.getD mkNullNode
|
||||
let implicitSourceStx := s.sources.implicit.getD mkNullNode
|
||||
return (structStx.setArg 1 explicitSourceStx).setArg 3 implicitSourceStx
|
||||
let valStx := s.ref -- construct substructure syntax using s.ref as template
|
||||
let valStx := valStx.setArg 4 mkNullNode -- erase optional expected type
|
||||
let args := substructFields.toArray.map (·.toSyntax)
|
||||
let valStx := valStx.setArg 2 (mkNullNode <| mkSepArray args (mkAtom ","))
|
||||
let fieldsStx := mkNode ``Parser.Term.structInstFields
|
||||
#[mkNullNode <| mkSepArray args (mkAtom ",")]
|
||||
let valStx := valStx.setArg 2 fieldsStx
|
||||
let valStx ← updateSource valStx
|
||||
return { field with lhs := [field.lhs.head!], val := FieldVal.term valStx }
|
||||
/--
|
||||
Adds in the missing fields using the explicit sources.
|
||||
Invariant: a missing field always comes from the first source that can provide it.
|
||||
-/
|
||||
private partial def addMissingFields (s : Struct) : TermElabM Struct := do
|
||||
private partial def addMissingFields (s : StructInstView) : TermElabM StructInstView := do
|
||||
let env ← getEnv
|
||||
let fieldNames := getStructureFields env s.structName
|
||||
let ref := s.ref.mkSynthetic
|
||||
@@ -527,7 +620,7 @@ mutual
|
||||
match findField? s.fields fieldName with
|
||||
| some field => return field::fields
|
||||
| none =>
|
||||
let addField (val : FieldVal Struct) : TermElabM Fields := do
|
||||
let addField (val : FieldVal StructInstView) : TermElabM Fields := do
|
||||
return { ref, lhs := [FieldLHS.fieldName ref fieldName], val := val } :: fields
|
||||
match Lean.isSubobjectField? env s.structName fieldName with
|
||||
| some substructName =>
|
||||
@@ -535,8 +628,8 @@ mutual
|
||||
let downFields := getStructureFieldsFlattened env substructName false
|
||||
-- Filter out all explicit sources that do not share a leaf field keeping
|
||||
-- structure with no fields
|
||||
let filtered := s.source.explicit.filter fun source =>
|
||||
let sourceFields := getStructureFieldsFlattened env source.structName false
|
||||
let filtered := s.sources.explicit.filter fun sources =>
|
||||
let sourceFields := getStructureFieldsFlattened env sources.structName false
|
||||
sourceFields.any (fun name => downFields.contains name) || sourceFields.isEmpty
|
||||
-- Take the first such one remaining
|
||||
match filtered[0]? with
|
||||
@@ -550,27 +643,30 @@ mutual
|
||||
-- No sources could provide this subobject in the proper order.
|
||||
-- Recurse to handle default values for fields.
|
||||
else
|
||||
let substruct := Struct.mk ref substructName #[] [] s.source
|
||||
let substruct := { ref, structName := substructName, params := #[], fields := [], sources := s.sources }
|
||||
let substruct ← expandStruct substruct
|
||||
addField (FieldVal.nested substruct)
|
||||
-- No sources could provide this subobject.
|
||||
-- Recurse to handle default values for fields.
|
||||
| none =>
|
||||
let substruct := Struct.mk ref substructName #[] [] s.source
|
||||
let substruct := { ref, structName := substructName, params := #[], fields := [], sources := s.sources }
|
||||
let substruct ← expandStruct substruct
|
||||
addField (FieldVal.nested substruct)
|
||||
-- Since this is not a subobject field, we are free to use the first source that can
|
||||
-- provide it.
|
||||
| none =>
|
||||
if let some val ← s.source.explicit.findSomeM? fun source => mkProjStx? source.stx source.structName fieldName then
|
||||
if let some val ← s.sources.explicit.findSomeM? fun source => mkProjStx? source.stx source.structName fieldName then
|
||||
addField (FieldVal.term val)
|
||||
else if s.source.implicit.isSome then
|
||||
else if s.sources.implicit.isSome then
|
||||
addField (FieldVal.term (mkHole ref))
|
||||
else
|
||||
addField FieldVal.default
|
||||
return s.setFields fields.reverse
|
||||
return { s with fields := fields.reverse }
|
||||
|
||||
private partial def expandStruct (s : Struct) : TermElabM Struct := do
|
||||
/--
|
||||
Expands all fields of the structure instance, consolidates compound fields into subobject fields, and adds missing fields.
|
||||
-/
|
||||
private partial def expandStruct (s : StructInstView) : TermElabM StructInstView := do
|
||||
let s := expandCompositeFields s
|
||||
let s ← expandNumLitFields s
|
||||
let s ← expandParentFields s
|
||||
@@ -579,10 +675,17 @@ mutual
|
||||
|
||||
end
|
||||
|
||||
/--
|
||||
The constructor to use for the structure instance notation.
|
||||
-/
|
||||
structure CtorHeaderResult where
|
||||
/-- The constructor function with applied structure parameters. -/
|
||||
ctorFn : Expr
|
||||
/-- The type of `ctorFn` -/
|
||||
ctorFnType : Expr
|
||||
/-- Instance metavariables for structure parameters that are instance implicit. -/
|
||||
instMVars : Array MVarId
|
||||
/-- Type parameter names and metavariables for each parameter. Used to seed `StructInstView.params`. -/
|
||||
params : Array (Name × Expr)
|
||||
|
||||
private def mkCtorHeaderAux : Nat → Expr → Expr → Array MVarId → Array (Name × Expr) → TermElabM CtorHeaderResult
|
||||
@@ -604,6 +707,7 @@ private partial def getForallBody : Nat → Expr → Option Expr
|
||||
| _+1, _ => none
|
||||
| 0, type => type
|
||||
|
||||
/-- Attempts to use the expected type to solve for structure parameters. -/
|
||||
private def propagateExpectedType (type : Expr) (numFields : Nat) (expectedType? : Option Expr) : TermElabM Unit := do
|
||||
match expectedType? with
|
||||
| none => return ()
|
||||
@@ -614,6 +718,7 @@ private def propagateExpectedType (type : Expr) (numFields : Nat) (expectedType?
|
||||
unless typeBody.hasLooseBVars do
|
||||
discard <| isDefEq expectedType typeBody
|
||||
|
||||
/-- Elaborates the structure constructor using the expected type, filling in all structure parameters. -/
|
||||
private def mkCtorHeader (ctorVal : ConstructorVal) (expectedType? : Option Expr) : TermElabM CtorHeaderResult := do
|
||||
let us ← mkFreshLevelMVars ctorVal.levelParams.length
|
||||
let val := Lean.mkConst ctorVal.name us
|
||||
@@ -623,32 +728,43 @@ private def mkCtorHeader (ctorVal : ConstructorVal) (expectedType? : Option Expr
|
||||
synthesizeAppInstMVars r.instMVars r.ctorFn
|
||||
return r
|
||||
|
||||
/-- Annotates an expression that it is a value for a missing field. -/
|
||||
def markDefaultMissing (e : Expr) : Expr :=
|
||||
mkAnnotation `structInstDefault e
|
||||
|
||||
/-- If the expression has been annotated by `markDefaultMissing`, returns the unannotated expression. -/
|
||||
def defaultMissing? (e : Expr) : Option Expr :=
|
||||
annotation? `structInstDefault e
|
||||
|
||||
/-- Throws "failed to elaborate field" error. -/
|
||||
def throwFailedToElabField {α} (fieldName : Name) (structName : Name) (msgData : MessageData) : TermElabM α :=
|
||||
throwError "failed to elaborate field '{fieldName}' of '{structName}, {msgData}"
|
||||
|
||||
def trySynthStructInstance? (s : Struct) (expectedType : Expr) : TermElabM (Option Expr) := do
|
||||
/-- If the struct has all-missing fields, tries to synthesize the structure using typeclass inference. -/
|
||||
def trySynthStructInstance? (s : StructInstView) (expectedType : Expr) : TermElabM (Option Expr) := do
|
||||
if !s.allDefault then
|
||||
return none
|
||||
else
|
||||
try synthInstance? expectedType catch _ => return none
|
||||
|
||||
/-- The result of elaborating a `StructInstView` structure instance view. -/
|
||||
structure ElabStructResult where
|
||||
/-- The elaborated value. -/
|
||||
val : Expr
|
||||
struct : Struct
|
||||
/-- The modified `StructInstView` view after elaboration. -/
|
||||
struct : StructInstView
|
||||
/-- Metavariables for instance implicit fields. These will be registered after default value propagation. -/
|
||||
instMVars : Array MVarId
|
||||
|
||||
private partial def elabStruct (s : Struct) (expectedType? : Option Expr) : TermElabM ElabStructResult := withRef s.ref do
|
||||
/--
|
||||
Main elaborator for structure instances.
|
||||
-/
|
||||
private partial def elabStructInstView (s : StructInstView) (expectedType? : Option Expr) : TermElabM ElabStructResult := withRef s.ref do
|
||||
let env ← getEnv
|
||||
let ctorVal := getStructureCtor env s.structName
|
||||
if isPrivateNameFromImportedModule env ctorVal.name then
|
||||
throwError "invalid \{...} notation, constructor for `{s.structName}` is marked as private"
|
||||
-- We store the parameters at the resulting `Struct`. We use this information during default value propagation.
|
||||
-- We store the parameters at the resulting `StructInstView`. We use this information during default value propagation.
|
||||
let { ctorFn, ctorFnType, params, .. } ← mkCtorHeader ctorVal expectedType?
|
||||
let (e, _, fields, instMVars) ← s.fields.foldlM (init := (ctorFn, ctorFnType, [], #[])) fun (e, type, fields, instMVars) field => do
|
||||
match field.lhs with
|
||||
@@ -657,7 +773,7 @@ private partial def elabStruct (s : Struct) (expectedType? : Option Expr) : Term
|
||||
trace[Elab.struct] "elabStruct {field}, {type}"
|
||||
match type with
|
||||
| .forallE _ d b bi =>
|
||||
let cont (val : Expr) (field : Field Struct) (instMVars := instMVars) : TermElabM (Expr × Expr × Fields × Array MVarId) := do
|
||||
let cont (val : Expr) (field : Field StructInstView) (instMVars := instMVars) : TermElabM (Expr × Expr × Fields × Array MVarId) := do
|
||||
pushInfoTree <| InfoTree.node (children := {}) <| Info.ofFieldInfo {
|
||||
projName := s.structName.append fieldName, fieldName, lctx := (← getLCtx), val, stx := ref }
|
||||
let e := mkApp e val
|
||||
@@ -671,7 +787,7 @@ private partial def elabStruct (s : Struct) (expectedType? : Option Expr) : Term
|
||||
match (← trySynthStructInstance? s d) with
|
||||
| some val => cont val { field with val := FieldVal.term (mkHole field.ref) }
|
||||
| none =>
|
||||
let { val, struct := sNew, instMVars := instMVarsNew } ← elabStruct s (some d)
|
||||
let { val, struct := sNew, instMVars := instMVarsNew } ← elabStructInstView s (some d)
|
||||
let val ← ensureHasType d val
|
||||
cont val { field with val := FieldVal.nested sNew } (instMVars ++ instMVarsNew)
|
||||
| .default =>
|
||||
@@ -700,17 +816,21 @@ private partial def elabStruct (s : Struct) (expectedType? : Option Expr) : Term
|
||||
cont (markDefaultMissing val) field
|
||||
| _ => withRef field.ref <| throwFailedToElabField fieldName s.structName m!"unexpected constructor type{indentExpr type}"
|
||||
| _ => throwErrorAt field.ref "unexpected unexpanded structure field"
|
||||
return { val := e, struct := s.setFields fields.reverse |>.setParams params, instMVars }
|
||||
return { val := e, struct := { s with fields := fields.reverse, params }, instMVars }
|
||||
|
||||
namespace DefaultFields
|
||||
|
||||
/--
|
||||
Context for default value propagation.
|
||||
-/
|
||||
structure Context where
|
||||
-- We must search for default values overridden in derived structures
|
||||
structs : Array Struct := #[]
|
||||
/-- The current path through `.nested` subobject structures. We must search for default values overridden in derived structures. -/
|
||||
structs : Array StructInstView := #[]
|
||||
/-- The collection of structures that could provide a default value. -/
|
||||
allStructNames : Array Name := #[]
|
||||
/--
|
||||
Consider the following example:
|
||||
```
|
||||
```lean
|
||||
structure A where
|
||||
x : Nat := 1
|
||||
|
||||
@@ -736,22 +856,29 @@ structure Context where
|
||||
-/
|
||||
maxDistance : Nat := 0
|
||||
|
||||
/--
|
||||
State for default value propagation
|
||||
-/
|
||||
structure State where
|
||||
/-- Whether progress has been made so far on this round of the propagation loop. -/
|
||||
progress : Bool := false
|
||||
|
||||
partial def collectStructNames (struct : Struct) (names : Array Name) : Array Name :=
|
||||
/-- Collects all structures that may provide default values for fields. -/
|
||||
partial def collectStructNames (struct : StructInstView) (names : Array Name) : Array Name :=
|
||||
let names := names.push struct.structName
|
||||
struct.fields.foldl (init := names) fun names field =>
|
||||
match field.val with
|
||||
| .nested struct => collectStructNames struct names
|
||||
| _ => names
|
||||
|
||||
partial def getHierarchyDepth (struct : Struct) : Nat :=
|
||||
/-- Gets the maximum nesting depth of subobjects. -/
|
||||
partial def getHierarchyDepth (struct : StructInstView) : Nat :=
|
||||
struct.fields.foldl (init := 0) fun max field =>
|
||||
match field.val with
|
||||
| .nested struct => Nat.max max (getHierarchyDepth struct + 1)
|
||||
| _ => max
|
||||
|
||||
/-- Returns whether the field is still missing. -/
|
||||
def isDefaultMissing? [Monad m] [MonadMCtx m] (field : Field Struct) : m Bool := do
|
||||
if let some expr := field.expr? then
|
||||
if let some (.mvar mvarId) := defaultMissing? expr then
|
||||
@@ -759,40 +886,51 @@ def isDefaultMissing? [Monad m] [MonadMCtx m] (field : Field Struct) : m Bool :=
|
||||
return true
|
||||
return false
|
||||
|
||||
partial def findDefaultMissing? [Monad m] [MonadMCtx m] (struct : Struct) : m (Option (Field Struct)) :=
|
||||
/-- Returns a field that is still missing. -/
|
||||
partial def findDefaultMissing? [Monad m] [MonadMCtx m] (struct : StructInstView) : m (Option (Field StructInstView)) :=
|
||||
struct.fields.findSomeM? fun field => do
|
||||
match field.val with
|
||||
| .nested struct => findDefaultMissing? struct
|
||||
| _ => return if (← isDefaultMissing? field) then field else none
|
||||
|
||||
partial def allDefaultMissing [Monad m] [MonadMCtx m] (struct : Struct) : m (Array (Field Struct)) :=
|
||||
/-- Returns all fields that are still missing. -/
|
||||
partial def allDefaultMissing [Monad m] [MonadMCtx m] (struct : StructInstView) : m (Array (Field StructInstView)) :=
|
||||
go struct *> get |>.run' #[]
|
||||
where
|
||||
go (struct : Struct) : StateT (Array (Field Struct)) m Unit :=
|
||||
go (struct : StructInstView) : StateT (Array (Field StructInstView)) m Unit :=
|
||||
for field in struct.fields do
|
||||
if let .nested struct := field.val then
|
||||
go struct
|
||||
else if (← isDefaultMissing? field) then
|
||||
modify (·.push field)
|
||||
|
||||
def getFieldName (field : Field Struct) : Name :=
|
||||
/-- Returns the name of the field. Assumes all fields under consideration are simple and named. -/
|
||||
def getFieldName (field : Field StructInstView) : Name :=
|
||||
match field.lhs with
|
||||
| [.fieldName _ fieldName] => fieldName
|
||||
| _ => unreachable!
|
||||
|
||||
abbrev M := ReaderT Context (StateRefT State TermElabM)
|
||||
|
||||
/-- Returns whether we should interrupt the round because we have made progress allowing nonzero depth. -/
|
||||
def isRoundDone : M Bool := do
|
||||
return (← get).progress && (← read).maxDistance > 0
|
||||
|
||||
def getFieldValue? (struct : Struct) (fieldName : Name) : Option Expr :=
|
||||
/-- Returns the `expr?` for the given field. -/
|
||||
def getFieldValue? (struct : StructInstView) (fieldName : Name) : Option Expr :=
|
||||
struct.fields.findSome? fun field =>
|
||||
if getFieldName field == fieldName then
|
||||
field.expr?
|
||||
else
|
||||
none
|
||||
|
||||
partial def mkDefaultValueAux? (struct : Struct) : Expr → TermElabM (Option Expr)
|
||||
/-- Instantiates a default value from the given default value declaration, if applicable. -/
|
||||
partial def mkDefaultValue? (struct : StructInstView) (cinfo : ConstantInfo) : TermElabM (Option Expr) :=
|
||||
withRef struct.ref do
|
||||
let us ← mkFreshLevelMVarsFor cinfo
|
||||
process (← instantiateValueLevelParams cinfo us)
|
||||
where
|
||||
process : Expr → TermElabM (Option Expr)
|
||||
| .lam n d b c => withRef struct.ref do
|
||||
if c.isExplicit then
|
||||
let fieldName := n
|
||||
@@ -801,29 +939,26 @@ partial def mkDefaultValueAux? (struct : Struct) : Expr → TermElabM (Option Ex
|
||||
| some val =>
|
||||
let valType ← inferType val
|
||||
if (← isDefEq valType d) then
|
||||
mkDefaultValueAux? struct (b.instantiate1 val)
|
||||
process (b.instantiate1 val)
|
||||
else
|
||||
return none
|
||||
else
|
||||
if let some (_, param) := struct.params.find? fun (paramName, _) => paramName == n then
|
||||
-- Recall that we did not use to have support for parameter propagation here.
|
||||
if (← isDefEq (← inferType param) d) then
|
||||
mkDefaultValueAux? struct (b.instantiate1 param)
|
||||
process (b.instantiate1 param)
|
||||
else
|
||||
return none
|
||||
else
|
||||
let arg ← mkFreshExprMVar d
|
||||
mkDefaultValueAux? struct (b.instantiate1 arg)
|
||||
process (b.instantiate1 arg)
|
||||
| e =>
|
||||
let_expr id _ a := e | return some e
|
||||
return some a
|
||||
|
||||
def mkDefaultValue? (struct : Struct) (cinfo : ConstantInfo) : TermElabM (Option Expr) :=
|
||||
withRef struct.ref do
|
||||
let us ← mkFreshLevelMVarsFor cinfo
|
||||
mkDefaultValueAux? struct (← instantiateValueLevelParams cinfo us)
|
||||
|
||||
/-- Reduce default value. It performs beta reduction and projections of the given structures. -/
|
||||
/--
|
||||
Reduces a default value. It performs beta reduction and projections of the given structures to reduce them to the provided values for fields.
|
||||
-/
|
||||
partial def reduce (structNames : Array Name) (e : Expr) : MetaM Expr := do
|
||||
match e with
|
||||
| .forallE .. =>
|
||||
@@ -880,7 +1015,10 @@ where
|
||||
else
|
||||
k
|
||||
|
||||
partial def tryToSynthesizeDefault (structs : Array Struct) (allStructNames : Array Name) (maxDistance : Nat) (fieldName : Name) (mvarId : MVarId) : TermElabM Bool :=
|
||||
/--
|
||||
Attempts to synthesize a default value for a missing field `fieldName` using default values from each structure in `structs`.
|
||||
-/
|
||||
def tryToSynthesizeDefault (structs : Array StructInstView) (allStructNames : Array Name) (maxDistance : Nat) (fieldName : Name) (mvarId : MVarId) : TermElabM Bool :=
|
||||
let rec loop (i : Nat) (dist : Nat) := do
|
||||
if dist > maxDistance then
|
||||
return false
|
||||
@@ -900,14 +1038,25 @@ partial def tryToSynthesizeDefault (structs : Array Struct) (allStructNames : Ar
|
||||
| none =>
|
||||
let mvarDecl ← getMVarDecl mvarId
|
||||
let val ← ensureHasType mvarDecl.type val
|
||||
mvarId.assign val
|
||||
return true
|
||||
/-
|
||||
We must use `checkedAssign` here to ensure we do not create a cyclic
|
||||
assignment. See #3150.
|
||||
This can happen when there are holes in the the fields the default value
|
||||
depends on.
|
||||
Possible improvement: create a new `_` instead of returning `false` when
|
||||
`checkedAssign` fails. Reason: the field will not be needed after the
|
||||
other `_` are resolved by the user.
|
||||
-/
|
||||
mvarId.checkedAssign val
|
||||
| _ => loop (i+1) dist
|
||||
else
|
||||
return false
|
||||
loop 0 0
|
||||
|
||||
partial def step (struct : Struct) : M Unit :=
|
||||
/--
|
||||
Performs one step of default value synthesis.
|
||||
-/
|
||||
partial def step (struct : StructInstView) : M Unit :=
|
||||
unless (← isRoundDone) do
|
||||
withReader (fun ctx => { ctx with structs := ctx.structs.push struct }) do
|
||||
for field in struct.fields do
|
||||
@@ -924,7 +1073,10 @@ partial def step (struct : Struct) : M Unit :=
|
||||
modify fun _ => { progress := true }
|
||||
| _ => pure ()
|
||||
|
||||
partial def propagateLoop (hierarchyDepth : Nat) (d : Nat) (struct : Struct) : M Unit := do
|
||||
/--
|
||||
Main entry point to default value synthesis in the `M` monad.
|
||||
-/
|
||||
partial def propagateLoop (hierarchyDepth : Nat) (d : Nat) (struct : StructInstView) : M Unit := do
|
||||
match (← findDefaultMissing? struct) with
|
||||
| none => return () -- Done
|
||||
| some field =>
|
||||
@@ -947,16 +1099,22 @@ partial def propagateLoop (hierarchyDepth : Nat) (d : Nat) (struct : Struct) : M
|
||||
else
|
||||
propagateLoop hierarchyDepth (d+1) struct
|
||||
|
||||
def propagate (struct : Struct) : TermElabM Unit :=
|
||||
/--
|
||||
Synthesizes default values for all missing fields, if possible.
|
||||
-/
|
||||
def propagate (struct : StructInstView) : TermElabM Unit :=
|
||||
let hierarchyDepth := getHierarchyDepth struct
|
||||
let structNames := collectStructNames struct #[]
|
||||
propagateLoop hierarchyDepth 0 struct { allStructNames := structNames } |>.run' {}
|
||||
|
||||
end DefaultFields
|
||||
|
||||
private def elabStructInstAux (stx : Syntax) (expectedType? : Option Expr) (source : Source) : TermElabM Expr := do
|
||||
let structName ← getStructName expectedType? source
|
||||
let struct ← liftMacroM <| mkStructView stx structName source
|
||||
/--
|
||||
Main entry point to elaborator for structure instance notation, unless the structure instance is a modifyOp.
|
||||
-/
|
||||
private def elabStructInstAux (stx : Syntax) (expectedType? : Option Expr) (sources : SourcesView) : TermElabM Expr := do
|
||||
let structName ← getStructName expectedType? sources
|
||||
let struct ← liftMacroM <| mkStructView stx structName sources
|
||||
let struct ← expandStruct struct
|
||||
trace[Elab.struct] "{struct}"
|
||||
/- We try to synthesize pending problems with `withSynthesize` combinator before trying to use default values.
|
||||
@@ -974,7 +1132,7 @@ private def elabStructInstAux (stx : Syntax) (expectedType? : Option Expr) (sour
|
||||
|
||||
TODO: investigate whether this design decision may have unintended side effects or produce confusing behavior.
|
||||
-/
|
||||
let { val := r, struct, instMVars } ← withSynthesize (postpone := .yes) <| elabStruct struct expectedType?
|
||||
let { val := r, struct, instMVars } ← withSynthesize (postpone := .yes) <| elabStructInstView struct expectedType?
|
||||
trace[Elab.struct] "before propagate {r}"
|
||||
DefaultFields.propagate struct
|
||||
synthesizeAppInstMVars instMVars r
|
||||
@@ -984,13 +1142,13 @@ private def elabStructInstAux (stx : Syntax) (expectedType? : Option Expr) (sour
|
||||
match (← expandNonAtomicExplicitSources stx) with
|
||||
| some stxNew => withMacroExpansion stx stxNew <| elabTerm stxNew expectedType?
|
||||
| none =>
|
||||
let sourceView ← getStructSource stx
|
||||
let sourcesView ← getStructSources stx
|
||||
if let some modifyOp ← isModifyOp? stx then
|
||||
if sourceView.explicit.isEmpty then
|
||||
if sourcesView.explicit.isEmpty then
|
||||
throwError "invalid \{...} notation, explicit source is required when using '[<index>] := <value>'"
|
||||
elabModifyOp stx modifyOp sourceView.explicit expectedType?
|
||||
elabModifyOp stx modifyOp sourcesView.explicit expectedType?
|
||||
else
|
||||
elabStructInstAux stx expectedType? sourceView
|
||||
elabStructInstAux stx expectedType? sourcesView
|
||||
|
||||
builtin_initialize
|
||||
registerTraceClass `Elab.struct
|
||||
|
||||
@@ -233,11 +233,15 @@ where
|
||||
return (← `((with_annotate_term $(stx[0]) @ParserDescr.sepBy1) $p $sep $psep $(quote allowTrailingSep)), 1)
|
||||
|
||||
isValidAtom (s : String) : Bool :=
|
||||
-- Pretty-printing instructions shouldn't affect validity
|
||||
let s := s.trim
|
||||
!s.isEmpty &&
|
||||
s.front != '\'' &&
|
||||
(s.front != '\'' || "''".isPrefixOf s) &&
|
||||
s.front != '\"' &&
|
||||
!(isIdBeginEscape s.front) &&
|
||||
!(s.front == '`' && (s.endPos == ⟨1⟩ || isIdFirst (s.get ⟨1⟩) || isIdBeginEscape (s.get ⟨1⟩))) &&
|
||||
!s.front.isDigit
|
||||
!s.front.isDigit &&
|
||||
!(s.any Char.isWhitespace)
|
||||
|
||||
processAtom (stx : Syntax) := do
|
||||
match stx[0].isStrLit? with
|
||||
|
||||
@@ -198,11 +198,10 @@ def rewriteRulesPass (maxSteps : Nat) : Pass where
|
||||
let sevalThms ← getSEvalTheorems
|
||||
let sevalSimprocs ← Simp.getSEvalSimprocs
|
||||
|
||||
let simpCtx : Simp.Context := {
|
||||
config := { failIfUnchanged := false, zetaDelta := true, maxSteps }
|
||||
simpTheorems := #[bvThms, sevalThms]
|
||||
congrTheorems := (← getSimpCongrTheorems)
|
||||
}
|
||||
let simpCtx ← Simp.mkContext
|
||||
(config := { failIfUnchanged := false, zetaDelta := true, maxSteps })
|
||||
(simpTheorems := #[bvThms, sevalThms])
|
||||
(congrTheorems := (← getSimpCongrTheorems))
|
||||
|
||||
let hyps ← goal.getNondepPropHyps
|
||||
let ⟨result?, _⟩ ← simpGoal goal
|
||||
@@ -217,35 +216,23 @@ Flatten out ands. That is look for hypotheses of the form `h : (x && y) = true`
|
||||
with `h.left : x = true` and `h.right : y = true`. This can enable more fine grained substitutions
|
||||
in embedded constraint substitution.
|
||||
-/
|
||||
def andFlatteningPass : Pass where
|
||||
partial def andFlatteningPass : Pass where
|
||||
name := `andFlattening
|
||||
run goal := do
|
||||
goal.withContext do
|
||||
let hyps ← goal.getNondepPropHyps
|
||||
let mut newHyps := #[]
|
||||
let mut oldHyps := #[]
|
||||
for hyp in hyps do
|
||||
let typ ← hyp.getType
|
||||
let_expr Eq α eqLhs eqRhs := typ | continue
|
||||
let_expr Bool.and lhs rhs := eqLhs | continue
|
||||
let_expr Bool := α | continue
|
||||
let_expr Bool.true := eqRhs | continue
|
||||
let mkEqTrue (lhs : Expr) : Expr :=
|
||||
mkApp3 (mkConst ``Eq [1]) (mkConst ``Bool) lhs (mkConst ``Bool.true)
|
||||
let hypExpr := (← hyp.getDecl).toExpr
|
||||
let leftHyp : Hypothesis := {
|
||||
userName := (← hyp.getUserName) ++ `left,
|
||||
type := mkEqTrue lhs,
|
||||
value := mkApp3 (mkConst ``Std.Tactic.BVDecide.Normalize.Bool.and_left) lhs rhs hypExpr
|
||||
for fvar in hyps do
|
||||
let hyp : Hypothesis := {
|
||||
userName := (← fvar.getDecl).userName
|
||||
type := ← fvar.getType
|
||||
value := mkFVar fvar
|
||||
}
|
||||
let rightHyp : Hypothesis := {
|
||||
userName := (← hyp.getUserName) ++ `right,
|
||||
type := mkEqTrue rhs,
|
||||
value := mkApp3 (mkConst ``Std.Tactic.BVDecide.Normalize.Bool.and_right) lhs rhs hypExpr
|
||||
}
|
||||
newHyps := newHyps.push leftHyp
|
||||
newHyps := newHyps.push rightHyp
|
||||
oldHyps := oldHyps.push hyp
|
||||
let sizeBefore := newHyps.size
|
||||
newHyps ← splitAnds hyp newHyps
|
||||
if newHyps.size > sizeBefore then
|
||||
oldHyps := oldHyps.push fvar
|
||||
if newHyps.size == 0 then
|
||||
return goal
|
||||
else
|
||||
@@ -253,6 +240,38 @@ def andFlatteningPass : Pass where
|
||||
-- Given that we collected the hypotheses in the correct order above the invariant is given
|
||||
let goal ← goal.tryClearMany oldHyps
|
||||
return goal
|
||||
where
|
||||
splitAnds (hyp : Hypothesis) (hyps : Array Hypothesis) (first : Bool := true) :
|
||||
MetaM (Array Hypothesis) := do
|
||||
match ← trySplit hyp with
|
||||
| some (left, right) =>
|
||||
let hyps ← splitAnds left hyps false
|
||||
splitAnds right hyps false
|
||||
| none =>
|
||||
if first then
|
||||
return hyps
|
||||
else
|
||||
return hyps.push hyp
|
||||
|
||||
trySplit (hyp : Hypothesis) : MetaM (Option (Hypothesis × Hypothesis)) := do
|
||||
let typ := hyp.type
|
||||
let_expr Eq α eqLhs eqRhs := typ | return none
|
||||
let_expr Bool.and lhs rhs := eqLhs | return none
|
||||
let_expr Bool.true := eqRhs | return none
|
||||
let_expr Bool := α | return none
|
||||
let mkEqTrue (lhs : Expr) : Expr :=
|
||||
mkApp3 (mkConst ``Eq [1]) (mkConst ``Bool) lhs (mkConst ``Bool.true)
|
||||
let leftHyp : Hypothesis := {
|
||||
userName := hyp.userName,
|
||||
type := mkEqTrue lhs,
|
||||
value := mkApp3 (mkConst ``Std.Tactic.BVDecide.Normalize.Bool.and_left) lhs rhs hyp.value
|
||||
}
|
||||
let rightHyp : Hypothesis := {
|
||||
userName := hyp.userName,
|
||||
type := mkEqTrue rhs,
|
||||
value := mkApp3 (mkConst ``Std.Tactic.BVDecide.Normalize.Bool.and_right) lhs rhs hyp.value
|
||||
}
|
||||
return some (leftHyp, rightHyp)
|
||||
|
||||
/--
|
||||
Substitute embedded constraints. That is look for hypotheses of the form `h : x = true` and use
|
||||
@@ -283,11 +302,10 @@ def embeddedConstraintPass (maxSteps : Nat) : Pass where
|
||||
|
||||
let goal ← goal.tryClearMany duplicates
|
||||
|
||||
let simpCtx : Simp.Context := {
|
||||
config := { failIfUnchanged := false, maxSteps }
|
||||
simpTheorems := relevantHyps
|
||||
congrTheorems := (← getSimpCongrTheorems)
|
||||
}
|
||||
let simpCtx ← Simp.mkContext
|
||||
(config := { failIfUnchanged := false, maxSteps })
|
||||
(simpTheorems := relevantHyps)
|
||||
(congrTheorems := (← getSimpCongrTheorems))
|
||||
|
||||
let ⟨result?, _⟩ ← simpGoal goal (ctx := simpCtx) (fvarIdsToSimp := ← goal.getNondepPropHyps)
|
||||
let some (_, newGoal) := result? | return none
|
||||
@@ -310,22 +328,18 @@ def acNormalizePass : Pass where
|
||||
|
||||
return newGoal
|
||||
|
||||
/--
|
||||
The normalization passes used by `bv_normalize` and thus `bv_decide`.
|
||||
-/
|
||||
def defaultPipeline (cfg : BVDecideConfig ): List Pass :=
|
||||
[
|
||||
rewriteRulesPass cfg.maxSteps,
|
||||
andFlatteningPass,
|
||||
embeddedConstraintPass cfg.maxSteps
|
||||
]
|
||||
|
||||
def passPipeline (cfg : BVDecideConfig) : List Pass := Id.run do
|
||||
let mut passPipeline := defaultPipeline cfg
|
||||
let mut passPipeline := [rewriteRulesPass cfg.maxSteps]
|
||||
|
||||
if cfg.acNf then
|
||||
passPipeline := passPipeline ++ [acNormalizePass]
|
||||
|
||||
if cfg.andFlattening then
|
||||
passPipeline := passPipeline ++ [andFlatteningPass]
|
||||
|
||||
if cfg.embeddedConstraintSubst then
|
||||
passPipeline := passPipeline ++ [embeddedConstraintPass cfg.maxSteps]
|
||||
|
||||
return passPipeline
|
||||
|
||||
end Pass
|
||||
|
||||
@@ -13,6 +13,31 @@ open Meta
|
||||
# Implementation of the `change` tactic
|
||||
-/
|
||||
|
||||
/--
|
||||
Elaborates the pattern `p` and ensures that it is defeq to `e`.
|
||||
Emulates `(show p from ?m : e)`, returning the type of `?m`, but `e` and `p` do not need to be types.
|
||||
Unlike `(show p from ?m : e)`, this can assign synthetic opaque metavariables appearing in `p`.
|
||||
-/
|
||||
def elabChange (e : Expr) (p : Term) : TacticM Expr := do
|
||||
let p ← runTermElab do
|
||||
let p ← Term.elabTermEnsuringType p (← inferType e)
|
||||
unless ← isDefEq p e do
|
||||
/-
|
||||
Sometimes isDefEq can fail due to postponed elaboration problems.
|
||||
We synthesize pending synthetic mvars while allowing typeclass instances to be postponed,
|
||||
which might enable solving for them with an additional `isDefEq`.
|
||||
-/
|
||||
Term.synthesizeSyntheticMVars (postpone := .partial)
|
||||
discard <| isDefEq p e
|
||||
pure p
|
||||
withAssignableSyntheticOpaque do
|
||||
unless ← isDefEq p e do
|
||||
let (p, tgt) ← addPPExplicitToExposeDiff p e
|
||||
throwError "\
|
||||
'change' tactic failed, pattern{indentExpr p}\n\
|
||||
is not definitionally equal to target{indentExpr tgt}"
|
||||
instantiateMVars p
|
||||
|
||||
/-- `change` can be used to replace the main goal or its hypotheses with
|
||||
different, yet definitionally equal, goal or hypotheses.
|
||||
|
||||
@@ -38,15 +63,13 @@ the main goal. -/
|
||||
| `(tactic| change $newType:term $[$loc:location]?) => do
|
||||
withLocation (expandOptLocation (Lean.mkOptionalNode loc))
|
||||
(atLocal := fun h => do
|
||||
let hTy ← h.getType
|
||||
-- This is a hack to get the new type to elaborate in the same sort of way that
|
||||
-- it would for a `show` expression for the goal.
|
||||
let mvar ← mkFreshExprMVar none
|
||||
let (_, mvars) ← elabTermWithHoles
|
||||
(← `(term | show $newType from $(← Term.exprToSyntax mvar))) hTy `change
|
||||
let (hTy', mvars) ← withCollectingNewGoalsFrom (elabChange (← h.getType) newType) (← getMainTag) `change
|
||||
liftMetaTactic fun mvarId => do
|
||||
return (← mvarId.changeLocalDecl h (← inferType mvar)) :: mvars)
|
||||
(atTarget := evalTactic <| ← `(tactic| refine_lift show $newType from ?_))
|
||||
(failed := fun _ => throwError "change tactic failed")
|
||||
return (← mvarId.changeLocalDecl h hTy') :: mvars)
|
||||
(atTarget := do
|
||||
let (tgt', mvars) ← withCollectingNewGoalsFrom (elabChange (← getMainTarget) newType) (← getMainTag) `change
|
||||
liftMetaTactic fun mvarId => do
|
||||
return (← mvarId.replaceTargetDefEq tgt') :: mvars)
|
||||
(failed := fun _ => throwError "'change' tactic failed")
|
||||
|
||||
end Lean.Elab.Tactic
|
||||
|
||||
@@ -114,6 +114,13 @@ private def elabConfig (recover : Bool) (structName : Name) (items : Array Confi
|
||||
let e ← Term.withSynthesize <| Term.elabTermEnsuringType stx (mkConst structName)
|
||||
instantiateMVars e
|
||||
|
||||
section
|
||||
-- We automatically disable the following option for `macro`s but the subsequent `def` both contains
|
||||
-- a quotation and is called only by `macro`s, so we disable the option for it manually. Note that
|
||||
-- we can't use `in` as it is parsed as a single command and so the option would not influence the
|
||||
-- parser.
|
||||
set_option internal.parseQuotWithCurrentStage false
|
||||
|
||||
private def mkConfigElaborator
|
||||
(doc? : Option (TSyntax ``Parser.Command.docComment)) (elabName type monadName : Ident)
|
||||
(adapt recover : Term) : MacroM (TSyntax `command) := do
|
||||
@@ -148,6 +155,8 @@ private def mkConfigElaborator
|
||||
throwError msg
|
||||
go)
|
||||
|
||||
end
|
||||
|
||||
/-!
|
||||
`declare_config_elab elabName TypeName` declares a function `elabName : Syntax → TacticM TypeName`
|
||||
that elaborates a tactic configuration.
|
||||
|
||||
@@ -5,6 +5,7 @@ Authors: Leonardo de Moura
|
||||
-/
|
||||
prelude
|
||||
import Lean.Elab.Tactic.ElabTerm
|
||||
import Lean.Elab.Tactic.Change
|
||||
import Lean.Elab.Tactic.Conv.Basic
|
||||
|
||||
namespace Lean.Elab.Tactic.Conv
|
||||
@@ -15,11 +16,9 @@ open Meta
|
||||
| `(conv| change $e) => withMainContext do
|
||||
let lhs ← getLhs
|
||||
let mvarCounterSaved := (← getMCtx).mvarCounter
|
||||
let r ← elabTermEnsuringType e (← inferType lhs)
|
||||
logUnassignedAndAbort (← filterOldMVars (← getMVars r) mvarCounterSaved)
|
||||
unless (← isDefEqGuarded r lhs) do
|
||||
throwError "invalid 'change' conv tactic, term{indentExpr r}\nis not definitionally equal to current left-hand-side{indentExpr lhs}"
|
||||
changeLhs r
|
||||
let lhs' ← elabChange lhs e
|
||||
logUnassignedAndAbort (← filterOldMVars (← getMVars lhs') mvarCounterSaved)
|
||||
changeLhs lhs'
|
||||
| _ => throwUnsupportedSyntax
|
||||
|
||||
end Lean.Elab.Tactic.Conv
|
||||
|
||||
@@ -12,11 +12,10 @@ namespace Lean.Elab.Tactic.Conv
|
||||
open Meta
|
||||
|
||||
private def getContext : MetaM Simp.Context := do
|
||||
return {
|
||||
simpTheorems := {}
|
||||
congrTheorems := (← getSimpCongrTheorems)
|
||||
config := Simp.neutralConfig
|
||||
}
|
||||
Simp.mkContext
|
||||
(simpTheorems := {})
|
||||
(congrTheorems := (← getSimpCongrTheorems))
|
||||
(config := Simp.neutralConfig)
|
||||
|
||||
partial def matchPattern? (pattern : AbstractMVarsResult) (e : Expr) : MetaM (Option (Expr × Array Expr)) :=
|
||||
withNewMCtxDepth do
|
||||
@@ -126,7 +125,7 @@ private def pre (pattern : AbstractMVarsResult) (state : IO.Ref PatternMatchStat
|
||||
pure (.occs #[] 0 ids.toList)
|
||||
| _ => throwUnsupportedSyntax
|
||||
let state ← IO.mkRef occs
|
||||
let ctx := { ← getContext with config.memoize := occs matches .all _ }
|
||||
let ctx := (← getContext).setMemoize (occs matches .all _)
|
||||
let (result, _) ← Simp.main lhs ctx (methods := { pre := pre patternA state })
|
||||
let subgoals ← match ← state.get with
|
||||
| .all #[] | .occs _ 0 _ =>
|
||||
|
||||
@@ -18,21 +18,22 @@ private def mkKey (e : Expr) (simp : Bool) : MetaM (Array Key) := do
|
||||
let (_, _, type) ← withReducible <| forallMetaTelescopeReducing e
|
||||
let type ← whnfR type
|
||||
if simp then
|
||||
if let some (_, lhs, _) := type.eq? then
|
||||
mkPath lhs simpDtConfig
|
||||
else if let some (lhs, _) := type.iff? then
|
||||
mkPath lhs simpDtConfig
|
||||
else if let some (_, lhs, _) := type.ne? then
|
||||
mkPath lhs simpDtConfig
|
||||
else if let some p := type.not? then
|
||||
match p.eq? with
|
||||
| some (_, lhs, _) =>
|
||||
mkPath lhs simpDtConfig
|
||||
| _ => mkPath p simpDtConfig
|
||||
else
|
||||
mkPath type simpDtConfig
|
||||
withSimpGlobalConfig do
|
||||
if let some (_, lhs, _) := type.eq? then
|
||||
mkPath lhs
|
||||
else if let some (lhs, _) := type.iff? then
|
||||
mkPath lhs
|
||||
else if let some (_, lhs, _) := type.ne? then
|
||||
mkPath lhs
|
||||
else if let some p := type.not? then
|
||||
match p.eq? with
|
||||
| some (_, lhs, _) =>
|
||||
mkPath lhs
|
||||
| _ => mkPath p
|
||||
else
|
||||
mkPath type
|
||||
else
|
||||
mkPath type {}
|
||||
mkPath type
|
||||
|
||||
private def getType (t : TSyntax `term) : TermElabM Expr := do
|
||||
if let `($id:ident) := t then
|
||||
|
||||
@@ -542,11 +542,6 @@ declare_config_elab elabDecideConfig Parser.Tactic.DecideConfig
|
||||
let cfg ← elabDecideConfig stx[1]
|
||||
evalDecideCore `decide cfg
|
||||
|
||||
@[builtin_tactic Lean.Parser.Tactic.decideBang] def evalDecideBang : Tactic := fun stx => do
|
||||
let cfg ← elabDecideConfig stx[1]
|
||||
let cfg := { cfg with kernel := true }
|
||||
evalDecideCore `decide! cfg
|
||||
|
||||
@[builtin_tactic Lean.Parser.Tactic.nativeDecide] def evalNativeDecide : Tactic := fun stx => do
|
||||
let cfg ← elabDecideConfig stx[1]
|
||||
let cfg := { cfg with native := true }
|
||||
|
||||
@@ -195,9 +195,6 @@ structure ExtTheorems where
|
||||
erased : PHashSet Name := {}
|
||||
deriving Inhabited
|
||||
|
||||
/-- Discrimation tree settings for the `ext` extension. -/
|
||||
def extExt.config : WhnfCoreConfig := {}
|
||||
|
||||
/-- The environment extension to track `@[ext]` theorems. -/
|
||||
builtin_initialize extExtension :
|
||||
SimpleScopedEnvExtension ExtTheorem ExtTheorems ←
|
||||
@@ -211,7 +208,7 @@ builtin_initialize extExtension :
|
||||
ordered from high priority to low. -/
|
||||
@[inline] def getExtTheorems (ty : Expr) : MetaM (Array ExtTheorem) := do
|
||||
let extTheorems := extExtension.getState (← getEnv)
|
||||
let arr ← extTheorems.tree.getMatch ty extExt.config
|
||||
let arr ← extTheorems.tree.getMatch ty
|
||||
let erasedArr := arr.filter fun thm => !extTheorems.erased.contains thm.declName
|
||||
-- Using insertion sort because it is stable and the list of matches should be mostly sorted.
|
||||
-- Most ext theorems have default priority.
|
||||
@@ -258,7 +255,7 @@ builtin_initialize registerBuiltinAttribute {
|
||||
but this theorem proves{indentD declTy}"
|
||||
let some (ty, lhs, rhs) := declTy.eq? | failNotEq
|
||||
unless lhs.isMVar && rhs.isMVar do failNotEq
|
||||
let keys ← withReducible <| DiscrTree.mkPath ty extExt.config
|
||||
let keys ← withReducible <| DiscrTree.mkPath ty
|
||||
let priority ← liftCommandElabM <| Elab.liftMacroM do evalPrio (prio.getD (← `(prio| default)))
|
||||
extExtension.add {declName, keys, priority} kind
|
||||
-- Realize iff theorem
|
||||
|
||||
@@ -40,7 +40,7 @@ def exact? (ref : Syntax) (required : Option (Array (TSyntax `term))) (requireCl
|
||||
| some suggestions =>
|
||||
if requireClose then throwError
|
||||
"`exact?` could not close the goal. Try `apply?` to see partial suggestions."
|
||||
reportOutOfHeartbeats `library_search ref
|
||||
reportOutOfHeartbeats `apply? ref
|
||||
for (_, suggestionMCtx) in suggestions do
|
||||
withMCtx suggestionMCtx do
|
||||
addExactSuggestion ref (← instantiateMVars (mkMVar mvar)).headBeta (addSubgoalsMsg := true)
|
||||
|
||||
@@ -28,8 +28,10 @@ def proveEqUsing (s : SimpTheorems) (a b : Expr) : MetaM (Option Simp.Result) :=
|
||||
unless ← isDefEq a'.expr b'.expr do return none
|
||||
a'.mkEqTrans (← b'.mkEqSymm b)
|
||||
withReducible do
|
||||
(go (← Simp.mkDefaultMethods).toMethodsRef
|
||||
{ simpTheorems := #[s], congrTheorems := ← Meta.getSimpCongrTheorems }).run' {}
|
||||
let ctx ← Simp.mkContext
|
||||
(simpTheorems := #[s])
|
||||
(congrTheorems := ← Meta.getSimpCongrTheorems)
|
||||
(go (← Simp.mkDefaultMethods).toMethodsRef ctx).run' {}
|
||||
|
||||
/-- Proves `a = b` by simplifying using move and squash lemmas. -/
|
||||
def proveEqUsingDown (a b : Expr) : MetaM (Option Simp.Result) := do
|
||||
@@ -191,19 +193,25 @@ def derive (e : Expr) : MetaM Simp.Result := do
|
||||
-- step 1: pre-processing of numerals
|
||||
let r ← withTrace "pre-processing numerals" do
|
||||
let post e := return Simp.Step.done (← try numeralToCoe e catch _ => pure {expr := e})
|
||||
r.mkEqTrans (← Simp.main r.expr { config, congrTheorems } (methods := { post })).1
|
||||
let ctx ← Simp.mkContext (config := config) (congrTheorems := congrTheorems)
|
||||
r.mkEqTrans (← Simp.main r.expr ctx (methods := { post })).1
|
||||
|
||||
-- step 2: casts are moved upwards and eliminated
|
||||
let r ← withTrace "moving upward, splitting and eliminating" do
|
||||
let post := upwardAndElim (← normCastExt.up.getTheorems)
|
||||
r.mkEqTrans (← Simp.main r.expr { config, congrTheorems } (methods := { post })).1
|
||||
let ctx ← Simp.mkContext (config := config) (congrTheorems := congrTheorems)
|
||||
r.mkEqTrans (← Simp.main r.expr ctx (methods := { post })).1
|
||||
|
||||
let simprocs ← ({} : Simp.SimprocsArray).add `reduceCtorEq false
|
||||
|
||||
-- step 3: casts are squashed
|
||||
let r ← withTrace "squashing" do
|
||||
let simpTheorems := #[← normCastExt.squash.getTheorems]
|
||||
r.mkEqTrans (← simp r.expr { simpTheorems, config, congrTheorems } simprocs).1
|
||||
let ctx ← Simp.mkContext
|
||||
(config := config)
|
||||
(simpTheorems := simpTheorems)
|
||||
(congrTheorems := congrTheorems)
|
||||
r.mkEqTrans (← simp r.expr ctx simprocs).1
|
||||
|
||||
return r
|
||||
|
||||
@@ -263,7 +271,7 @@ def evalConvNormCast : Tactic :=
|
||||
def evalPushCast : Tactic := fun stx => do
|
||||
let { ctx, simprocs, dischargeWrapper } ← withMainContext do
|
||||
mkSimpContext (simpTheorems := pushCastExt.getTheorems) stx (eraseLocal := false)
|
||||
let ctx := { ctx with config := { ctx.config with failIfUnchanged := false } }
|
||||
let ctx := ctx.setFailIfUnchanged false
|
||||
dischargeWrapper.with fun discharge? =>
|
||||
discard <| simpLocation ctx simprocs discharge? (expandOptLocation stx[5])
|
||||
|
||||
|
||||
@@ -6,7 +6,6 @@ Authors: Kim Morrison
|
||||
prelude
|
||||
import Lean.Elab.Tactic.Omega.Core
|
||||
import Lean.Elab.Tactic.FalseOrByContra
|
||||
import Lean.Meta.Tactic.Cases
|
||||
import Lean.Elab.Tactic.Config
|
||||
|
||||
/-!
|
||||
@@ -520,23 +519,6 @@ partial def processFacts (p : MetaProblem) : OmegaM (MetaProblem × Nat) := do
|
||||
|
||||
end MetaProblem
|
||||
|
||||
/--
|
||||
Given `p : P ∨ Q` (or any inductive type with two one-argument constructors),
|
||||
split the goal into two subgoals:
|
||||
one containing the hypothesis `h : P` and another containing `h : Q`.
|
||||
-/
|
||||
def cases₂ (mvarId : MVarId) (p : Expr) (hName : Name := `h) :
|
||||
MetaM ((MVarId × FVarId) × (MVarId × FVarId)) := do
|
||||
let mvarId ← mvarId.assert `hByCases (← inferType p) p
|
||||
let (fvarId, mvarId) ← mvarId.intro1
|
||||
let #[s₁, s₂] ← mvarId.cases fvarId #[{ varNames := [hName] }, { varNames := [hName] }] |
|
||||
throwError "'cases' tactic failed, unexpected number of subgoals"
|
||||
let #[Expr.fvar f₁ ..] ← pure s₁.fields
|
||||
| throwError "'cases' tactic failed, unexpected new hypothesis"
|
||||
let #[Expr.fvar f₂ ..] ← pure s₂.fields
|
||||
| throwError "'cases' tactic failed, unexpected new hypothesis"
|
||||
return ((s₁.mvarId, f₁), (s₂.mvarId, f₂))
|
||||
|
||||
/--
|
||||
Helpful error message when omega cannot find a solution
|
||||
-/
|
||||
@@ -628,33 +610,36 @@ mutual
|
||||
Split a disjunction in a `MetaProblem`, and if we find a new usable fact
|
||||
call `omegaImpl` in both branches.
|
||||
-/
|
||||
partial def splitDisjunction (m : MetaProblem) (g : MVarId) : OmegaM Unit := g.withContext do
|
||||
partial def splitDisjunction (m : MetaProblem) : OmegaM Expr := do
|
||||
match m.disjunctions with
|
||||
| [] => throwError "omega could not prove the goal:\n{← formatErrorMessage m.problem}"
|
||||
| h :: t =>
|
||||
trace[omega] "Case splitting on {← inferType h}"
|
||||
let ctx ← getMCtx
|
||||
let (⟨g₁, h₁⟩, ⟨g₂, h₂⟩) ← cases₂ g h
|
||||
trace[omega] "Adding facts:\n{← g₁.withContext <| inferType (.fvar h₁)}"
|
||||
let m₁ := { m with facts := [.fvar h₁], disjunctions := t }
|
||||
let r ← withoutModifyingState do
|
||||
let (m₁, n) ← g₁.withContext m₁.processFacts
|
||||
| h :: t => do
|
||||
let hType ← whnfD (← inferType h)
|
||||
trace[omega] "Case splitting on {hType}"
|
||||
let_expr Or hType₁ hType₂ := hType | throwError "Unexpected disjunction {hType}"
|
||||
let p?₁ ← withoutModifyingState do withLocalDeclD `h₁ hType₁ fun h₁ => do
|
||||
withTraceNode `omega (msg := fun _ => do pure m!"Assuming fact:{indentExpr hType₁}") do
|
||||
let m₁ := { m with facts := [h₁], disjunctions := t }
|
||||
let (m₁, n) ← m₁.processFacts
|
||||
if 0 < n then
|
||||
omegaImpl m₁ g₁
|
||||
pure true
|
||||
let p₁ ← omegaImpl m₁
|
||||
let p₁ ← mkLambdaFVars #[h₁] p₁
|
||||
return some p₁
|
||||
else
|
||||
pure false
|
||||
if r then
|
||||
trace[omega] "Adding facts:\n{← g₂.withContext <| inferType (.fvar h₂)}"
|
||||
let m₂ := { m with facts := [.fvar h₂], disjunctions := t }
|
||||
omegaImpl m₂ g₂
|
||||
return none
|
||||
if let some p₁ := p?₁ then
|
||||
withLocalDeclD `h₂ hType₂ fun h₂ => do
|
||||
withTraceNode `omega (msg := fun _ => do pure m!"Assuming fact:{indentExpr hType₂}") do
|
||||
let m₂ := { m with facts := [h₂], disjunctions := t }
|
||||
let p₂ ← omegaImpl m₂
|
||||
let p₂ ← mkLambdaFVars #[h₂] p₂
|
||||
return mkApp6 (mkConst ``Or.elim) hType₁ hType₂ (mkConst ``False) h p₁ p₂
|
||||
else
|
||||
trace[omega] "No new facts found."
|
||||
setMCtx ctx
|
||||
splitDisjunction { m with disjunctions := t } g
|
||||
splitDisjunction { m with disjunctions := t }
|
||||
|
||||
/-- Implementation of the `omega` algorithm, and handling disjunctions. -/
|
||||
partial def omegaImpl (m : MetaProblem) (g : MVarId) : OmegaM Unit := g.withContext do
|
||||
partial def omegaImpl (m : MetaProblem) : OmegaM Expr := do
|
||||
let (m, _) ← m.processFacts
|
||||
guard m.facts.isEmpty
|
||||
let p := m.problem
|
||||
@@ -663,12 +648,12 @@ partial def omegaImpl (m : MetaProblem) (g : MVarId) : OmegaM Unit := g.withCont
|
||||
trace[omega] "After elimination:\nAtoms: {← atomsList}\n{p'}"
|
||||
match p'.possible, p'.proveFalse?, p'.proveFalse?_spec with
|
||||
| true, _, _ =>
|
||||
splitDisjunction m g
|
||||
splitDisjunction m
|
||||
| false, .some prf, _ =>
|
||||
trace[omega] "Justification:\n{p'.explanation?.get}"
|
||||
let prf ← instantiateMVars (← prf)
|
||||
trace[omega] "omega found a contradiction, proving {← inferType prf}"
|
||||
g.assign prf
|
||||
return prf
|
||||
|
||||
end
|
||||
|
||||
@@ -677,7 +662,9 @@ Given a collection of facts, try prove `False` using the omega algorithm,
|
||||
and close the goal using that.
|
||||
-/
|
||||
def omega (facts : List Expr) (g : MVarId) (cfg : OmegaConfig := {}) : MetaM Unit :=
|
||||
OmegaM.run (omegaImpl { facts } g) cfg
|
||||
g.withContext do
|
||||
let prf ← OmegaM.run (omegaImpl { facts }) cfg
|
||||
g.assign prf
|
||||
|
||||
open Lean Elab Tactic Parser.Tactic
|
||||
|
||||
|
||||
@@ -91,7 +91,7 @@ def elabSimpConfig (optConfig : Syntax) (kind : SimpKind) : TacticM Meta.Simp.Co
|
||||
| .simpAll => return (← elabSimpConfigCtxCore optConfig).toConfig
|
||||
| .dsimp => return { (← elabDSimpConfigCore optConfig) with }
|
||||
|
||||
private def addDeclToUnfoldOrTheorem (thms : SimpTheorems) (id : Origin) (e : Expr) (post : Bool) (inv : Bool) (kind : SimpKind) : MetaM SimpTheorems := do
|
||||
private def addDeclToUnfoldOrTheorem (config : Meta.ConfigWithKey) (thms : SimpTheorems) (id : Origin) (e : Expr) (post : Bool) (inv : Bool) (kind : SimpKind) : MetaM SimpTheorems := do
|
||||
if e.isConst then
|
||||
let declName := e.constName!
|
||||
let info ← getConstInfo declName
|
||||
@@ -108,7 +108,7 @@ private def addDeclToUnfoldOrTheorem (thms : SimpTheorems) (id : Origin) (e : Ex
|
||||
let fvarId := e.fvarId!
|
||||
let decl ← fvarId.getDecl
|
||||
if (← isProp decl.type) then
|
||||
thms.add id #[] e (post := post) (inv := inv)
|
||||
thms.add id #[] e (post := post) (inv := inv) (config := config)
|
||||
else if !decl.isLet then
|
||||
throwError "invalid argument, variable is not a proposition or let-declaration"
|
||||
else if inv then
|
||||
@@ -116,9 +116,9 @@ private def addDeclToUnfoldOrTheorem (thms : SimpTheorems) (id : Origin) (e : Ex
|
||||
else
|
||||
return thms.addLetDeclToUnfold fvarId
|
||||
else
|
||||
thms.add id #[] e (post := post) (inv := inv)
|
||||
thms.add id #[] e (post := post) (inv := inv) (config := config)
|
||||
|
||||
private def addSimpTheorem (thms : SimpTheorems) (id : Origin) (stx : Syntax) (post : Bool) (inv : Bool) : TermElabM SimpTheorems := do
|
||||
private def addSimpTheorem (config : Meta.ConfigWithKey) (thms : SimpTheorems) (id : Origin) (stx : Syntax) (post : Bool) (inv : Bool) : TermElabM SimpTheorems := do
|
||||
let thm? ← Term.withoutModifyingElabMetaStateWithInfo <| withRef stx do
|
||||
let e ← Term.elabTerm stx none
|
||||
Term.synthesizeSyntheticMVars (postpone := .no) (ignoreStuckTC := true)
|
||||
@@ -132,7 +132,7 @@ private def addSimpTheorem (thms : SimpTheorems) (id : Origin) (stx : Syntax) (p
|
||||
else
|
||||
return some (#[], e)
|
||||
if let some (levelParams, proof) := thm? then
|
||||
thms.add id levelParams proof (post := post) (inv := inv)
|
||||
thms.add id levelParams proof (post := post) (inv := inv) (config := config)
|
||||
else
|
||||
return thms
|
||||
|
||||
@@ -212,7 +212,7 @@ def elabSimpArgs (stx : Syntax) (ctx : Simp.Context) (simprocs : Simp.SimprocsAr
|
||||
match (← resolveSimpIdTheorem? term) with
|
||||
| .expr e =>
|
||||
let name ← mkFreshId
|
||||
thms ← addDeclToUnfoldOrTheorem thms (.stx name arg) e post inv kind
|
||||
thms ← addDeclToUnfoldOrTheorem ctx.indexConfig thms (.stx name arg) e post inv kind
|
||||
| .simproc declName =>
|
||||
simprocs ← simprocs.add declName post
|
||||
| .ext (some ext₁) (some ext₂) _ =>
|
||||
@@ -224,7 +224,7 @@ def elabSimpArgs (stx : Syntax) (ctx : Simp.Context) (simprocs : Simp.SimprocsAr
|
||||
simprocs := simprocs.push (← ext₂.getSimprocs)
|
||||
| .none =>
|
||||
let name ← mkFreshId
|
||||
thms ← addSimpTheorem thms (.stx name arg) term post inv
|
||||
thms ← addSimpTheorem ctx.indexConfig thms (.stx name arg) term post inv
|
||||
else if arg.getKind == ``Lean.Parser.Tactic.simpStar then
|
||||
starArg := true
|
||||
else
|
||||
@@ -234,7 +234,7 @@ def elabSimpArgs (stx : Syntax) (ctx : Simp.Context) (simprocs : Simp.SimprocsAr
|
||||
logException ex
|
||||
else
|
||||
throw ex
|
||||
return { ctx := { ctx with simpTheorems := thmsArray.set! 0 thms }, simprocs, starArg }
|
||||
return { ctx := ctx.setSimpTheorems (thmsArray.set! 0 thms), simprocs, starArg }
|
||||
-- If recovery is disabled, then we want simp argument elaboration failures to be exceptions.
|
||||
-- This affects `addSimpTheorem`.
|
||||
if (← read).recover then
|
||||
@@ -311,10 +311,11 @@ def mkSimpContext (stx : Syntax) (eraseLocal : Bool) (kind := SimpKind.simp)
|
||||
simpTheorems
|
||||
let simprocs ← if simpOnly then pure {} else Simp.getSimprocs
|
||||
let congrTheorems ← getSimpCongrTheorems
|
||||
let r ← elabSimpArgs stx[4] (eraseLocal := eraseLocal) (kind := kind) (simprocs := #[simprocs]) {
|
||||
config := (← elabSimpConfig stx[1] (kind := kind))
|
||||
simpTheorems := #[simpTheorems], congrTheorems
|
||||
}
|
||||
let ctx ← Simp.mkContext
|
||||
(config := (← elabSimpConfig stx[1] (kind := kind)))
|
||||
(simpTheorems := #[simpTheorems])
|
||||
congrTheorems
|
||||
let r ← elabSimpArgs stx[4] (eraseLocal := eraseLocal) (kind := kind) (simprocs := #[simprocs]) ctx
|
||||
if !r.starArg || ignoreStarArg then
|
||||
return { r with dischargeWrapper }
|
||||
else
|
||||
@@ -328,8 +329,8 @@ def mkSimpContext (stx : Syntax) (eraseLocal : Bool) (kind := SimpKind.simp)
|
||||
let hs ← getPropHyps
|
||||
for h in hs do
|
||||
unless simpTheorems.isErased (.fvar h) do
|
||||
simpTheorems ← simpTheorems.addTheorem (.fvar h) (← h.getDecl).toExpr
|
||||
let ctx := { ctx with simpTheorems }
|
||||
simpTheorems ← simpTheorems.addTheorem (.fvar h) (← h.getDecl).toExpr (config := ctx.indexConfig)
|
||||
let ctx := ctx.setSimpTheorems simpTheorems
|
||||
return { ctx, simprocs, dischargeWrapper }
|
||||
|
||||
register_builtin_option tactic.simp.trace : Bool := {
|
||||
|
||||
@@ -36,9 +36,9 @@ deriving instance Repr for UseImplicitLambdaResult
|
||||
let stx ← `(tactic| simp $cfg:optConfig $(disch)? $[only%$only]? $[[$args,*]]?)
|
||||
let { ctx, simprocs, dischargeWrapper } ←
|
||||
withMainContext <| mkSimpContext stx (eraseLocal := false)
|
||||
let ctx := if unfold.isSome then { ctx with config.autoUnfold := true } else ctx
|
||||
let ctx := if unfold.isSome then ctx.setAutoUnfold else ctx
|
||||
-- TODO: have `simpa` fail if it doesn't use `simp`.
|
||||
let ctx := { ctx with config := { ctx.config with failIfUnchanged := false } }
|
||||
let ctx := ctx.setFailIfUnchanged false
|
||||
dischargeWrapper.with fun discharge? => do
|
||||
let (some (_, g), stats) ← simpGoal (← getMainGoal) ctx (simprocs := simprocs)
|
||||
(simplifyTarget := true) (discharge? := discharge?)
|
||||
|
||||
@@ -25,7 +25,7 @@ def elabSimprocPattern (stx : Syntax) : MetaM Expr := do
|
||||
|
||||
def elabSimprocKeys (stx : Syntax) : MetaM (Array Meta.SimpTheoremKey) := do
|
||||
let pattern ← elabSimprocPattern stx
|
||||
DiscrTree.mkPath pattern simpDtConfig
|
||||
withSimpGlobalConfig <| DiscrTree.mkPath pattern
|
||||
|
||||
def checkSimprocType (declName : Name) : CoreM Bool := do
|
||||
let decl ← getConstInfo declName
|
||||
|
||||
@@ -1298,13 +1298,20 @@ def isTacticOrPostponedHole? (e : Expr) : TermElabM (Option MVarId) := do
|
||||
| _ => return none
|
||||
| _ => pure none
|
||||
|
||||
def mkTermInfo (elaborator : Name) (stx : Syntax) (e : Expr) (expectedType? : Option Expr := none) (lctx? : Option LocalContext := none) (isBinder := false) : TermElabM (Sum Info MVarId) := do
|
||||
def mkTermInfo (elaborator : Name) (stx : Syntax) (e : Expr) (expectedType? : Option Expr := none)
|
||||
(lctx? : Option LocalContext := none) (isBinder := false) :
|
||||
TermElabM (Sum Info MVarId) := do
|
||||
match (← isTacticOrPostponedHole? e) with
|
||||
| some mvarId => return Sum.inr mvarId
|
||||
| none =>
|
||||
let e := removeSaveInfoAnnotation e
|
||||
return Sum.inl <| Info.ofTermInfo { elaborator, lctx := lctx?.getD (← getLCtx), expr := e, stx, expectedType?, isBinder }
|
||||
|
||||
def mkPartialTermInfo (elaborator : Name) (stx : Syntax) (expectedType? : Option Expr := none)
|
||||
(lctx? : Option LocalContext := none) :
|
||||
TermElabM Info := do
|
||||
return Info.ofPartialTermInfo { elaborator, lctx := lctx?.getD (← getLCtx), stx, expectedType? }
|
||||
|
||||
/--
|
||||
Pushes a new leaf node to the info tree associating the expression `e` to the syntax `stx`.
|
||||
As a result, when the user hovers over `stx` they will see the type of `e`, and if `e`
|
||||
@@ -1326,41 +1333,54 @@ def addTermInfo (stx : Syntax) (e : Expr) (expectedType? : Option Expr := none)
|
||||
if (← read).inPattern && !force then
|
||||
return mkPatternWithRef e stx
|
||||
else
|
||||
withInfoContext' (pure ()) (fun _ => mkTermInfo elaborator stx e expectedType? lctx? isBinder) |> discard
|
||||
discard <| withInfoContext'
|
||||
(pure ())
|
||||
(fun _ => mkTermInfo elaborator stx e expectedType? lctx? isBinder)
|
||||
(mkPartialTermInfo elaborator stx expectedType? lctx?)
|
||||
return e
|
||||
|
||||
def addTermInfo' (stx : Syntax) (e : Expr) (expectedType? : Option Expr := none) (lctx? : Option LocalContext := none) (elaborator := Name.anonymous) (isBinder := false) : TermElabM Unit :=
|
||||
discard <| addTermInfo stx e expectedType? lctx? elaborator isBinder
|
||||
|
||||
def withInfoContext' (stx : Syntax) (x : TermElabM Expr) (mkInfo : Expr → TermElabM (Sum Info MVarId)) : TermElabM Expr := do
|
||||
def withInfoContext' (stx : Syntax) (x : TermElabM Expr)
|
||||
(mkInfo : Expr → TermElabM (Sum Info MVarId)) (mkInfoOnError : TermElabM Info) :
|
||||
TermElabM Expr := do
|
||||
if (← read).inPattern then
|
||||
let e ← x
|
||||
return mkPatternWithRef e stx
|
||||
else
|
||||
Elab.withInfoContext' x mkInfo
|
||||
Elab.withInfoContext' x mkInfo mkInfoOnError
|
||||
|
||||
/-- Info node capturing `def/let rec` bodies, used by the unused variables linter. -/
|
||||
structure BodyInfo where
|
||||
/-- The body as a fully elaborated term. -/
|
||||
value : Expr
|
||||
/-- The body as a fully elaborated term. `none` if the body failed to elaborate. -/
|
||||
value? : Option Expr
|
||||
deriving TypeName
|
||||
|
||||
/-- Creates an `Info.ofCustomInfo` node backed by a `BodyInfo`. -/
|
||||
def mkBodyInfo (stx : Syntax) (value : Expr) : Info :=
|
||||
.ofCustomInfo { stx, value := .mk { value : BodyInfo } }
|
||||
def mkBodyInfo (stx : Syntax) (value? : Option Expr) : Info :=
|
||||
.ofCustomInfo { stx, value := .mk { value? : BodyInfo } }
|
||||
|
||||
/-- Extracts a `BodyInfo` custom info. -/
|
||||
def getBodyInfo? : Info → Option BodyInfo
|
||||
| .ofCustomInfo { value, .. } => value.get? BodyInfo
|
||||
| _ => none
|
||||
|
||||
def withTermInfoContext' (elaborator : Name) (stx : Syntax) (x : TermElabM Expr)
|
||||
(expectedType? : Option Expr := none) (lctx? : Option LocalContext := none)
|
||||
(isBinder : Bool := false) :
|
||||
TermElabM Expr :=
|
||||
withInfoContext' stx x
|
||||
(mkTermInfo elaborator stx (expectedType? := expectedType?) (lctx? := lctx?) (isBinder := isBinder))
|
||||
(mkPartialTermInfo elaborator stx (expectedType? := expectedType?) (lctx? := lctx?))
|
||||
|
||||
/--
|
||||
Postpone the elaboration of `stx`, return a metavariable that acts as a placeholder, and
|
||||
ensures the info tree is updated and a hole id is introduced.
|
||||
When `stx` is elaborated, new info nodes are created and attached to the new hole id in the info tree.
|
||||
-/
|
||||
def postponeElabTerm (stx : Syntax) (expectedType? : Option Expr) : TermElabM Expr := do
|
||||
withInfoContext' stx (mkInfo := mkTermInfo .anonymous (expectedType? := expectedType?) stx) do
|
||||
withTermInfoContext' .anonymous stx (expectedType? := expectedType?) do
|
||||
postponeElabTermCore stx expectedType?
|
||||
|
||||
/--
|
||||
@@ -1372,7 +1392,7 @@ private def elabUsingElabFnsAux (s : SavedState) (stx : Syntax) (expectedType? :
|
||||
| (elabFn::elabFns) =>
|
||||
try
|
||||
-- record elaborator in info tree, but only when not backtracking to other elaborators (outer `try`)
|
||||
withInfoContext' stx (mkInfo := mkTermInfo elabFn.declName (expectedType? := expectedType?) stx)
|
||||
withTermInfoContext' elabFn.declName stx (expectedType? := expectedType?)
|
||||
(try
|
||||
elabFn.value stx expectedType?
|
||||
catch ex => match ex with
|
||||
@@ -1755,7 +1775,7 @@ private partial def elabTermAux (expectedType? : Option Expr) (catchExPostpone :
|
||||
let result ← match (← liftMacroM (expandMacroImpl? env stx)) with
|
||||
| some (decl, stxNew?) =>
|
||||
let stxNew ← liftMacroM <| liftExcept stxNew?
|
||||
withInfoContext' stx (mkInfo := mkTermInfo decl (expectedType? := expectedType?) stx) <|
|
||||
withTermInfoContext' decl stx (expectedType? := expectedType?) <|
|
||||
withMacroExpansion stx stxNew <|
|
||||
withRef stxNew <|
|
||||
elabTermAux expectedType? catchExPostpone implicitLambda stxNew
|
||||
|
||||
@@ -599,17 +599,20 @@ def geq (u v : Level) : Bool :=
|
||||
where
|
||||
go (u v : Level) : Bool :=
|
||||
u == v ||
|
||||
let k := fun () =>
|
||||
match v with
|
||||
| imax v₁ v₂ => go u v₁ && go u v₂
|
||||
| _ =>
|
||||
let v' := v.getLevelOffset
|
||||
(u.getLevelOffset == v' || v'.isZero)
|
||||
&& u.getOffset ≥ v.getOffset
|
||||
match u, v with
|
||||
| _, zero => true
|
||||
| u, max v₁ v₂ => go u v₁ && go u v₂
|
||||
| max u₁ u₂, v => go u₁ v || go u₂ v
|
||||
| u, imax v₁ v₂ => go u v₁ && go u v₂
|
||||
| imax _ u₂, v => go u₂ v
|
||||
| succ u, succ v => go u v
|
||||
| _, _ =>
|
||||
let v' := v.getLevelOffset
|
||||
(u.getLevelOffset == v' || v'.isZero)
|
||||
&& u.getOffset ≥ v.getOffset
|
||||
| _, zero => true
|
||||
| u, max v₁ v₂ => go u v₁ && go u v₂
|
||||
| max u₁ u₂, v => go u₁ v || go u₂ v || k ()
|
||||
| imax _ u₂, v => go u₂ v
|
||||
| succ u, succ v => go u v
|
||||
| _, _ => k ()
|
||||
termination_by (u, v)
|
||||
|
||||
end Level
|
||||
|
||||
@@ -393,16 +393,17 @@ where
|
||||
| .ofCustomInfo ti =>
|
||||
if !linter.unusedVariables.analyzeTactics.get ci.options then
|
||||
if let some bodyInfo := ti.value.get? Elab.Term.BodyInfo then
|
||||
-- the body is the only `Expr` we will analyze in this case
|
||||
-- NOTE: we include it even if no tactics are present as at least for parameters we want
|
||||
-- to lint only truly unused binders
|
||||
let (e, _) := instantiateMVarsCore ci.mctx bodyInfo.value
|
||||
modify fun s => { s with
|
||||
assignments := s.assignments.push (.insert {} ⟨.anonymous⟩ e) }
|
||||
let tacticsPresent := children.any (·.findInfo? (· matches .ofTacticInfo ..) |>.isSome)
|
||||
withReader (· || tacticsPresent) do
|
||||
go children.toArray ci
|
||||
return false
|
||||
if let some value := bodyInfo.value? then
|
||||
-- the body is the only `Expr` we will analyze in this case
|
||||
-- NOTE: we include it even if no tactics are present as at least for parameters we want
|
||||
-- to lint only truly unused binders
|
||||
let (e, _) := instantiateMVarsCore ci.mctx value
|
||||
modify fun s => { s with
|
||||
assignments := s.assignments.push (.insert {} ⟨.anonymous⟩ e) }
|
||||
let tacticsPresent := children.any (·.findInfo? (· matches .ofTacticInfo ..) |>.isSome)
|
||||
withReader (· || tacticsPresent) do
|
||||
go children.toArray ci
|
||||
return false
|
||||
| .ofTermInfo ti =>
|
||||
if ignored then return true
|
||||
match ti.expr with
|
||||
|
||||
@@ -116,7 +116,7 @@ variable (p : Name → Bool) in
|
||||
/-- Returns true when the message contains a `MessageData.tagged tag ..` constructor where `p tag`
|
||||
is true.
|
||||
|
||||
This does not descend into lazily generated subtress (`.ofLazy`); message tags
|
||||
This does not descend into lazily generated subtrees (`.ofLazy`); message tags
|
||||
of interest (like those added by `logLinter`) are expected to be near the root
|
||||
of the `MessageData`, and not hidden inside `.ofLazy`.
|
||||
-/
|
||||
@@ -130,6 +130,19 @@ partial def hasTag : MessageData → Bool
|
||||
| trace data msg msgs => p data.cls || hasTag msg || msgs.any hasTag
|
||||
| _ => false
|
||||
|
||||
/--
|
||||
Returns the top-level tag of the message.
|
||||
If none, returns `Name.anonymous`.
|
||||
|
||||
This does not descend into message subtrees (e.g., `.compose`, `.ofLazy`).
|
||||
The message kind is expected to describe the whole message.
|
||||
-/
|
||||
def kind : MessageData → Name
|
||||
| withContext _ msg => kind msg
|
||||
| withNamingContext _ msg => kind msg
|
||||
| tagged n _ => n
|
||||
| _ => .anonymous
|
||||
|
||||
/-- An empty message. -/
|
||||
def nil : MessageData :=
|
||||
ofFormat Format.nil
|
||||
@@ -315,7 +328,7 @@ structure BaseMessage (α : Type u) where
|
||||
endPos : Option Position := none
|
||||
/-- If `true`, report range as given; see `msgToInteractiveDiagnostic`. -/
|
||||
keepFullRange : Bool := false
|
||||
severity : MessageSeverity := MessageSeverity.error
|
||||
severity : MessageSeverity := .error
|
||||
caption : String := ""
|
||||
/-- The content of the message. -/
|
||||
data : α
|
||||
@@ -328,7 +341,10 @@ abbrev Message := BaseMessage MessageData
|
||||
/-- A `SerialMessage` is a `Message` whose `MessageData` has been eagerly
|
||||
serialized and is thus appropriate for use in pure contexts where the effectful
|
||||
`MessageData.toString` cannot be used. -/
|
||||
abbrev SerialMessage := BaseMessage String
|
||||
structure SerialMessage extends BaseMessage String where
|
||||
/-- The message kind (i.e., the top-level tag). -/
|
||||
kind : Name
|
||||
deriving ToJson, FromJson
|
||||
|
||||
namespace SerialMessage
|
||||
|
||||
@@ -354,8 +370,12 @@ end SerialMessage
|
||||
|
||||
namespace Message
|
||||
|
||||
@[inherit_doc MessageData.kind] abbrev kind (msg : Message) :=
|
||||
msg.data.kind
|
||||
|
||||
/-- Serializes the message, converting its data into a string and saving its kind. -/
|
||||
@[inline] def serialize (msg : Message) : IO SerialMessage := do
|
||||
return {msg with data := ← msg.data.toString}
|
||||
return {msg with kind := msg.kind, data := ← msg.data.toString}
|
||||
|
||||
protected def toString (msg : Message) (includeEndPos := false) : IO String := do
|
||||
-- Remark: The inline here avoids a new message allocation when `msg` is shared
|
||||
|
||||
@@ -32,6 +32,9 @@ inductive ReduceMode where
|
||||
| reduceSimpleOnly
|
||||
| none
|
||||
|
||||
private def config : ConfigWithKey :=
|
||||
{ transparency := .reducible, iota := false, proj := .no : Config }.toConfigWithKey
|
||||
|
||||
mutual
|
||||
|
||||
/--
|
||||
@@ -61,8 +64,8 @@ where
|
||||
-- Drawback: cost.
|
||||
return e
|
||||
else match mode with
|
||||
| .reduce => DiscrTree.reduce e {}
|
||||
| .reduceSimpleOnly => DiscrTree.reduce e { iota := false, proj := .no }
|
||||
| .reduce => DiscrTree.reduce e
|
||||
| .reduceSimpleOnly => withConfigWithKey config <| DiscrTree.reduce e
|
||||
| .none => return e
|
||||
|
||||
lt (a b : Expr) : MetaM Bool := do
|
||||
|
||||
@@ -196,13 +196,13 @@ where
|
||||
let packedArg := Unary.pack packedDomain args
|
||||
return e.beta #[packedArg]
|
||||
| [n] => do
|
||||
withLocalDecl n .default domain fun x => do
|
||||
withLocalDeclD n domain fun x => do
|
||||
let dummy := Expr.const ``Unit []
|
||||
mkLambdaFVars #[x] (← go packedDomain dummy (args.push x) [])
|
||||
| n :: ns =>
|
||||
match_expr domain with
|
||||
| PSigma a b =>
|
||||
withLocalDecl n .default a fun x => do
|
||||
withLocalDeclD n a fun x => do
|
||||
mkLambdaFVars #[x] (← go packedDomain (b.beta #[x]) (args.push x) ns)
|
||||
| _ => throwError "curryPSigma: Expected PSigma type, got {domain}"
|
||||
|
||||
@@ -319,7 +319,7 @@ def uncurryType (types : Array Expr) : MetaM Expr := do
|
||||
unless type.isForall do
|
||||
throwError "Mutual.uncurryType: Expected forall type, got {type}"
|
||||
let domain ← packType (types.map (·.bindingDomain!))
|
||||
withLocalDeclD `x domain fun x => do
|
||||
withLocalDeclD (← mkFreshUserName `x) domain fun x => do
|
||||
let codomain ← Mutual.mkCodomain types x
|
||||
mkForallFVars #[x] codomain
|
||||
|
||||
@@ -485,13 +485,14 @@ projects to the `i`th function of type,
|
||||
-/
|
||||
def curryProj (argsPacker : ArgsPacker) (e : Expr) (i : Nat) : MetaM Expr := do
|
||||
let n := argsPacker.numFuncs
|
||||
let packedDomain := (← inferType e).bindingDomain!
|
||||
let t ← inferType e
|
||||
let packedDomain := t.bindingDomain!
|
||||
let unaryTypes ← Mutual.unpackType n packedDomain
|
||||
unless i < unaryTypes.length do
|
||||
throwError "curryProj: index out of range"
|
||||
let unaryType := unaryTypes[i]!
|
||||
-- unary : (x : a ⊗ b) → e[inl x]
|
||||
let unary ← withLocalDecl `x .default unaryType fun x => do
|
||||
let unary ← withLocalDeclD t.bindingName! unaryType fun x => do
|
||||
let packedArg ← Mutual.pack unaryTypes.length packedDomain i x
|
||||
mkLambdaFVars #[x] (e.beta #[packedArg])
|
||||
-- nary : (x : a) → (y : b) → e[inl (x,y)]
|
||||
|
||||
@@ -27,6 +27,51 @@ namespace Lean.Meta
|
||||
|
||||
builtin_initialize isDefEqStuckExceptionId : InternalExceptionId ← registerInternalExceptionId `isDefEqStuck
|
||||
|
||||
def TransparencyMode.toUInt64 : TransparencyMode → UInt64
|
||||
| .all => 0
|
||||
| .default => 1
|
||||
| .reducible => 2
|
||||
| .instances => 3
|
||||
|
||||
def EtaStructMode.toUInt64 : EtaStructMode → UInt64
|
||||
| .all => 0
|
||||
| .notClasses => 1
|
||||
| .none => 2
|
||||
|
||||
/--
|
||||
Configuration for projection reduction. See `whnfCore`.
|
||||
-/
|
||||
inductive ProjReductionKind where
|
||||
/-- Projections `s.i` are not reduced at `whnfCore`. -/
|
||||
| no
|
||||
/--
|
||||
Projections `s.i` are reduced at `whnfCore`, and `whnfCore` is used at `s` during the process.
|
||||
Recall that `whnfCore` does not perform `delta` reduction (i.e., it will not unfold constant declarations).
|
||||
-/
|
||||
| yes
|
||||
/--
|
||||
Projections `s.i` are reduced at `whnfCore`, and `whnf` is used at `s` during the process.
|
||||
Recall that `whnfCore` does not perform `delta` reduction (i.e., it will not unfold constant declarations), but `whnf` does.
|
||||
-/
|
||||
| yesWithDelta
|
||||
/--
|
||||
Projections `s.i` are reduced at `whnfCore`, and `whnfAtMostI` is used at `s` during the process.
|
||||
Recall that `whnfAtMostI` is like `whnf` but uses transparency at most `instances`.
|
||||
This option is stronger than `yes`, but weaker than `yesWithDelta`.
|
||||
We use this option to ensure we reduce projections to prevent expensive defeq checks when unifying TC operations.
|
||||
When unifying e.g. `(@Field.toNeg α inst1).1 =?= (@Field.toNeg α inst2).1`,
|
||||
we only want to unify negation (and not all other field operations as well).
|
||||
Unifying the field instances slowed down unification: https://github.com/leanprover/lean4/issues/1986
|
||||
-/
|
||||
| yesWithDeltaI
|
||||
deriving DecidableEq, Inhabited, Repr
|
||||
|
||||
def ProjReductionKind.toUInt64 : ProjReductionKind → UInt64
|
||||
| .no => 0
|
||||
| .yes => 1
|
||||
| .yesWithDelta => 2
|
||||
| .yesWithDeltaI => 3
|
||||
|
||||
/--
|
||||
Configuration flags for the `MetaM` monad.
|
||||
Many of them are used to control the `isDefEq` function that checks whether two terms are definitionally equal or not.
|
||||
@@ -118,9 +163,64 @@ structure Config where
|
||||
- `max u w =?= mav u ?v` is solved with `?v := w` ignoring the solution `?v := max u w`
|
||||
-/
|
||||
univApprox : Bool := true
|
||||
/-- If `true`, reduce recursor/matcher applications, e.g., `Nat.rec true (fun _ _ => false) Nat.zero` reduces to `true` -/
|
||||
iota : Bool := true
|
||||
/-- If `true`, reduce terms such as `(fun x => t[x]) a` into `t[a]` -/
|
||||
beta : Bool := true
|
||||
/-- Control projection reduction at `whnfCore`. -/
|
||||
proj : ProjReductionKind := .yesWithDelta
|
||||
/--
|
||||
Zeta reduction: `let x := v; e[x]` reduces to `e[v]`.
|
||||
We say a let-declaration `let x := v; e` is non dependent if it is equivalent to `(fun x => e) v`.
|
||||
Recall that
|
||||
```
|
||||
fun x : BitVec 5 => let n := 5; fun y : BitVec n => x = y
|
||||
```
|
||||
is type correct, but
|
||||
```
|
||||
fun x : BitVec 5 => (fun n => fun y : BitVec n => x = y) 5
|
||||
```
|
||||
is not.
|
||||
-/
|
||||
zeta : Bool := true
|
||||
/--
|
||||
Zeta-delta reduction: given a local context containing entry `x : t := e`, free variable `x` reduces to `e`.
|
||||
-/
|
||||
zetaDelta : Bool := true
|
||||
deriving Inhabited
|
||||
|
||||
/-- Convert `isDefEq` and `WHNF` relevant parts into a key for caching results -/
|
||||
private def Config.toKey (c : Config) : UInt64 :=
|
||||
c.transparency.toUInt64 |||
|
||||
(c.foApprox.toUInt64 <<< 2) |||
|
||||
(c.ctxApprox.toUInt64 <<< 3) |||
|
||||
(c.quasiPatternApprox.toUInt64 <<< 4) |||
|
||||
(c.constApprox.toUInt64 <<< 5) |||
|
||||
(c.isDefEqStuckEx.toUInt64 <<< 6) |||
|
||||
(c.unificationHints.toUInt64 <<< 7) |||
|
||||
(c.proofIrrelevance.toUInt64 <<< 8) |||
|
||||
(c.assignSyntheticOpaque.toUInt64 <<< 9) |||
|
||||
(c.offsetCnstrs.toUInt64 <<< 10) |||
|
||||
(c.iota.toUInt64 <<< 11) |||
|
||||
(c.beta.toUInt64 <<< 12) |||
|
||||
(c.zeta.toUInt64 <<< 13) |||
|
||||
(c.zetaDelta.toUInt64 <<< 14) |||
|
||||
(c.univApprox.toUInt64 <<< 15) |||
|
||||
(c.etaStruct.toUInt64 <<< 16) |||
|
||||
(c.proj.toUInt64 <<< 18)
|
||||
|
||||
/-- Configuration with key produced by `Config.toKey`. -/
|
||||
structure ConfigWithKey where
|
||||
private mk ::
|
||||
config : Config
|
||||
key : UInt64
|
||||
deriving Inhabited
|
||||
|
||||
def Config.toConfigWithKey (c : Config) : ConfigWithKey :=
|
||||
{ config := c, key := c.toKey }
|
||||
|
||||
/--
|
||||
Function parameter information cache.
|
||||
Function parameter information cache.
|
||||
-/
|
||||
structure ParamInfo where
|
||||
/-- The binder annotation for the parameter. -/
|
||||
@@ -178,7 +278,6 @@ def ParamInfo.isStrictImplicit (p : ParamInfo) : Bool :=
|
||||
def ParamInfo.isExplicit (p : ParamInfo) : Bool :=
|
||||
p.binderInfo == BinderInfo.default
|
||||
|
||||
|
||||
/--
|
||||
Function information cache. See `ParamInfo`.
|
||||
-/
|
||||
@@ -192,11 +291,12 @@ structure FunInfo where
|
||||
resultDeps : Array Nat := #[]
|
||||
|
||||
/--
|
||||
Key for the function information cache.
|
||||
Key for the function information cache.
|
||||
-/
|
||||
structure InfoCacheKey where
|
||||
/-- The transparency mode used to compute the `FunInfo`. -/
|
||||
transparency : TransparencyMode
|
||||
private mk ::
|
||||
/-- key produced using `Config.toKey`. -/
|
||||
configKey : UInt64
|
||||
/-- The function being cached information about. It is quite often an `Expr.const`. -/
|
||||
expr : Expr
|
||||
/--
|
||||
@@ -207,11 +307,10 @@ structure InfoCacheKey where
|
||||
nargs? : Option Nat
|
||||
deriving Inhabited, BEq
|
||||
|
||||
namespace InfoCacheKey
|
||||
instance : Hashable InfoCacheKey :=
|
||||
⟨fun ⟨transparency, expr, nargs⟩ => mixHash (hash transparency) <| mixHash (hash expr) (hash nargs)⟩
|
||||
end InfoCacheKey
|
||||
instance : Hashable InfoCacheKey where
|
||||
hash := fun { configKey, expr, nargs? } => mixHash (hash configKey) <| mixHash (hash expr) (hash nargs?)
|
||||
|
||||
-- Remark: we don't need to store `Config.toKey` because typeclass resolution uses a fixed configuration.
|
||||
structure SynthInstanceCacheKey where
|
||||
localInsts : LocalInstances
|
||||
type : Expr
|
||||
@@ -231,38 +330,50 @@ structure AbstractMVarsResult where
|
||||
|
||||
abbrev SynthInstanceCache := PersistentHashMap SynthInstanceCacheKey (Option AbstractMVarsResult)
|
||||
|
||||
abbrev InferTypeCache := PersistentExprStructMap Expr
|
||||
-- Key for `InferType` and `WHNF` caches
|
||||
structure ExprConfigCacheKey where
|
||||
private mk ::
|
||||
expr : Expr
|
||||
configKey : UInt64
|
||||
deriving Inhabited
|
||||
|
||||
instance : BEq ExprConfigCacheKey where
|
||||
beq a b :=
|
||||
Expr.equal a.expr b.expr &&
|
||||
a.configKey == b.configKey
|
||||
|
||||
instance : Hashable ExprConfigCacheKey where
|
||||
hash := fun { expr, configKey } => mixHash (hash expr) (hash configKey)
|
||||
|
||||
abbrev InferTypeCache := PersistentHashMap ExprConfigCacheKey Expr
|
||||
abbrev FunInfoCache := PersistentHashMap InfoCacheKey FunInfo
|
||||
abbrev WhnfCache := PersistentExprStructMap Expr
|
||||
abbrev WhnfCache := PersistentHashMap ExprConfigCacheKey Expr
|
||||
|
||||
structure DefEqCacheKey where
|
||||
private mk ::
|
||||
lhs : Expr
|
||||
rhs : Expr
|
||||
configKey : UInt64
|
||||
deriving Inhabited, BEq
|
||||
|
||||
instance : Hashable DefEqCacheKey where
|
||||
hash := fun { lhs, rhs, configKey } => mixHash (hash lhs) <| mixHash (hash rhs) (hash configKey)
|
||||
|
||||
/--
|
||||
A mapping `(s, t) ↦ isDefEq s t` per transparency level.
|
||||
TODO: consider more efficient representations (e.g., a proper set) and caching policies (e.g., imperfect cache).
|
||||
We should also investigate the impact on memory consumption. -/
|
||||
structure DefEqCache where
|
||||
reducible : PersistentHashMap (Expr × Expr) Bool := {}
|
||||
instances : PersistentHashMap (Expr × Expr) Bool := {}
|
||||
default : PersistentHashMap (Expr × Expr) Bool := {}
|
||||
all : PersistentHashMap (Expr × Expr) Bool := {}
|
||||
deriving Inhabited
|
||||
|
||||
/--
|
||||
A cache for `inferType` at transparency levels `.default` an `.all`.
|
||||
A mapping `(s, t) ↦ isDefEq s t`.
|
||||
TODO: consider more efficient representations (e.g., a proper set) and caching policies (e.g., imperfect cache).
|
||||
We should also investigate the impact on memory consumption.
|
||||
-/
|
||||
structure InferTypeCaches where
|
||||
default : InferTypeCache
|
||||
all : InferTypeCache
|
||||
deriving Inhabited
|
||||
abbrev DefEqCache := PersistentHashMap DefEqCacheKey Bool
|
||||
|
||||
/--
|
||||
Cache datastructures for type inference, type class resolution, whnf, and definitional equality.
|
||||
Cache datastructures for type inference, type class resolution, whnf, and definitional equality.
|
||||
-/
|
||||
structure Cache where
|
||||
inferType : InferTypeCaches := ⟨{}, {}⟩
|
||||
inferType : InferTypeCache := {}
|
||||
funInfo : FunInfoCache := {}
|
||||
synthInstance : SynthInstanceCache := {}
|
||||
whnfDefault : WhnfCache := {} -- cache for closed terms and `TransparencyMode.default`
|
||||
whnfAll : WhnfCache := {} -- cache for closed terms and `TransparencyMode.all`
|
||||
whnf : WhnfCache := {}
|
||||
defEqTrans : DefEqCache := {} -- transient cache for terms containing mvars or using nonstandard configuration options, it is frequently reset.
|
||||
defEqPerm : DefEqCache := {} -- permanent cache for terms not containing mvars and using standard configuration options
|
||||
deriving Inhabited
|
||||
@@ -332,7 +443,8 @@ register_builtin_option maxSynthPendingDepth : Nat := {
|
||||
Contextual information for the `MetaM` monad.
|
||||
-/
|
||||
structure Context where
|
||||
config : Config := {}
|
||||
private config : Config := {}
|
||||
private configKey : UInt64 := config.toKey
|
||||
/-- Local context -/
|
||||
lctx : LocalContext := {}
|
||||
/-- Local instances in `lctx`. -/
|
||||
@@ -483,17 +595,27 @@ variable [MonadControlT MetaM n] [Monad n]
|
||||
@[inline] def modifyCache (f : Cache → Cache) : MetaM Unit :=
|
||||
modify fun { mctx, cache, zetaDeltaFVarIds, postponed, diag } => { mctx, cache := f cache, zetaDeltaFVarIds, postponed, diag }
|
||||
|
||||
@[inline] def modifyInferTypeCacheDefault (f : InferTypeCache → InferTypeCache) : MetaM Unit :=
|
||||
modifyCache fun ⟨⟨icd, ica⟩, c1, c2, c3, c4, c5, c6⟩ => ⟨⟨f icd, ica⟩, c1, c2, c3, c4, c5, c6⟩
|
||||
|
||||
@[inline] def modifyInferTypeCacheAll (f : InferTypeCache → InferTypeCache) : MetaM Unit :=
|
||||
modifyCache fun ⟨⟨icd, ica⟩, c1, c2, c3, c4, c5, c6⟩ => ⟨⟨icd, f ica⟩, c1, c2, c3, c4, c5, c6⟩
|
||||
@[inline] def modifyInferTypeCache (f : InferTypeCache → InferTypeCache) : MetaM Unit :=
|
||||
modifyCache fun ⟨ic, c1, c2, c3, c4, c5⟩ => ⟨f ic, c1, c2, c3, c4, c5⟩
|
||||
|
||||
@[inline] def modifyDefEqTransientCache (f : DefEqCache → DefEqCache) : MetaM Unit :=
|
||||
modifyCache fun ⟨c1, c2, c3, c4, c5, defeqTrans, c6⟩ => ⟨c1, c2, c3, c4, c5, f defeqTrans, c6⟩
|
||||
modifyCache fun ⟨c1, c2, c3, c4, defeqTrans, c5⟩ => ⟨c1, c2, c3, c4, f defeqTrans, c5⟩
|
||||
|
||||
@[inline] def modifyDefEqPermCache (f : DefEqCache → DefEqCache) : MetaM Unit :=
|
||||
modifyCache fun ⟨c1, c2, c3, c4, c5, c6, defeqPerm⟩ => ⟨c1, c2, c3, c4, c5, c6, f defeqPerm⟩
|
||||
modifyCache fun ⟨c1, c2, c3, c4, c5, defeqPerm⟩ => ⟨c1, c2, c3, c4, c5, f defeqPerm⟩
|
||||
|
||||
def mkExprConfigCacheKey (expr : Expr) : MetaM ExprConfigCacheKey :=
|
||||
return { expr, configKey := (← read).configKey }
|
||||
|
||||
def mkDefEqCacheKey (lhs rhs : Expr) : MetaM DefEqCacheKey := do
|
||||
let configKey := (← read).configKey
|
||||
if Expr.quickLt lhs rhs then
|
||||
return { lhs, rhs, configKey }
|
||||
else
|
||||
return { lhs := rhs, rhs := lhs, configKey }
|
||||
|
||||
def mkInfoCacheKey (expr : Expr) (nargs? : Option Nat) : MetaM InfoCacheKey :=
|
||||
return { expr, nargs?, configKey := (← read).configKey }
|
||||
|
||||
@[inline] def resetDefEqPermCaches : MetaM Unit :=
|
||||
modifyDefEqPermCache fun _ => {}
|
||||
@@ -538,6 +660,9 @@ def getLocalInstances : MetaM LocalInstances :=
|
||||
def getConfig : MetaM Config :=
|
||||
return (← read).config
|
||||
|
||||
def getConfigWithKey : MetaM ConfigWithKey :=
|
||||
return (← getConfig).toConfigWithKey
|
||||
|
||||
def resetZetaDeltaFVarIds : MetaM Unit :=
|
||||
modify fun s => { s with zetaDeltaFVarIds := {} }
|
||||
|
||||
@@ -941,7 +1066,25 @@ def elimMVarDeps (xs : Array Expr) (e : Expr) (preserveOrder : Bool := false) :
|
||||
|
||||
/-- `withConfig f x` executes `x` using the updated configuration object obtained by applying `f`. -/
|
||||
@[inline] def withConfig (f : Config → Config) : n α → n α :=
|
||||
mapMetaM <| withReader (fun ctx => { ctx with config := f ctx.config })
|
||||
mapMetaM <| withReader fun ctx =>
|
||||
let config := f ctx.config
|
||||
let configKey := config.toKey
|
||||
{ ctx with config, configKey }
|
||||
|
||||
@[inline] def withConfigWithKey (c : ConfigWithKey) : n α → n α :=
|
||||
mapMetaM <| withReader fun ctx =>
|
||||
let config := c.config
|
||||
let configKey := c.key
|
||||
{ ctx with config, configKey }
|
||||
|
||||
@[inline] def withCanUnfoldPred (p : Config → ConstantInfo → CoreM Bool) : n α → n α :=
|
||||
mapMetaM <| withReader (fun ctx => { ctx with canUnfold? := p })
|
||||
|
||||
@[inline] def withIncSynthPending : n α → n α :=
|
||||
mapMetaM <| withReader (fun ctx => { ctx with synthPendingDepth := ctx.synthPendingDepth + 1 })
|
||||
|
||||
@[inline] def withInTypeClassResolution : n α → n α :=
|
||||
mapMetaM <| withReader (fun ctx => { ctx with inTypeClassResolution := true })
|
||||
|
||||
/--
|
||||
Executes `x` tracking zetaDelta reductions `Config.trackZetaDelta := true`
|
||||
@@ -952,8 +1095,15 @@ Executes `x` tracking zetaDelta reductions `Config.trackZetaDelta := true`
|
||||
@[inline] def withoutProofIrrelevance (x : n α) : n α :=
|
||||
withConfig (fun cfg => { cfg with proofIrrelevance := false }) x
|
||||
|
||||
@[inline] private def Context.setTransparency (ctx : Context) (transparency : TransparencyMode) : Context :=
|
||||
let config := { ctx.config with transparency }
|
||||
-- Recall that `transparency` is stored in the first 2 bits
|
||||
let configKey : UInt64 := ((ctx.configKey >>> (2 : UInt64)) <<< 2) ||| transparency.toUInt64
|
||||
{ ctx with config, configKey }
|
||||
|
||||
@[inline] def withTransparency (mode : TransparencyMode) : n α → n α :=
|
||||
withConfig (fun config => { config with transparency := mode })
|
||||
-- We avoid `withConfig` for performance reasons.
|
||||
mapMetaM <| withReader (·.setTransparency mode)
|
||||
|
||||
/-- `withDefault x` executes `x` using the default transparency setting. -/
|
||||
@[inline] def withDefault (x : n α) : n α :=
|
||||
@@ -974,13 +1124,10 @@ or type class instances are unfolded.
|
||||
Execute `x` ensuring the transparency setting is at least `mode`.
|
||||
Recall that `.all > .default > .instances > .reducible`.
|
||||
-/
|
||||
@[inline] def withAtLeastTransparency (mode : TransparencyMode) (x : n α) : n α :=
|
||||
withConfig
|
||||
(fun config =>
|
||||
let oldMode := config.transparency
|
||||
let mode := if oldMode.lt mode then mode else oldMode
|
||||
{ config with transparency := mode })
|
||||
x
|
||||
@[inline] def withAtLeastTransparency (mode : TransparencyMode) : n α → n α :=
|
||||
mapMetaM <| withReader fun ctx =>
|
||||
let modeOld := ctx.config.transparency
|
||||
ctx.setTransparency <| if modeOld.lt mode then mode else modeOld
|
||||
|
||||
/-- Execute `x` allowing `isDefEq` to assign synthetic opaque metavariables. -/
|
||||
@[inline] def withAssignableSyntheticOpaque (x : n α) : n α :=
|
||||
@@ -1002,8 +1149,8 @@ def getTheoremInfo (info : ConstantInfo) : MetaM (Option ConstantInfo) := do
|
||||
|
||||
private def getDefInfoTemp (info : ConstantInfo) : MetaM (Option ConstantInfo) := do
|
||||
match (← getTransparency) with
|
||||
| TransparencyMode.all => return some info
|
||||
| TransparencyMode.default => return some info
|
||||
| .all => return some info
|
||||
| .default => return some info
|
||||
| _ =>
|
||||
if (← isReducible info.name) then
|
||||
return some info
|
||||
@@ -1422,6 +1569,14 @@ def withLocalDecl (name : Name) (bi : BinderInfo) (type : Expr) (k : Expr → n
|
||||
def withLocalDeclD (name : Name) (type : Expr) (k : Expr → n α) : n α :=
|
||||
withLocalDecl name BinderInfo.default type k
|
||||
|
||||
/--
|
||||
Similar to `withLocalDecl`, but it does **not** check whether the new variable is a local instance or not.
|
||||
-/
|
||||
def withLocalDeclNoLocalInstanceUpdate (name : Name) (bi : BinderInfo) (type : Expr) (x : Expr → MetaM α) : MetaM α := do
|
||||
let fvarId ← mkFreshFVarId
|
||||
withReader (fun ctx => { ctx with lctx := ctx.lctx.mkLocalDecl fvarId name type bi }) do
|
||||
x (mkFVar fvarId)
|
||||
|
||||
/-- Append an array of free variables `xs` to the local context and execute `k xs`.
|
||||
`declInfos` takes the form of an array consisting of:
|
||||
- the name of the variable
|
||||
@@ -1538,11 +1693,11 @@ def withReplaceFVarId {α} (fvarId : FVarId) (e : Expr) : MetaM α → MetaM α
|
||||
localInstances := ctx.localInstances.erase fvarId }
|
||||
|
||||
/--
|
||||
`withNewMCtxDepth k` executes `k` with a higher metavariable context depth,
|
||||
where metavariables created outside the `withNewMCtxDepth` (with a lower depth) cannot be assigned.
|
||||
If `allowLevelAssignments` is set to true, then the level metavariable depth
|
||||
is not increased, and level metavariables from the outer scope can be
|
||||
assigned. (This is used by TC synthesis.)
|
||||
`withNewMCtxDepth k` executes `k` with a higher metavariable context depth,
|
||||
where metavariables created outside the `withNewMCtxDepth` (with a lower depth) cannot be assigned.
|
||||
If `allowLevelAssignments` is set to true, then the level metavariable depth
|
||||
is not increased, and level metavariables from the outer scope can be
|
||||
assigned. (This is used by TC synthesis.)
|
||||
-/
|
||||
def withNewMCtxDepth (k : n α) (allowLevelAssignments := false) : n α :=
|
||||
mapMetaM (withNewMCtxDepthImp allowLevelAssignments) k
|
||||
@@ -1552,13 +1707,20 @@ private def withLocalContextImp (lctx : LocalContext) (localInsts : LocalInstanc
|
||||
x
|
||||
|
||||
/--
|
||||
`withLCtx lctx localInsts k` replaces the local context and local instances, and then executes `k`.
|
||||
The local context and instances are restored after executing `k`.
|
||||
This method assumes that the local instances in `localInsts` are in the local context `lctx`.
|
||||
`withLCtx lctx localInsts k` replaces the local context and local instances, and then executes `k`.
|
||||
The local context and instances are restored after executing `k`.
|
||||
This method assumes that the local instances in `localInsts` are in the local context `lctx`.
|
||||
-/
|
||||
def withLCtx (lctx : LocalContext) (localInsts : LocalInstances) : n α → n α :=
|
||||
mapMetaM <| withLocalContextImp lctx localInsts
|
||||
|
||||
/--
|
||||
Simpler version of `withLCtx` which just updates the local context. It is the resposability of the
|
||||
caller ensure the local instances are also properly updated.
|
||||
-/
|
||||
def withLCtx' (lctx : LocalContext) : n α → n α :=
|
||||
mapMetaM <| withReader (fun ctx => { ctx with lctx })
|
||||
|
||||
/--
|
||||
Runs `k` in a local environment with the `fvarIds` erased.
|
||||
-/
|
||||
|
||||
@@ -91,7 +91,15 @@ private partial def mkKey (e : Expr) : CanonM UInt64 := do
|
||||
let eNew ← instantiateMVars e
|
||||
unless eNew == e do
|
||||
return (← mkKey eNew)
|
||||
let info ← getFunInfo f
|
||||
let info ← if f.hasLooseBVars then
|
||||
-- If `f` has loose bound variables, `getFunInfo` will fail.
|
||||
-- This can only happen if `f` contains local variables.
|
||||
-- Instead we use an empty `FunInfo`, which results in the
|
||||
-- `i < info.paramInfo.size` check below failing for all indices,
|
||||
-- and hence mixing in the hash for all arguments.
|
||||
pure {}
|
||||
else
|
||||
getFunInfo f
|
||||
let mut k ← mkKey f
|
||||
for i in [:e.getAppNumArgs] do
|
||||
if h : i < info.paramInfo.size then
|
||||
@@ -101,10 +109,13 @@ private partial def mkKey (e : Expr) : CanonM UInt64 := do
|
||||
else
|
||||
k := mixHash k (← mkKey (e.getArg! i))
|
||||
return k
|
||||
| .lam _ t b _
|
||||
| .forallE _ t b _ =>
|
||||
| .lam n t b bi
|
||||
| .forallE n t b bi =>
|
||||
-- Note that we do not use `withLocalDecl` here, for performance reasons.
|
||||
-- Instead we have a guard for loose bound variables in the `.app` case above.
|
||||
return mixHash (← mkKey t) (← mkKey b)
|
||||
| .letE _ _ v b _ =>
|
||||
| .letE n t v b _ =>
|
||||
-- Similarly, we do not use `withLetDecl` here.
|
||||
return mixHash (← mkKey v) (← mkKey b)
|
||||
| .proj _ i s =>
|
||||
return mixHash i.toUInt64 (← mkKey s)
|
||||
@@ -124,11 +135,11 @@ def canon (e : Expr) : CanonM Expr := do
|
||||
if (← isDefEq e e') then
|
||||
return e'
|
||||
-- `e` is not definitionally equal to any expression in `es'`. We claim this should be rare.
|
||||
unsafe modify fun { cache, keyToExprs } => { cache, keyToExprs := keyToExprs.insert k (e :: es') }
|
||||
modify fun { cache, keyToExprs } => { cache, keyToExprs := keyToExprs.insert k (e :: es') }
|
||||
return e
|
||||
else
|
||||
-- `e` is the first expression we found with key `k`.
|
||||
unsafe modify fun { cache, keyToExprs } => { cache, keyToExprs := keyToExprs.insert k [e] }
|
||||
modify fun { cache, keyToExprs } => { cache, keyToExprs := keyToExprs.insert k [e] }
|
||||
return e
|
||||
|
||||
end Canonicalizer
|
||||
|
||||
@@ -157,9 +157,11 @@ def coerceMonadLift? (e expectedType : Expr) : MetaM (Option Expr) := do
|
||||
let eType ← instantiateMVars (← inferType e)
|
||||
let some (n, β) ← isTypeApp? expectedType | return none
|
||||
let some (m, α) ← isTypeApp? eType | return none
|
||||
-- Need to save and restore the state in case `m` and `n` are defeq but not monads to prevent this procedure from having side effects.
|
||||
let saved ← saveState
|
||||
if (← isDefEq m n) then
|
||||
let some monadInst ← isMonad? n | return none
|
||||
try expandCoe (← mkAppOptM ``Lean.Internal.coeM #[m, α, β, none, monadInst, e]) catch _ => return none
|
||||
let some monadInst ← isMonad? n | restoreState saved; return none
|
||||
try expandCoe (← mkAppOptM ``Lean.Internal.coeM #[m, α, β, none, monadInst, e]) catch _ => restoreState saved; return none
|
||||
else if autoLift.get (← getOptions) then
|
||||
try
|
||||
-- Construct lift from `m` to `n`
|
||||
|
||||
@@ -305,16 +305,13 @@ def hasNoindexAnnotation (e : Expr) : Bool :=
|
||||
|
||||
/--
|
||||
Reduction procedure for the discrimination tree indexing.
|
||||
The parameter `config` controls how aggressively the term is reduced.
|
||||
The parameter at type `DiscrTree` controls this value.
|
||||
See comment at `DiscrTree`.
|
||||
-/
|
||||
partial def reduce (e : Expr) (config : WhnfCoreConfig) : MetaM Expr := do
|
||||
let e ← whnfCore e config
|
||||
partial def reduce (e : Expr) : MetaM Expr := do
|
||||
let e ← whnfCore e
|
||||
match (← unfoldDefinition? e) with
|
||||
| some e => reduce e config
|
||||
| some e => reduce e
|
||||
| none => match e.etaExpandedStrict? with
|
||||
| some e => reduce e config
|
||||
| some e => reduce e
|
||||
| none => return e
|
||||
|
||||
/--
|
||||
@@ -333,24 +330,24 @@ private def isBadKey (fn : Expr) : Bool :=
|
||||
| _ => true
|
||||
|
||||
/--
|
||||
Reduce `e` until we get an irreducible term (modulo current reducibility setting) or the resulting term
|
||||
is a bad key (see comment at `isBadKey`).
|
||||
We use this method instead of `reduce` for root terms at `pushArgs`. -/
|
||||
private partial def reduceUntilBadKey (e : Expr) (config : WhnfCoreConfig) : MetaM Expr := do
|
||||
Reduce `e` until we get an irreducible term (modulo current reducibility setting) or the resulting term
|
||||
is a bad key (see comment at `isBadKey`).
|
||||
We use this method instead of `reduce` for root terms at `pushArgs`. -/
|
||||
private partial def reduceUntilBadKey (e : Expr) : MetaM Expr := do
|
||||
let e ← step e
|
||||
match e.etaExpandedStrict? with
|
||||
| some e => reduceUntilBadKey e config
|
||||
| some e => reduceUntilBadKey e
|
||||
| none => return e
|
||||
where
|
||||
step (e : Expr) := do
|
||||
let e ← whnfCore e config
|
||||
let e ← whnfCore e
|
||||
match (← unfoldDefinition? e) with
|
||||
| some e' => if isBadKey e'.getAppFn then return e else step e'
|
||||
| none => return e
|
||||
|
||||
/-- whnf for the discrimination tree module -/
|
||||
def reduceDT (e : Expr) (root : Bool) (config : WhnfCoreConfig) : MetaM Expr :=
|
||||
if root then reduceUntilBadKey e config else reduce e config
|
||||
def reduceDT (e : Expr) (root : Bool) : MetaM Expr :=
|
||||
if root then reduceUntilBadKey e else reduce e
|
||||
|
||||
/- Remark: we use `shouldAddAsStar` only for nested terms, and `root == false` for nested terms -/
|
||||
|
||||
@@ -372,11 +369,11 @@ In this issue, we have a local hypotheses `(h : ∀ p : α × β, f p p.2 = p.2)
|
||||
For example, it was introduced by another tactic. Thus, when populating the discrimination tree explicit arguments provided to `simp` (e.g., `simp [h]`),
|
||||
we use `noIndexAtArgs := true`. See comment: https://github.com/leanprover/lean4/issues/2670#issuecomment-1758889365
|
||||
-/
|
||||
private def pushArgs (root : Bool) (todo : Array Expr) (e : Expr) (config : WhnfCoreConfig) (noIndexAtArgs : Bool) : MetaM (Key × Array Expr) := do
|
||||
private def pushArgs (root : Bool) (todo : Array Expr) (e : Expr) (noIndexAtArgs : Bool) : MetaM (Key × Array Expr) := do
|
||||
if hasNoindexAnnotation e then
|
||||
return (.star, todo)
|
||||
else
|
||||
let e ← reduceDT e root config
|
||||
let e ← reduceDT e root
|
||||
let fn := e.getAppFn
|
||||
let push (k : Key) (nargs : Nat) (todo : Array Expr): MetaM (Key × Array Expr) := do
|
||||
let info ← getFunInfoNArgs fn nargs
|
||||
@@ -422,23 +419,23 @@ private def pushArgs (root : Bool) (todo : Array Expr) (e : Expr) (config : Whnf
|
||||
| _ => return (.other, todo)
|
||||
|
||||
@[inherit_doc pushArgs]
|
||||
partial def mkPathAux (root : Bool) (todo : Array Expr) (keys : Array Key) (config : WhnfCoreConfig) (noIndexAtArgs : Bool) : MetaM (Array Key) := do
|
||||
partial def mkPathAux (root : Bool) (todo : Array Expr) (keys : Array Key) (noIndexAtArgs : Bool) : MetaM (Array Key) := do
|
||||
if todo.isEmpty then
|
||||
return keys
|
||||
else
|
||||
let e := todo.back!
|
||||
let todo := todo.pop
|
||||
let (k, todo) ← pushArgs root todo e config noIndexAtArgs
|
||||
mkPathAux false todo (keys.push k) config noIndexAtArgs
|
||||
let (k, todo) ← pushArgs root todo e noIndexAtArgs
|
||||
mkPathAux false todo (keys.push k) noIndexAtArgs
|
||||
|
||||
private def initCapacity := 8
|
||||
|
||||
@[inherit_doc pushArgs]
|
||||
def mkPath (e : Expr) (config : WhnfCoreConfig) (noIndexAtArgs := false) : MetaM (Array Key) := do
|
||||
def mkPath (e : Expr) (noIndexAtArgs := false) : MetaM (Array Key) := do
|
||||
withReducible do
|
||||
let todo : Array Expr := .mkEmpty initCapacity
|
||||
let keys : Array Key := .mkEmpty initCapacity
|
||||
mkPathAux (root := true) (todo.push e) keys config noIndexAtArgs
|
||||
mkPathAux (root := true) (todo.push e) keys noIndexAtArgs
|
||||
|
||||
private partial def createNodes (keys : Array Key) (v : α) (i : Nat) : Trie α :=
|
||||
if h : i < keys.size then
|
||||
@@ -492,23 +489,23 @@ def insertCore [BEq α] (d : DiscrTree α) (keys : Array Key) (v : α) : DiscrTr
|
||||
let c := insertAux keys v 1 c
|
||||
{ root := d.root.insert k c }
|
||||
|
||||
def insert [BEq α] (d : DiscrTree α) (e : Expr) (v : α) (config : WhnfCoreConfig) (noIndexAtArgs := false) : MetaM (DiscrTree α) := do
|
||||
let keys ← mkPath e config noIndexAtArgs
|
||||
def insert [BEq α] (d : DiscrTree α) (e : Expr) (v : α) (noIndexAtArgs := false) : MetaM (DiscrTree α) := do
|
||||
let keys ← mkPath e noIndexAtArgs
|
||||
return d.insertCore keys v
|
||||
|
||||
/--
|
||||
Inserts a value into a discrimination tree,
|
||||
but only if its key is not of the form `#[*]` or `#[=, *, *, *]`.
|
||||
-/
|
||||
def insertIfSpecific [BEq α] (d : DiscrTree α) (e : Expr) (v : α) (config : WhnfCoreConfig) (noIndexAtArgs := false) : MetaM (DiscrTree α) := do
|
||||
let keys ← mkPath e config noIndexAtArgs
|
||||
def insertIfSpecific [BEq α] (d : DiscrTree α) (e : Expr) (v : α) (noIndexAtArgs := false) : MetaM (DiscrTree α) := do
|
||||
let keys ← mkPath e noIndexAtArgs
|
||||
return if keys == #[Key.star] || keys == #[Key.const `Eq 3, Key.star, Key.star, Key.star] then
|
||||
d
|
||||
else
|
||||
d.insertCore keys v
|
||||
|
||||
private def getKeyArgs (e : Expr) (isMatch root : Bool) (config : WhnfCoreConfig) : MetaM (Key × Array Expr) := do
|
||||
let e ← reduceDT e root config
|
||||
private def getKeyArgs (e : Expr) (isMatch root : Bool) : MetaM (Key × Array Expr) := do
|
||||
let e ← reduceDT e root
|
||||
unless root do
|
||||
-- See pushArgs
|
||||
if let some v := toNatLit? e then
|
||||
@@ -553,8 +550,8 @@ private def getKeyArgs (e : Expr) (isMatch root : Bool) (config : WhnfCoreConfig
|
||||
if isMatch then
|
||||
return (.other, #[])
|
||||
else do
|
||||
let ctx ← read
|
||||
if ctx.config.isDefEqStuckEx then
|
||||
let cfg ← getConfig
|
||||
if cfg.isDefEqStuckEx then
|
||||
/-
|
||||
When the configuration flag `isDefEqStuckEx` is set to true,
|
||||
we want `isDefEq` to throw an exception whenever it tries to assign
|
||||
@@ -580,11 +577,11 @@ private def getKeyArgs (e : Expr) (isMatch root : Bool) (config : WhnfCoreConfig
|
||||
| .forallE _ d _ _ => return (.arrow, #[d])
|
||||
| _ => return (.other, #[])
|
||||
|
||||
private abbrev getMatchKeyArgs (e : Expr) (root : Bool) (config : WhnfCoreConfig) : MetaM (Key × Array Expr) :=
|
||||
getKeyArgs e (isMatch := true) (root := root) (config := config)
|
||||
private abbrev getMatchKeyArgs (e : Expr) (root : Bool) : MetaM (Key × Array Expr) :=
|
||||
getKeyArgs e (isMatch := true) (root := root)
|
||||
|
||||
private abbrev getUnifyKeyArgs (e : Expr) (root : Bool) (config : WhnfCoreConfig) : MetaM (Key × Array Expr) :=
|
||||
getKeyArgs e (isMatch := false) (root := root) (config := config)
|
||||
private abbrev getUnifyKeyArgs (e : Expr) (root : Bool) : MetaM (Key × Array Expr) :=
|
||||
getKeyArgs e (isMatch := false) (root := root)
|
||||
|
||||
private def getStarResult (d : DiscrTree α) : Array α :=
|
||||
let result : Array α := .mkEmpty initCapacity
|
||||
@@ -595,7 +592,7 @@ private def getStarResult (d : DiscrTree α) : Array α :=
|
||||
private abbrev findKey (cs : Array (Key × Trie α)) (k : Key) : Option (Key × Trie α) :=
|
||||
cs.binSearch (k, default) (fun a b => a.1 < b.1)
|
||||
|
||||
private partial def getMatchLoop (todo : Array Expr) (c : Trie α) (result : Array α) (config : WhnfCoreConfig) : MetaM (Array α) := do
|
||||
private partial def getMatchLoop (todo : Array Expr) (c : Trie α) (result : Array α) : MetaM (Array α) := do
|
||||
match c with
|
||||
| .node vs cs =>
|
||||
if todo.isEmpty then
|
||||
@@ -606,48 +603,48 @@ private partial def getMatchLoop (todo : Array Expr) (c : Trie α) (result : Arr
|
||||
let e := todo.back!
|
||||
let todo := todo.pop
|
||||
let first := cs[0]! /- Recall that `Key.star` is the minimal key -/
|
||||
let (k, args) ← getMatchKeyArgs e (root := false) config
|
||||
let (k, args) ← getMatchKeyArgs e (root := false)
|
||||
/- We must always visit `Key.star` edges since they are wildcards.
|
||||
Thus, `todo` is not used linearly when there is `Key.star` edge
|
||||
and there is an edge for `k` and `k != Key.star`. -/
|
||||
let visitStar (result : Array α) : MetaM (Array α) :=
|
||||
if first.1 == .star then
|
||||
getMatchLoop todo first.2 result config
|
||||
getMatchLoop todo first.2 result
|
||||
else
|
||||
return result
|
||||
let visitNonStar (k : Key) (args : Array Expr) (result : Array α) : MetaM (Array α) :=
|
||||
match findKey cs k with
|
||||
| none => return result
|
||||
| some c => getMatchLoop (todo ++ args) c.2 result config
|
||||
| some c => getMatchLoop (todo ++ args) c.2 result
|
||||
let result ← visitStar result
|
||||
match k with
|
||||
| .star => return result
|
||||
| _ => visitNonStar k args result
|
||||
|
||||
private def getMatchRoot (d : DiscrTree α) (k : Key) (args : Array Expr) (result : Array α) (config : WhnfCoreConfig) : MetaM (Array α) :=
|
||||
private def getMatchRoot (d : DiscrTree α) (k : Key) (args : Array Expr) (result : Array α) : MetaM (Array α) :=
|
||||
match d.root.find? k with
|
||||
| none => return result
|
||||
| some c => getMatchLoop args c result config
|
||||
| some c => getMatchLoop args c result
|
||||
|
||||
private def getMatchCore (d : DiscrTree α) (e : Expr) (config : WhnfCoreConfig) : MetaM (Key × Array α) :=
|
||||
private def getMatchCore (d : DiscrTree α) (e : Expr) : MetaM (Key × Array α) :=
|
||||
withReducible do
|
||||
let result := getStarResult d
|
||||
let (k, args) ← getMatchKeyArgs e (root := true) config
|
||||
let (k, args) ← getMatchKeyArgs e (root := true)
|
||||
match k with
|
||||
| .star => return (k, result)
|
||||
| _ => return (k, (← getMatchRoot d k args result config))
|
||||
| _ => return (k, (← getMatchRoot d k args result))
|
||||
|
||||
/--
|
||||
Find values that match `e` in `d`.
|
||||
-/
|
||||
def getMatch (d : DiscrTree α) (e : Expr) (config : WhnfCoreConfig) : MetaM (Array α) :=
|
||||
return (← getMatchCore d e config).2
|
||||
def getMatch (d : DiscrTree α) (e : Expr) : MetaM (Array α) :=
|
||||
return (← getMatchCore d e).2
|
||||
|
||||
/--
|
||||
Similar to `getMatch`, but returns solutions that are prefixes of `e`.
|
||||
We store the number of ignored arguments in the result.-/
|
||||
partial def getMatchWithExtra (d : DiscrTree α) (e : Expr) (config : WhnfCoreConfig) : MetaM (Array (α × Nat)) := do
|
||||
let (k, result) ← getMatchCore d e config
|
||||
partial def getMatchWithExtra (d : DiscrTree α) (e : Expr) : MetaM (Array (α × Nat)) := do
|
||||
let (k, result) ← getMatchCore d e
|
||||
let result := result.map (·, 0)
|
||||
if !e.isApp then
|
||||
return result
|
||||
@@ -669,7 +666,7 @@ where
|
||||
| _ => return false
|
||||
|
||||
go (e : Expr) (numExtra : Nat) (result : Array (α × Nat)) : MetaM (Array (α × Nat)) := do
|
||||
let result := result ++ (← getMatchCore d e config).2.map (., numExtra)
|
||||
let result := result ++ (← getMatchCore d e).2.map (., numExtra)
|
||||
if e.isApp then
|
||||
go e.appFn! (numExtra + 1) result
|
||||
else
|
||||
@@ -678,8 +675,8 @@ where
|
||||
/--
|
||||
Return the root symbol for `e`, and the number of arguments after `reduceDT`.
|
||||
-/
|
||||
def getMatchKeyRootFor (e : Expr) (config : WhnfCoreConfig) : MetaM (Key × Nat) := do
|
||||
let e ← reduceDT e (root := true) config
|
||||
def getMatchKeyRootFor (e : Expr) : MetaM (Key × Nat) := do
|
||||
let e ← reduceDT e (root := true)
|
||||
let numArgs := e.getAppNumArgs
|
||||
let key := match e.getAppFn with
|
||||
| .lit v => .lit v
|
||||
@@ -716,17 +713,17 @@ We use this method to simulate Lean 3's indexing.
|
||||
|
||||
The natural number in the result is the number of arguments in `e` after `reduceDT`.
|
||||
-/
|
||||
def getMatchLiberal (d : DiscrTree α) (e : Expr) (config : WhnfCoreConfig) : MetaM (Array α × Nat) := do
|
||||
def getMatchLiberal (d : DiscrTree α) (e : Expr) : MetaM (Array α × Nat) := do
|
||||
withReducible do
|
||||
let result := getStarResult d
|
||||
let (k, numArgs) ← getMatchKeyRootFor e config
|
||||
let (k, numArgs) ← getMatchKeyRootFor e
|
||||
match k with
|
||||
| .star => return (result, numArgs)
|
||||
| _ => return (getAllValuesForKey d k result, numArgs)
|
||||
|
||||
partial def getUnify (d : DiscrTree α) (e : Expr) (config : WhnfCoreConfig) : MetaM (Array α) :=
|
||||
partial def getUnify (d : DiscrTree α) (e : Expr) : MetaM (Array α) :=
|
||||
withReducible do
|
||||
let (k, args) ← getUnifyKeyArgs e (root := true) config
|
||||
let (k, args) ← getUnifyKeyArgs e (root := true)
|
||||
match k with
|
||||
| .star => d.root.foldlM (init := #[]) fun result k c => process k.arity #[] c result
|
||||
| _ =>
|
||||
@@ -750,7 +747,7 @@ where
|
||||
else
|
||||
let e := todo.back!
|
||||
let todo := todo.pop
|
||||
let (k, args) ← getUnifyKeyArgs e (root := false) config
|
||||
let (k, args) ← getUnifyKeyArgs e (root := false)
|
||||
let visitStar (result : Array α) : MetaM (Array α) :=
|
||||
let first := cs[0]!
|
||||
if first.1 == .star then
|
||||
|
||||
@@ -364,7 +364,7 @@ private partial def isDefEqBindingAux (lctx : LocalContext) (fvars : Array Expr)
|
||||
| Expr.forallE n d₁ b₁ _, Expr.forallE _ d₂ b₂ _ => process n d₁ d₂ b₁ b₂
|
||||
| Expr.lam n d₁ b₁ _, Expr.lam _ d₂ b₂ _ => process n d₁ d₂ b₁ b₂
|
||||
| _, _ =>
|
||||
withReader (fun ctx => { ctx with lctx := lctx }) do
|
||||
withLCtx' lctx do
|
||||
isDefEqBindingDomain fvars ds₂ do
|
||||
Meta.isExprDefEqAux (e₁.instantiateRev fvars) (e₂.instantiateRev fvars)
|
||||
|
||||
@@ -758,8 +758,8 @@ mutual
|
||||
if mvarDecl.depth != (← getMCtx).depth || mvarDecl.kind.isSyntheticOpaque then
|
||||
traceM `Meta.isDefEq.assign.readOnlyMVarWithBiggerLCtx <| addAssignmentInfo (mkMVar mvarId)
|
||||
throwCheckAssignmentFailure
|
||||
let ctxMeta ← readThe Meta.Context
|
||||
unless ctxMeta.config.ctxApprox && ctx.mvarDecl.lctx.isSubPrefixOf mvarDecl.lctx do
|
||||
let cfg ← getConfig
|
||||
unless cfg.ctxApprox && ctx.mvarDecl.lctx.isSubPrefixOf mvarDecl.lctx do
|
||||
traceM `Meta.isDefEq.assign.readOnlyMVarWithBiggerLCtx <| addAssignmentInfo (mkMVar mvarId)
|
||||
throwCheckAssignmentFailure
|
||||
/- Create an auxiliary metavariable with a smaller context and "checked" type.
|
||||
@@ -814,8 +814,8 @@ mutual
|
||||
|
||||
partial def checkApp (e : Expr) : CheckAssignmentM Expr :=
|
||||
e.withApp fun f args => do
|
||||
let ctxMeta ← readThe Meta.Context
|
||||
if f.isMVar && ctxMeta.config.ctxApprox && args.all Expr.isFVar then
|
||||
let cfg ← getConfig
|
||||
if f.isMVar && cfg.ctxApprox && args.all Expr.isFVar then
|
||||
let f ← check f
|
||||
catchInternalId outOfScopeExceptionId
|
||||
(do
|
||||
@@ -1387,15 +1387,21 @@ private abbrev unfold (e : Expr) (failK : MetaM α) (successK : Expr → MetaM
|
||||
/-- Auxiliary method for isDefEqDelta -/
|
||||
private def unfoldBothDefEq (fn : Name) (t s : Expr) : MetaM LBool := do
|
||||
match t, s with
|
||||
| Expr.const _ ls₁, Expr.const _ ls₂ => isListLevelDefEq ls₁ ls₂
|
||||
| Expr.app _ _, Expr.app _ _ =>
|
||||
| .const _ ls₁, .const _ ls₂ =>
|
||||
match (← isListLevelDefEq ls₁ ls₂) with
|
||||
| .true => return .true
|
||||
| _ =>
|
||||
unfold t (pure .undef) fun t =>
|
||||
unfold s (pure .undef) fun s =>
|
||||
isDefEqLeftRight fn t s
|
||||
| .app _ _, .app _ _ =>
|
||||
if (← tryHeuristic t s) then
|
||||
pure LBool.true
|
||||
return .true
|
||||
else
|
||||
unfold t
|
||||
(unfold s (pure LBool.undef) (fun s => isDefEqRight fn t s))
|
||||
(unfold s (pure .undef) fun s => isDefEqRight fn t s)
|
||||
(fun t => unfold s (isDefEqLeft fn t s) (fun s => isDefEqLeftRight fn t s))
|
||||
| _, _ => pure LBool.false
|
||||
| _, _ => return .false
|
||||
|
||||
private def sameHeadSymbol (t s : Expr) : Bool :=
|
||||
match t.getAppFn, s.getAppFn with
|
||||
@@ -1674,11 +1680,12 @@ private partial def isDefEqQuick (t s : Expr) : MetaM LBool :=
|
||||
-- | Expr.mdata _ t _, s => isDefEqQuick t s
|
||||
-- | t, Expr.mdata _ s _ => isDefEqQuick t s
|
||||
| .fvar fvarId₁, .fvar fvarId₂ => do
|
||||
if (← fvarId₁.isLetVar <||> fvarId₂.isLetVar) then
|
||||
return LBool.undef
|
||||
else if fvarId₁ == fvarId₂ then
|
||||
return LBool.true
|
||||
if fvarId₁ == fvarId₂ then
|
||||
return .true
|
||||
else if (← fvarId₁.isLetVar <||> fvarId₂.isLetVar) then
|
||||
return .undef
|
||||
else
|
||||
-- If `t` and `s` are not proofs or let-variables, we still return `.undef` and let other rules (e.g., unit-like) kick in.
|
||||
isDefEqProofIrrel t s
|
||||
| t, s =>
|
||||
isDefEqQuickOther t s
|
||||
@@ -1794,8 +1801,8 @@ private partial def isDefEqQuickOther (t s : Expr) : MetaM LBool := do
|
||||
| LBool.true => return LBool.true
|
||||
| LBool.false => return LBool.false
|
||||
| _ =>
|
||||
let ctx ← read
|
||||
if ctx.config.isDefEqStuckEx then do
|
||||
let cfg ← getConfig
|
||||
if cfg.isDefEqStuckEx then do
|
||||
trace[Meta.isDefEq.stuck] "{t} =?= {s}"
|
||||
Meta.throwIsDefEqStuck
|
||||
else
|
||||
@@ -1834,7 +1841,7 @@ end
|
||||
let e ← instantiateMVars e
|
||||
successK e
|
||||
else
|
||||
if (← read).config.isDefEqStuckEx then
|
||||
if (← getConfig).isDefEqStuckEx then
|
||||
/-
|
||||
When `isDefEqStuckEx := true` and `mvar` was created in a previous level,
|
||||
we should throw an exception. See issue #2736 for a situation where this can happen.
|
||||
@@ -2079,50 +2086,37 @@ Structure for storing defeq cache key information.
|
||||
-/
|
||||
structure DefEqCacheKeyInfo where
|
||||
kind : DefEqCacheKind
|
||||
key : Expr × Expr
|
||||
key : DefEqCacheKey
|
||||
|
||||
private def mkCacheKey (t s : Expr) : MetaM DefEqCacheKeyInfo := do
|
||||
let kind ← getDefEqCacheKind t s
|
||||
let key := if Expr.quickLt t s then (t, s) else (s, t)
|
||||
let key ← mkDefEqCacheKey t s
|
||||
return { key, kind }
|
||||
|
||||
private def getCachedResult (keyInfo : DefEqCacheKeyInfo) : MetaM LBool := do
|
||||
let cache ← match keyInfo.kind with
|
||||
| .transient => pure (← get).cache.defEqTrans
|
||||
| .permanent => pure (← get).cache.defEqPerm
|
||||
let cache := match (← getTransparency) with
|
||||
| .reducible => cache.reducible
|
||||
| .instances => cache.instances
|
||||
| .default => cache.default
|
||||
| .all => cache.all
|
||||
match cache.find? keyInfo.key with
|
||||
| some val => return val.toLBool
|
||||
| none => return .undef
|
||||
|
||||
def DefEqCache.update (cache : DefEqCache) (mode : TransparencyMode) (key : Expr × Expr) (result : Bool) : DefEqCache :=
|
||||
match mode with
|
||||
| .reducible => { cache with reducible := cache.reducible.insert key result }
|
||||
| .instances => { cache with instances := cache.instances.insert key result }
|
||||
| .default => { cache with default := cache.default.insert key result }
|
||||
| .all => { cache with all := cache.all.insert key result }
|
||||
|
||||
private def cacheResult (keyInfo : DefEqCacheKeyInfo) (result : Bool) : MetaM Unit := do
|
||||
let mode ← getTransparency
|
||||
let key := keyInfo.key
|
||||
match keyInfo.kind with
|
||||
| .permanent => modifyDefEqPermCache fun c => c.update mode key result
|
||||
| .permanent => modifyDefEqPermCache fun c => c.insert key result
|
||||
| .transient =>
|
||||
/-
|
||||
We must ensure that all assigned metavariables in the key are replaced by their current assignments.
|
||||
Otherwise, the key is invalid after the assignment is "backtracked".
|
||||
See issue #1870 for an example.
|
||||
-/
|
||||
let key := (← instantiateMVars key.1, ← instantiateMVars key.2)
|
||||
modifyDefEqTransientCache fun c => c.update mode key result
|
||||
let key ← mkDefEqCacheKey (← instantiateMVars key.lhs) (← instantiateMVars key.rhs)
|
||||
modifyDefEqTransientCache fun c => c.insert key result
|
||||
|
||||
private def whnfCoreAtDefEq (e : Expr) : MetaM Expr := do
|
||||
if backward.isDefEq.lazyWhnfCore.get (← getOptions) then
|
||||
whnfCore e (config := { proj := .yesWithDeltaI })
|
||||
withConfig (fun ctx => { ctx with proj := .yesWithDeltaI }) <| whnfCore e
|
||||
else
|
||||
whnfCore e
|
||||
|
||||
|
||||
@@ -10,13 +10,13 @@ import Lean.Meta.InferType
|
||||
namespace Lean.Meta
|
||||
|
||||
@[inline] private def checkFunInfoCache (fn : Expr) (maxArgs? : Option Nat) (k : MetaM FunInfo) : MetaM FunInfo := do
|
||||
let t ← getTransparency
|
||||
match (← get).cache.funInfo.find? ⟨t, fn, maxArgs?⟩ with
|
||||
| some finfo => pure finfo
|
||||
let key ← mkInfoCacheKey fn maxArgs?
|
||||
match (← get).cache.funInfo.find? key with
|
||||
| some finfo => return finfo
|
||||
| none => do
|
||||
let finfo ← k
|
||||
modify fun s => { s with cache := { s.cache with funInfo := s.cache.funInfo.insert ⟨t, fn, maxArgs?⟩ finfo } }
|
||||
pure finfo
|
||||
modify fun s => { s with cache := { s.cache with funInfo := s.cache.funInfo.insert key finfo } }
|
||||
return finfo
|
||||
|
||||
@[inline] private def whenHasVar {α} (e : Expr) (deps : α) (k : α → α) : α :=
|
||||
if e.hasFVar then k deps else deps
|
||||
|
||||
@@ -22,10 +22,11 @@ private def canUnfoldDefault (cfg : Config) (info : ConstantInfo) : CoreM Bool :
|
||||
|
||||
def canUnfold (info : ConstantInfo) : MetaM Bool := do
|
||||
let ctx ← read
|
||||
let cfg ← getConfig
|
||||
if let some f := ctx.canUnfold? then
|
||||
f ctx.config info
|
||||
f cfg info
|
||||
else
|
||||
canUnfoldDefault ctx.config info
|
||||
canUnfoldDefault cfg info
|
||||
|
||||
/--
|
||||
Look up a constant name, returning the `ConstantInfo`
|
||||
|
||||
@@ -97,8 +97,8 @@ private def inferConstType (c : Name) (us : List Level) : MetaM Expr := do
|
||||
private def inferProjType (structName : Name) (idx : Nat) (e : Expr) : MetaM Expr := do
|
||||
let structType ← inferType e
|
||||
let structType ← whnf structType
|
||||
let failed {α} : Unit → MetaM α := fun _ =>
|
||||
throwError "invalid projection{indentExpr (mkProj structName idx e)} from type {structType}"
|
||||
let failed {α} : Unit → MetaM α := fun _ => do
|
||||
throwError "invalid projection{indentExpr (mkProj structName idx e)}\nfrom type{indentExpr structType}"
|
||||
matchConstStructure structType.getAppFn failed fun structVal structLvls ctorVal =>
|
||||
let structTypeArgs := structType.getAppArgs
|
||||
if structVal.numParams + structVal.numIndices != structTypeArgs.size then
|
||||
@@ -165,24 +165,27 @@ private def inferFVarType (fvarId : FVarId) : MetaM Expr := do
|
||||
| none => fvarId.throwUnknown
|
||||
|
||||
@[inline] private def checkInferTypeCache (e : Expr) (inferType : MetaM Expr) : MetaM Expr := do
|
||||
match (← getTransparency) with
|
||||
| .default =>
|
||||
match (← get).cache.inferType.default.find? e with
|
||||
if e.hasMVar then
|
||||
inferType
|
||||
else
|
||||
let key ← mkExprConfigCacheKey e
|
||||
match (← get).cache.inferType.find? key with
|
||||
| some type => return type
|
||||
| none =>
|
||||
let type ← inferType
|
||||
unless e.hasMVar || type.hasMVar do
|
||||
modifyInferTypeCacheDefault fun c => c.insert e type
|
||||
unless type.hasMVar do
|
||||
modifyInferTypeCache fun c => c.insert key type
|
||||
return type
|
||||
| .all =>
|
||||
match (← get).cache.inferType.all.find? e with
|
||||
| some type => return type
|
||||
| none =>
|
||||
let type ← inferType
|
||||
unless e.hasMVar || type.hasMVar do
|
||||
modifyInferTypeCacheAll fun c => c.insert e type
|
||||
return type
|
||||
| _ => panic! "checkInferTypeCache: transparency mode not default or all"
|
||||
|
||||
private def defaultConfig : ConfigWithKey :=
|
||||
{ : Config }.toConfigWithKey
|
||||
|
||||
private def allConfig : ConfigWithKey :=
|
||||
{ transparency := .all : Config }.toConfigWithKey
|
||||
|
||||
@[inline] def withInferTypeConfig (x : MetaM α) : MetaM α := do
|
||||
let cfg := if (← getTransparency) == .all then allConfig else defaultConfig
|
||||
withConfigWithKey cfg x
|
||||
|
||||
@[export lean_infer_type]
|
||||
def inferTypeImp (e : Expr) : MetaM Expr :=
|
||||
@@ -201,7 +204,7 @@ def inferTypeImp (e : Expr) : MetaM Expr :=
|
||||
| .forallE .. => checkInferTypeCache e (inferForallType e)
|
||||
| .lam .. => checkInferTypeCache e (inferLambdaType e)
|
||||
| .letE .. => checkInferTypeCache e (inferLambdaType e)
|
||||
withIncRecDepth <| withAtLeastTransparency TransparencyMode.default (infer e)
|
||||
withIncRecDepth <| withInferTypeConfig (infer e)
|
||||
|
||||
/--
|
||||
Return `LBool.true` if given level is always equivalent to universe level zero.
|
||||
@@ -382,11 +385,6 @@ def isType (e : Expr) : MetaM Bool := do
|
||||
| .sort .. => return true
|
||||
| _ => return false
|
||||
|
||||
@[inline] private def withLocalDecl' {α} (name : Name) (bi : BinderInfo) (type : Expr) (x : Expr → MetaM α) : MetaM α := do
|
||||
let fvarId ← mkFreshFVarId
|
||||
withReader (fun ctx => { ctx with lctx := ctx.lctx.mkLocalDecl fvarId name type bi }) do
|
||||
x (mkFVar fvarId)
|
||||
|
||||
def typeFormerTypeLevelQuick : Expr → Option Level
|
||||
| .forallE _ _ b _ => typeFormerTypeLevelQuick b
|
||||
| .sort l => some l
|
||||
@@ -403,7 +401,7 @@ where
|
||||
go (type : Expr) (xs : Array Expr) : MetaM (Option Level) := do
|
||||
match type with
|
||||
| .sort l => return some l
|
||||
| .forallE n d b c => withLocalDecl' n c (d.instantiateRev xs) fun x => go b (xs.push x)
|
||||
| .forallE n d b c => withLocalDeclNoLocalInstanceUpdate n c (d.instantiateRev xs) fun x => go b (xs.push x)
|
||||
| _ =>
|
||||
let type ← whnfD (type.instantiateRev xs)
|
||||
match type with
|
||||
|
||||
@@ -72,9 +72,6 @@ structure Instances where
|
||||
erased : PHashSet Name := {}
|
||||
deriving Inhabited
|
||||
|
||||
/-- Configuration for the discrimination tree module -/
|
||||
def tcDtConfig : WhnfCoreConfig := {}
|
||||
|
||||
def addInstanceEntry (d : Instances) (e : InstanceEntry) : Instances :=
|
||||
match e.globalName? with
|
||||
| some n => { d with discrTree := d.discrTree.insertCore e.keys e, instanceNames := d.instanceNames.insert n e, erased := d.erased.erase n }
|
||||
@@ -98,7 +95,7 @@ private def mkInstanceKey (e : Expr) : MetaM (Array InstanceKey) := do
|
||||
let type ← inferType e
|
||||
withNewMCtxDepth do
|
||||
let (_, _, type) ← forallMetaTelescopeReducing type
|
||||
DiscrTree.mkPath type tcDtConfig
|
||||
DiscrTree.mkPath type
|
||||
|
||||
/--
|
||||
Compute the order the arguments of `inst` should be synthesized.
|
||||
|
||||
@@ -184,9 +184,9 @@ private def elimLooseBVarsByBeta (e : Expr) : CoreM Expr :=
|
||||
else
|
||||
return .continue)
|
||||
|
||||
private def getKeyArgs (e : Expr) (isMatch root : Bool) (config : WhnfCoreConfig) :
|
||||
private def getKeyArgs (e : Expr) (isMatch root : Bool) :
|
||||
MetaM (Key × Array Expr) := do
|
||||
let e ← DiscrTree.reduceDT e root config
|
||||
let e ← DiscrTree.reduceDT e root
|
||||
unless root do
|
||||
-- See pushArgs
|
||||
if let some v := toNatLit? e then
|
||||
@@ -222,8 +222,8 @@ private def getKeyArgs (e : Expr) (isMatch root : Bool) (config : WhnfCoreConfig
|
||||
if isMatch then
|
||||
return (.other, #[])
|
||||
else do
|
||||
let ctx ← read
|
||||
if ctx.config.isDefEqStuckEx then
|
||||
let cfg ← getConfig
|
||||
if cfg.isDefEqStuckEx then
|
||||
/-
|
||||
When the configuration flag `isDefEqStuckEx` is set to true,
|
||||
we want `isDefEq` to throw an exception whenever it tries to assign
|
||||
@@ -259,9 +259,9 @@ private def getKeyArgs (e : Expr) (isMatch root : Bool) (config : WhnfCoreConfig
|
||||
/-
|
||||
Given an expression we are looking for patterns that match, return the key and sub-expressions.
|
||||
-/
|
||||
private abbrev getMatchKeyArgs (e : Expr) (root : Bool) (config : WhnfCoreConfig) :
|
||||
private abbrev getMatchKeyArgs (e : Expr) (root : Bool) :
|
||||
MetaM (Key × Array Expr) :=
|
||||
getKeyArgs e (isMatch := true) (root := root) (config := config)
|
||||
getKeyArgs e (isMatch := true) (root := root)
|
||||
|
||||
end MatchClone
|
||||
|
||||
@@ -313,8 +313,6 @@ discriminator key is computed and processing the remaining
|
||||
terms is deferred until demanded by a match.
|
||||
-/
|
||||
structure LazyDiscrTree (α : Type) where
|
||||
/-- Configuration for normalization. -/
|
||||
config : Lean.Meta.WhnfCoreConfig := {}
|
||||
/-- Backing array of trie entries. Should be owned by this trie. -/
|
||||
tries : Array (LazyDiscrTree.Trie α) := #[default]
|
||||
/-- Map from discriminator trie roots to the index. -/
|
||||
@@ -332,12 +330,12 @@ open Lean.Meta.DiscrTree (mkNoindexAnnotation hasNoindexAnnotation reduceDT)
|
||||
/--
|
||||
Specialization of Lean.Meta.DiscrTree.pushArgs
|
||||
-/
|
||||
private def pushArgs (root : Bool) (todo : Array Expr) (e : Expr) (config : WhnfCoreConfig) :
|
||||
private def pushArgs (root : Bool) (todo : Array Expr) (e : Expr) :
|
||||
MetaM (Key × Array Expr) := do
|
||||
if hasNoindexAnnotation e then
|
||||
return (.star, todo)
|
||||
else
|
||||
let e ← reduceDT e root config
|
||||
let e ← reduceDT e root
|
||||
let fn := e.getAppFn
|
||||
let push (k : Key) (nargs : Nat) (todo : Array Expr) : MetaM (Key × Array Expr) := do
|
||||
let info ← getFunInfoNArgs fn nargs
|
||||
@@ -389,8 +387,8 @@ private def initCapacity := 8
|
||||
/--
|
||||
Get the root key and rest of terms of an expression using the specified config.
|
||||
-/
|
||||
private def rootKey (cfg: WhnfCoreConfig) (e : Expr) : MetaM (Key × Array Expr) :=
|
||||
pushArgs true (Array.mkEmpty initCapacity) e cfg
|
||||
private def rootKey (e : Expr) : MetaM (Key × Array Expr) :=
|
||||
pushArgs true (Array.mkEmpty initCapacity) e
|
||||
|
||||
private partial def buildPath (op : Bool → Array Expr → Expr → MetaM (Key × Array Expr)) (root : Bool) (todo : Array Expr) (keys : Array Key) : MetaM (Array Key) := do
|
||||
if todo.isEmpty then
|
||||
@@ -407,9 +405,9 @@ Create a key path from an expression using the function used for patterns.
|
||||
This differs from Lean.Meta.DiscrTree.mkPath and targetPath in that the expression
|
||||
should uses free variables rather than meta-variables for holes.
|
||||
-/
|
||||
def patternPath (e : Expr) (config : WhnfCoreConfig) : MetaM (Array Key) := do
|
||||
def patternPath (e : Expr) : MetaM (Array Key) := do
|
||||
let todo : Array Expr := .mkEmpty initCapacity
|
||||
let op root todo e := pushArgs root todo e config
|
||||
let op root todo e := pushArgs root todo e
|
||||
buildPath op (root := true) (todo.push e) (.mkEmpty initCapacity)
|
||||
|
||||
/--
|
||||
@@ -417,21 +415,21 @@ Create a key path from an expression we are matching against.
|
||||
|
||||
This should have mvars instantiated where feasible.
|
||||
-/
|
||||
def targetPath (e : Expr) (config : WhnfCoreConfig) : MetaM (Array Key) := do
|
||||
def targetPath (e : Expr) : MetaM (Array Key) := do
|
||||
let todo : Array Expr := .mkEmpty initCapacity
|
||||
let op root todo e := do
|
||||
let (k, args) ← MatchClone.getMatchKeyArgs e root config
|
||||
let (k, args) ← MatchClone.getMatchKeyArgs e root
|
||||
pure (k, todo ++ args)
|
||||
buildPath op (root := true) (todo.push e) (.mkEmpty initCapacity)
|
||||
|
||||
/- Monad for finding matches while resolving deferred patterns. -/
|
||||
@[reducible]
|
||||
private def MatchM α := ReaderT WhnfCoreConfig (StateRefT (Array (Trie α)) MetaM)
|
||||
private def MatchM α := StateRefT (Array (Trie α)) MetaM
|
||||
|
||||
private def runMatch (d : LazyDiscrTree α) (m : MatchM α β) : MetaM (β × LazyDiscrTree α) := do
|
||||
let { config := c, tries := a, roots := r } := d
|
||||
let (result, a) ← withReducible $ (m.run c).run a
|
||||
pure (result, { config := c, tries := a, roots := r})
|
||||
let { tries := a, roots := r } := d
|
||||
let (result, a) ← withReducible <| m.run a
|
||||
return (result, { tries := a, roots := r})
|
||||
|
||||
private def setTrie (i : TrieIndex) (v : Trie α) : MatchM α Unit :=
|
||||
modify (·.set! i v)
|
||||
@@ -444,7 +442,7 @@ private def newTrie [Monad m] [MonadState (Array (Trie α)) m] (e : LazyEntry α
|
||||
private def addLazyEntryToTrie (i:TrieIndex) (e : LazyEntry α) : MatchM α Unit :=
|
||||
modify (·.modify i (·.pushPending e))
|
||||
|
||||
private def evalLazyEntry (config : WhnfCoreConfig)
|
||||
private def evalLazyEntry
|
||||
(p : Array α × TrieIndex × Std.HashMap Key TrieIndex)
|
||||
(entry : LazyEntry α)
|
||||
: MatchM α (Array α × TrieIndex × Std.HashMap Key TrieIndex) := do
|
||||
@@ -456,7 +454,7 @@ private def evalLazyEntry (config : WhnfCoreConfig)
|
||||
else
|
||||
let e := todo.back!
|
||||
let todo := todo.pop
|
||||
let (k, todo) ← withLCtx lctx.1 lctx.2 $ pushArgs false todo e config
|
||||
let (k, todo) ← withLCtx lctx.1 lctx.2 <| pushArgs false todo e
|
||||
if k == .star then
|
||||
if starIdx = 0 then
|
||||
let starIdx ← newTrie (todo, lctx, v)
|
||||
@@ -477,26 +475,25 @@ private def evalLazyEntry (config : WhnfCoreConfig)
|
||||
This evaluates all lazy entries in a trie and updates `values`, `starIdx`, and `children`
|
||||
accordingly.
|
||||
-/
|
||||
private partial def evalLazyEntries (config : WhnfCoreConfig)
|
||||
private partial def evalLazyEntries
|
||||
(values : Array α) (starIdx : TrieIndex) (children : Std.HashMap Key TrieIndex)
|
||||
(entries : Array (LazyEntry α)) :
|
||||
MatchM α (Array α × TrieIndex × Std.HashMap Key TrieIndex) := do
|
||||
let mut values := values
|
||||
let mut starIdx := starIdx
|
||||
let mut children := children
|
||||
entries.foldlM (init := (values, starIdx, children)) (evalLazyEntry config)
|
||||
entries.foldlM (init := (values, starIdx, children)) evalLazyEntry
|
||||
|
||||
private def evalNode (c : TrieIndex) :
|
||||
MatchM α (Array α × TrieIndex × Std.HashMap Key TrieIndex) := do
|
||||
let .node vs star cs pending := (←get).get! c
|
||||
if pending.size = 0 then
|
||||
pure (vs, star, cs)
|
||||
return (vs, star, cs)
|
||||
else
|
||||
let config ← read
|
||||
setTrie c default
|
||||
let (vs, star, cs) ← evalLazyEntries config vs star cs pending
|
||||
let (vs, star, cs) ← evalLazyEntries vs star cs pending
|
||||
setTrie c <| .node vs star cs #[]
|
||||
pure (vs, star, cs)
|
||||
return (vs, star, cs)
|
||||
|
||||
def dropKeyAux (next : TrieIndex) (rest : List Key) :
|
||||
MatchM α Unit :=
|
||||
@@ -723,11 +720,11 @@ private def push (d : PreDiscrTree α) (k : Key) (e : LazyEntry α) : PreDiscrTr
|
||||
d.modifyAt k (·.push e)
|
||||
|
||||
/-- Convert a pre-discrimination tree to a lazy discrimination tree. -/
|
||||
private def toLazy (d : PreDiscrTree α) (config : WhnfCoreConfig := {}) : LazyDiscrTree α :=
|
||||
private def toLazy (d : PreDiscrTree α) : LazyDiscrTree α :=
|
||||
let { roots, tries } := d
|
||||
-- Adjust trie indices so the first value is reserved (so 0 is never a valid trie index)
|
||||
let roots := roots.fold (init := roots) (fun m k n => m.insert k (n+1))
|
||||
{ config, roots, tries := #[default] ++ tries.map (.node {} 0 {}) }
|
||||
{ roots, tries := #[default] ++ tries.map (.node {} 0 {}) }
|
||||
|
||||
/-- Merge two discrimination trees. -/
|
||||
protected def append (x y : PreDiscrTree α) : PreDiscrTree α :=
|
||||
@@ -756,12 +753,12 @@ namespace InitEntry
|
||||
/--
|
||||
Constructs an initial entry from an expression and value.
|
||||
-/
|
||||
def fromExpr (expr : Expr) (value : α) (config : WhnfCoreConfig := {}) : MetaM (InitEntry α) := do
|
||||
def fromExpr (expr : Expr) (value : α) : MetaM (InitEntry α) := do
|
||||
let lctx ← getLCtx
|
||||
let linst ← getLocalInstances
|
||||
let lctx := (lctx, linst)
|
||||
let (key, todo) ← LazyDiscrTree.rootKey config expr
|
||||
pure <| { key, entry := (todo, lctx, value) }
|
||||
let (key, todo) ← LazyDiscrTree.rootKey expr
|
||||
return { key, entry := (todo, lctx, value) }
|
||||
|
||||
/--
|
||||
Creates an entry for a subterm of an initial entry.
|
||||
@@ -769,11 +766,11 @@ Creates an entry for a subterm of an initial entry.
|
||||
This is slightly more efficient than using `fromExpr` on subterms since it avoids a redundant call
|
||||
to `whnf`.
|
||||
-/
|
||||
def mkSubEntry (e : InitEntry α) (idx : Nat) (value : α) (config : WhnfCoreConfig := {}) :
|
||||
def mkSubEntry (e : InitEntry α) (idx : Nat) (value : α) :
|
||||
MetaM (InitEntry α) := do
|
||||
let (todo, lctx, _) := e.entry
|
||||
let (key, todo) ← LazyDiscrTree.rootKey config todo[idx]!
|
||||
pure <| { key, entry := (todo, lctx, value) }
|
||||
let (key, todo) ← LazyDiscrTree.rootKey todo[idx]!
|
||||
return { key, entry := (todo, lctx, value) }
|
||||
|
||||
end InitEntry
|
||||
|
||||
|
||||
@@ -149,8 +149,8 @@ mutual
|
||||
if r != LBool.undef then
|
||||
return r == LBool.true
|
||||
else if !(← hasAssignableLevelMVar lhs <||> hasAssignableLevelMVar rhs) then
|
||||
let ctx ← read
|
||||
if ctx.config.isDefEqStuckEx && (lhs.isMVar || rhs.isMVar) then do
|
||||
let cfg ← getConfig
|
||||
if cfg.isDefEqStuckEx && (lhs.isMVar || rhs.isMVar) then do
|
||||
trace[Meta.isLevelDefEq.stuck] "{lhs} =?= {rhs}"
|
||||
Meta.throwIsDefEqStuck
|
||||
else
|
||||
|
||||
@@ -162,7 +162,7 @@ def refineThrough? (matcherApp : MatcherApp) (e : Expr) :
|
||||
private def withUserNamesImpl {α} (fvars : Array Expr) (names : Array Name) (k : MetaM α) : MetaM α := do
|
||||
let lctx := (Array.zip fvars names).foldl (init := ← (getLCtx)) fun lctx (fvar, name) =>
|
||||
lctx.setUserName fvar.fvarId! name
|
||||
withTheReader Meta.Context (fun ctx => { ctx with lctx }) k
|
||||
withLCtx' lctx k
|
||||
|
||||
/--
|
||||
Sets the user name of the FVars in the local context according to the given array of names.
|
||||
|
||||
@@ -207,7 +207,7 @@ def getInstances (type : Expr) : MetaM (Array Instance) := do
|
||||
| none => throwError "type class instance expected{indentExpr type}"
|
||||
| some className =>
|
||||
let globalInstances ← getGlobalInstancesIndex
|
||||
let result ← globalInstances.getUnify type tcDtConfig
|
||||
let result ← globalInstances.getUnify type
|
||||
-- Using insertion sort because it is stable and the array `result` should be mostly sorted.
|
||||
-- Most instances have default priority.
|
||||
let result := result.insertionSort fun e₁ e₂ => e₁.priority < e₂.priority
|
||||
@@ -782,7 +782,7 @@ def synthInstance? (type : Expr) (maxResultSize? : Option Nat := none) : MetaM (
|
||||
(return m!"{exceptOptionEmoji ·} {← instantiateMVars type}") do
|
||||
withConfig (fun config => { config with isDefEqStuckEx := true, transparency := TransparencyMode.instances,
|
||||
foApprox := true, ctxApprox := true, constApprox := false, univApprox := false }) do
|
||||
withReader (fun ctx => { ctx with inTypeClassResolution := true }) do
|
||||
withInTypeClassResolution do
|
||||
let localInsts ← getLocalInstances
|
||||
let type ← instantiateMVars type
|
||||
let type ← preprocess type
|
||||
@@ -839,7 +839,7 @@ private def synthPendingImp (mvarId : MVarId) : MetaM Bool := withIncRecDepth <|
|
||||
recordSynthPendingFailure mvarDecl.type
|
||||
return false
|
||||
else
|
||||
withReader (fun ctx => { ctx with synthPendingDepth := ctx.synthPendingDepth + 1 }) do
|
||||
withIncSynthPending do
|
||||
trace[Meta.synthPending] "synthPending {mkMVar mvarId}"
|
||||
let val? ← catchInternalId isDefEqStuckExceptionId (synthInstance? mvarDecl.type (maxResultSize? := none)) (fun _ => pure none)
|
||||
match val? with
|
||||
|
||||
@@ -188,12 +188,10 @@ def post (e : Expr) : SimpM Simp.Step := do
|
||||
| e, _ => return Simp.Step.done { expr := e }
|
||||
|
||||
def rewriteUnnormalized (mvarId : MVarId) : MetaM MVarId := do
|
||||
let simpCtx :=
|
||||
{
|
||||
simpTheorems := {}
|
||||
congrTheorems := (← getSimpCongrTheorems)
|
||||
config := Simp.neutralConfig
|
||||
}
|
||||
let simpCtx ← Simp.mkContext
|
||||
(simpTheorems := {})
|
||||
(congrTheorems := (← getSimpCongrTheorems))
|
||||
(config := Simp.neutralConfig)
|
||||
let tgt ← instantiateMVars (← mvarId.getType)
|
||||
let (res, _) ← Simp.main tgt simpCtx (methods := { post })
|
||||
applySimpResultToTarget mvarId tgt res
|
||||
@@ -207,12 +205,10 @@ def rewriteUnnormalizedRefl (goal : MVarId) : MetaM Unit := do
|
||||
|
||||
def acNfHypMeta (goal : MVarId) (fvarId : FVarId) : MetaM (Option MVarId) := do
|
||||
goal.withContext do
|
||||
let simpCtx :=
|
||||
{
|
||||
simpTheorems := {}
|
||||
congrTheorems := (← getSimpCongrTheorems)
|
||||
config := Simp.neutralConfig
|
||||
}
|
||||
let simpCtx ← Simp.mkContext
|
||||
(simpTheorems := {})
|
||||
(congrTheorems := (← getSimpCongrTheorems))
|
||||
(config := Simp.neutralConfig)
|
||||
let tgt ← instantiateMVars (← fvarId.getType)
|
||||
let (res, _) ← Simp.main tgt simpCtx (methods := { post })
|
||||
return (← applySimpResultToLocalDecl goal fvarId res false).map (·.snd)
|
||||
|
||||
@@ -38,7 +38,10 @@ where
|
||||
let sizeOfEq ← mkLT sizeOf_lhs sizeOf_rhs
|
||||
let hlt ← mkFreshExprSyntheticOpaqueMVar sizeOfEq
|
||||
-- TODO: we only need the `sizeOf` simp theorems
|
||||
match (← simpTarget hlt.mvarId! { config.arith := true, simpTheorems := #[ (← getSimpTheorems) ] } {}).1 with
|
||||
let ctx ← Simp.mkContext
|
||||
(config := { arith := true })
|
||||
(simpTheorems := #[ (← getSimpTheorems) ])
|
||||
match (← simpTarget hlt.mvarId! ctx {}).1 with
|
||||
| some _ => return false
|
||||
| none =>
|
||||
let heq ← mkCongrArg sizeOf_lhs.appFn! (← mkEqSymm h)
|
||||
|
||||
@@ -254,10 +254,6 @@ Apply `And.intro` as much as possible to goal `mvarId`.
|
||||
abbrev splitAnd (mvarId : MVarId) : MetaM (List MVarId) :=
|
||||
splitAndCore mvarId
|
||||
|
||||
@[deprecated splitAnd (since := "2024-03-17")]
|
||||
def _root_.Lean.Meta.splitAnd (mvarId : MVarId) : MetaM (List MVarId) :=
|
||||
mvarId.splitAnd
|
||||
|
||||
def exfalso (mvarId : MVarId) : MetaM MVarId :=
|
||||
mvarId.withContext do
|
||||
mvarId.checkNotAssigned `exfalso
|
||||
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user