mirror of
https://github.com/leanprover/lean4.git
synced 2026-04-13 23:54:10 +00:00
Compare commits
40 Commits
debug-lake
...
sofia/fix-
| Author | SHA1 | Date | |
|---|---|---|---|
|
|
b3d1fa9b4d | ||
|
|
4dced0287e | ||
|
|
c4d9573342 | ||
|
|
9db52c7fa6 | ||
|
|
ea209d19e0 | ||
|
|
f0c999a668 | ||
|
|
c769515d94 | ||
|
|
1b81a9889b | ||
|
|
1c9e26420f | ||
|
|
cd697eac81 | ||
|
|
c54f691f4a | ||
|
|
0d7e76ea88 | ||
|
|
2b8c273687 | ||
|
|
ff19ad9c38 | ||
|
|
d76e5a1886 | ||
|
|
86579c8e24 | ||
|
|
41ab492142 | ||
|
|
790d294e50 | ||
|
|
d53b46a0f3 | ||
|
|
5a9d3bc991 | ||
|
|
8678c99b76 | ||
|
|
bc2da2dc74 | ||
|
|
e0a29f43d2 | ||
|
|
a07649a4c6 | ||
|
|
031bfa5989 | ||
|
|
1d1c5c6e30 | ||
|
|
c0fbddbf6f | ||
|
|
c60f97a3fa | ||
|
|
82bb27fd7d | ||
|
|
ab0ec9ef95 | ||
|
|
f9b2f6b597 | ||
|
|
a3cc301de5 | ||
|
|
3a8db01ce8 | ||
|
|
06fb4bec52 | ||
|
|
35b4c7dbfc | ||
|
|
2398d2cc66 | ||
|
|
8353964e55 | ||
|
|
334d9bd4f3 | ||
|
|
f7f5fc5ecd | ||
|
|
659db85510 |
@@ -7,11 +7,6 @@ To build Lean you should use `make -j$(nproc) -C build/release`.
|
||||
The build uses `ccache`, and in a sandbox `ccache` may complain about read-only file systems.
|
||||
Use `CCACHE_READONLY` and `CCACHE_TEMPDIR` instead of disabling ccache completely.
|
||||
|
||||
To rebuild individual modules without a full build, use Lake directly:
|
||||
```
|
||||
cd src && lake build Init.Prelude
|
||||
```
|
||||
|
||||
## Running Tests
|
||||
|
||||
See `tests/README.md` for full documentation. Quick reference:
|
||||
@@ -66,6 +61,8 @@ To rebuild individual stage 2 modules without a full `make stage2`, use Lake dir
|
||||
cd build/release/stage2 && lake build Init.Prelude
|
||||
```
|
||||
|
||||
To run tests in stage2, replace `-C build/release` from above with `-C build/release/stage2`.
|
||||
|
||||
## New features
|
||||
|
||||
When asked to implement new features:
|
||||
|
||||
3
.github/workflows/ci.yml
vendored
3
.github/workflows/ci.yml
vendored
@@ -305,7 +305,8 @@ jobs:
|
||||
"test": true,
|
||||
"CMAKE_PRESET": "reldebug",
|
||||
// * `elab_bench/big_do` crashes with exit code 134
|
||||
"CTEST_OPTIONS": "-E 'elab_bench/big_do'",
|
||||
// * `compile_bench/channel` randomly segfaults
|
||||
"CTEST_OPTIONS": "-E 'elab_bench/big_do|compile_bench/channel'",
|
||||
},
|
||||
{
|
||||
"name": "Linux fsanitize",
|
||||
|
||||
@@ -220,7 +220,9 @@ add_custom_target(
|
||||
DEPENDS stage2
|
||||
)
|
||||
|
||||
add_custom_target(clean-stdlib COMMAND $(MAKE) -C stage1 clean-stdlib DEPENDS stage1)
|
||||
add_custom_target(clean-stdlib COMMAND $(MAKE) -C stage1 clean-stdlib DEPENDS stage1-configure)
|
||||
|
||||
add_custom_target(cache-get COMMAND $(MAKE) -C stage1 cache-get DEPENDS stage1-configure)
|
||||
|
||||
install(CODE "execute_process(COMMAND make -C stage1 install)")
|
||||
|
||||
|
||||
@@ -992,6 +992,13 @@ add_custom_target(
|
||||
|
||||
add_custom_target(clean-olean DEPENDS clean-stdlib)
|
||||
|
||||
if(USE_LAKE_CACHE)
|
||||
add_custom_target(
|
||||
cache-get
|
||||
COMMAND ${PREV_STAGE}/bin/lake${CMAKE_EXECUTABLE_SUFFIX} cache get --repo=leanprover/lean4
|
||||
)
|
||||
endif()
|
||||
|
||||
install(
|
||||
DIRECTORY "${CMAKE_BINARY_DIR}/lib/"
|
||||
DESTINATION lib
|
||||
|
||||
@@ -802,6 +802,7 @@ Examples:
|
||||
def firstM {α : Type u} {m : Type v → Type w} [Alternative m] (f : α → m β) (as : Array α) : m β :=
|
||||
go 0
|
||||
where
|
||||
@[specialize]
|
||||
go (i : Nat) : m β :=
|
||||
if hlt : i < as.size then
|
||||
f as[i] <|> go (i+1)
|
||||
@@ -1264,7 +1265,7 @@ Examples:
|
||||
-/
|
||||
@[inline, expose]
|
||||
def findIdx? {α : Type u} (p : α → Bool) (as : Array α) : Option Nat :=
|
||||
let rec loop (j : Nat) :=
|
||||
let rec @[specialize] loop (j : Nat) :=
|
||||
if h : j < as.size then
|
||||
if p as[j] then some j else loop (j + 1)
|
||||
else none
|
||||
|
||||
@@ -3096,13 +3096,13 @@ theorem foldl_eq_foldlM {f : β → α → β} {b} {xs : Array α} {start stop :
|
||||
theorem foldr_eq_foldrM {f : α → β → β} {b} {xs : Array α} {start stop : Nat} :
|
||||
xs.foldr f b start stop = (xs.foldrM (m := Id) (pure <| f · ·) b start stop).run := rfl
|
||||
|
||||
public theorem foldl_eq_foldl_extract {xs : Array α} {f : β → α → β} {init : β} :
|
||||
theorem foldl_eq_foldl_extract {xs : Array α} {f : β → α → β} {init : β} :
|
||||
xs.foldl (init := init) (start := start) (stop := stop) f =
|
||||
(xs.extract start stop).foldl (init := init) f := by
|
||||
simp only [foldl_eq_foldlM]
|
||||
rw [foldlM_start_stop]
|
||||
|
||||
public theorem foldr_eq_foldr_extract {xs : Array α} {f : α → β → β} {init : β} :
|
||||
theorem foldr_eq_foldr_extract {xs : Array α} {f : α → β → β} {init : β} :
|
||||
xs.foldr (init := init) (start := start) (stop := stop) f =
|
||||
(xs.extract stop start).foldr (init := init) f := by
|
||||
simp only [foldr_eq_foldrM]
|
||||
|
||||
@@ -80,7 +80,7 @@ instance : SliceSize (Internal.SubarrayData α) where
|
||||
size s := s.internalRepresentation.stop - s.internalRepresentation.start
|
||||
|
||||
@[grind =, suggest_for Subarray.size]
|
||||
public theorem size_eq {xs : Subarray α} :
|
||||
theorem size_eq {xs : Subarray α} :
|
||||
xs.size = xs.stop - xs.start := by
|
||||
simp [Std.Slice.size, SliceSize.size, start, stop]
|
||||
|
||||
|
||||
@@ -74,7 +74,7 @@ protected theorem isGE_compare {a b : Int} :
|
||||
rw [← Int.compare_swap, Ordering.isGE_swap]
|
||||
exact Int.isLE_compare
|
||||
|
||||
public instance : Std.LawfulOrderOrd Int where
|
||||
instance : Std.LawfulOrderOrd Int where
|
||||
isLE_compare _ _ := Int.isLE_compare
|
||||
isGE_compare _ _ := Int.isGE_compare
|
||||
|
||||
|
||||
@@ -42,29 +42,29 @@ The conversion functions {name (scope := "Init.Data.Iterators.Basic")}`Shrink.de
|
||||
{name (scope := "Init.Data.Iterators.Basic")}`Shrink.inflate` form an equivalence between
|
||||
{name}`α` and {lean}`Shrink α`, but this equivalence is intentionally not definitional.
|
||||
-/
|
||||
public def Shrink (α : Type u) : Type u := Internal.idOpaque.1 α
|
||||
def Shrink (α : Type u) : Type u := Internal.idOpaque.1 α
|
||||
|
||||
/-- Converts elements of {name}`α` into elements of {lean}`Shrink α`. -/
|
||||
@[always_inline]
|
||||
public def Shrink.deflate {α} (x : α) : Shrink α :=
|
||||
def Shrink.deflate {α} (x : α) : Shrink α :=
|
||||
cast (by simp [Shrink, Internal.idOpaque.property]) x
|
||||
|
||||
/-- Converts elements of {lean}`Shrink α` into elements of {name}`α`. -/
|
||||
@[always_inline]
|
||||
public def Shrink.inflate {α} (x : Shrink α) : α :=
|
||||
def Shrink.inflate {α} (x : Shrink α) : α :=
|
||||
cast (by simp [Shrink, Internal.idOpaque.property]) x
|
||||
|
||||
@[simp, grind =]
|
||||
public theorem Shrink.deflate_inflate {α} {x : Shrink α} :
|
||||
theorem Shrink.deflate_inflate {α} {x : Shrink α} :
|
||||
Shrink.deflate x.inflate = x := by
|
||||
simp [deflate, inflate]
|
||||
|
||||
@[simp, grind =]
|
||||
public theorem Shrink.inflate_deflate {α} {x : α} :
|
||||
theorem Shrink.inflate_deflate {α} {x : α} :
|
||||
(Shrink.deflate x).inflate = x := by
|
||||
simp [deflate, inflate]
|
||||
|
||||
public theorem Shrink.inflate_inj {α} {x y : Shrink α} :
|
||||
theorem Shrink.inflate_inj {α} {x y : Shrink α} :
|
||||
x.inflate = y.inflate ↔ x = y := by
|
||||
apply Iff.intro
|
||||
· intro h
|
||||
@@ -72,7 +72,7 @@ public theorem Shrink.inflate_inj {α} {x y : Shrink α} :
|
||||
· rintro rfl
|
||||
rfl
|
||||
|
||||
public theorem Shrink.deflate_inj {α} {x y : α} :
|
||||
theorem Shrink.deflate_inj {α} {x y : α} :
|
||||
Shrink.deflate x = Shrink.deflate y ↔ x = y := by
|
||||
apply Iff.intro
|
||||
· intro h
|
||||
|
||||
@@ -190,7 +190,7 @@ def Append.instFinitenessRelation [Monad m] [Iterator α₁ m β] [Iterator α
|
||||
exact IterM.TerminationMeasures.Finite.rel_of_skip ‹_›
|
||||
|
||||
@[no_expose]
|
||||
public instance Append.instFinite [Monad m] [Iterator α₁ m β] [Iterator α₂ m β]
|
||||
instance Append.instFinite [Monad m] [Iterator α₁ m β] [Iterator α₂ m β]
|
||||
[Finite α₁ m] [Finite α₂ m] : Finite (Append α₁ α₂ m β) m :=
|
||||
.of_finitenessRelation instFinitenessRelation
|
||||
|
||||
|
||||
@@ -282,6 +282,7 @@ The lexicographic order with respect to `lt` is:
|
||||
* `as.lex [] = false` is `false`
|
||||
* `(a :: as).lex (b :: bs)` is true if `lt a b` or `a == b` and `lex lt as bs` is true.
|
||||
-/
|
||||
@[specialize]
|
||||
def lex [BEq α] (l₁ l₂ : List α) (lt : α → α → Bool := by exact (· < ·)) : Bool :=
|
||||
match l₁, l₂ with
|
||||
| [], _ :: _ => true
|
||||
@@ -1004,6 +1005,7 @@ Examples:
|
||||
* `[8, 3, 2, 4, 2, 7, 4].dropWhile (· < 4) = [8, 3, 2, 4, 2, 7, 4]`
|
||||
* `[8, 3, 2, 4, 2, 7, 4].dropWhile (· < 100) = []`
|
||||
-/
|
||||
@[specialize]
|
||||
def dropWhile (p : α → Bool) : List α → List α
|
||||
| [] => []
|
||||
| a::l => match p a with
|
||||
@@ -1460,9 +1462,11 @@ Examples:
|
||||
["circle", "square", "triangle"]
|
||||
```
|
||||
-/
|
||||
@[inline]
|
||||
def modifyTailIdx (l : List α) (i : Nat) (f : List α → List α) : List α :=
|
||||
go i l
|
||||
where
|
||||
@[specialize]
|
||||
go : Nat → List α → List α
|
||||
| 0, l => f l
|
||||
| _+1, [] => []
|
||||
@@ -1498,6 +1502,7 @@ Examples:
|
||||
* `[1, 2, 3].modify 2 (· * 10) = [1, 2, 30]`
|
||||
* `[1, 2, 3].modify 3 (· * 10) = [1, 2, 3]`
|
||||
-/
|
||||
@[inline]
|
||||
def modify (l : List α) (i : Nat) (f : α → α) : List α :=
|
||||
l.modifyTailIdx i (modifyHead f)
|
||||
|
||||
@@ -1604,6 +1609,7 @@ Examples:
|
||||
* `[7, 6, 5, 8, 1, 2, 6].find? (· < 5) = some 1`
|
||||
* `[7, 6, 5, 8, 1, 2, 6].find? (· < 1) = none`
|
||||
-/
|
||||
@[specialize]
|
||||
def find? (p : α → Bool) : List α → Option α
|
||||
| [] => none
|
||||
| a::as => match p a with
|
||||
@@ -1626,6 +1632,7 @@ Examples:
|
||||
* `[7, 6, 5, 8, 1, 2, 6].findSome? (fun x => if x < 5 then some (10 * x) else none) = some 10`
|
||||
* `[7, 6, 5, 8, 1, 2, 6].findSome? (fun x => if x < 1 then some (10 * x) else none) = none`
|
||||
-/
|
||||
@[specialize]
|
||||
def findSome? (f : α → Option β) : List α → Option β
|
||||
| [] => none
|
||||
| a::as => match f a with
|
||||
@@ -1649,6 +1656,7 @@ Examples:
|
||||
* `[7, 6, 5, 8, 1, 2, 6].findRev? (· < 5) = some 2`
|
||||
* `[7, 6, 5, 8, 1, 2, 6].findRev? (· < 1) = none`
|
||||
-/
|
||||
@[specialize]
|
||||
def findRev? (p : α → Bool) : List α → Option α
|
||||
| [] => none
|
||||
| a::as => match findRev? p as with
|
||||
@@ -1667,6 +1675,7 @@ Examples:
|
||||
* `[7, 6, 5, 8, 1, 2, 6].findSomeRev? (fun x => if x < 5 then some (10 * x) else none) = some 20`
|
||||
* `[7, 6, 5, 8, 1, 2, 6].findSomeRev? (fun x => if x < 1 then some (10 * x) else none) = none`
|
||||
-/
|
||||
@[specialize]
|
||||
def findSomeRev? (f : α → Option β) : List α → Option β
|
||||
| [] => none
|
||||
| a::as => match findSomeRev? f as with
|
||||
@@ -1717,9 +1726,11 @@ Examples:
|
||||
* `[7, 6, 5, 8, 1, 2, 6].findIdx (· < 5) = some 4`
|
||||
* `[7, 6, 5, 8, 1, 2, 6].findIdx (· < 1) = none`
|
||||
-/
|
||||
@[inline]
|
||||
def findIdx? (p : α → Bool) (l : List α) : Option Nat :=
|
||||
go l 0
|
||||
where
|
||||
@[specialize]
|
||||
go : List α → Nat → Option Nat
|
||||
| [], _ => none
|
||||
| a :: l, i => if p a then some i else go l (i + 1)
|
||||
@@ -1750,6 +1761,7 @@ Examples:
|
||||
@[inline] def findFinIdx? (p : α → Bool) (l : List α) : Option (Fin l.length) :=
|
||||
go l 0 (by simp)
|
||||
where
|
||||
@[specialize]
|
||||
go : (l' : List α) → (i : Nat) → (h : l'.length + i = l.length) → Option (Fin l.length)
|
||||
| [], _, _ => none
|
||||
| a :: l, i, h =>
|
||||
@@ -1886,7 +1898,7 @@ Examples:
|
||||
* `[2, 4, 5, 6].any (· % 2 = 0) = true`
|
||||
* `[2, 4, 5, 6].any (· % 2 = 1) = true`
|
||||
-/
|
||||
@[suggest_for List.some]
|
||||
@[suggest_for List.some, specialize]
|
||||
def any : (l : List α) → (p : α → Bool) → Bool
|
||||
| [], _ => false
|
||||
| h :: t, p => p h || any t p
|
||||
@@ -1906,7 +1918,7 @@ Examples:
|
||||
* `[2, 4, 6].all (· % 2 = 0) = true`
|
||||
* `[2, 4, 5, 6].all (· % 2 = 0) = false`
|
||||
-/
|
||||
@[suggest_for List.every]
|
||||
@[suggest_for List.every, specialize]
|
||||
def all : List α → (α → Bool) → Bool
|
||||
| [], _ => true
|
||||
| h :: t, p => p h && all t p
|
||||
@@ -2007,6 +2019,7 @@ Examples:
|
||||
* `[1, 2, 3].zipWithAll Prod.mk [5, 6] = [(some 1, some 5), (some 2, some 6), (some 3, none)]`
|
||||
* `[x₁, x₂].zipWithAll f [y] = [f (some x₁) (some y), f (some x₂) none]`
|
||||
-/
|
||||
@[specialize]
|
||||
def zipWithAll (f : Option α → Option β → γ) : List α → List β → List γ
|
||||
| [], bs => bs.map fun b => f none (some b)
|
||||
| a :: as, [] => (a :: as).map fun a => f (some a) none
|
||||
|
||||
@@ -444,8 +444,8 @@ theorem findM?_eq_findSomeM? [Monad m] [LawfulMonad m] {p : α → m Bool} {as :
|
||||
intro b
|
||||
cases b <;> simp
|
||||
|
||||
@[inline, expose] protected def forIn' {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] (as : List α) (init : β) (f : (a : α) → a ∈ as → β → m (ForInStep β)) : m β :=
|
||||
let rec @[specialize] loop : (as' : List α) → (b : β) → Exists (fun bs => bs ++ as' = as) → m β
|
||||
@[inline, expose] protected def forIn' {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] (as : @& List α) (init : β) (f : (a : α) → a ∈ as → β → m (ForInStep β)) : m β :=
|
||||
let rec @[specialize] loop : (as' : @& List α) → (b : β) → Exists (fun bs => bs ++ as' = as) → m β
|
||||
| [], b, _ => pure b
|
||||
| a::as', b, h => do
|
||||
have : a ∈ as := by
|
||||
|
||||
@@ -37,7 +37,7 @@ open Nat
|
||||
@[simp, grind =] theorem min?_nil [Min α] : ([] : List α).min? = none := rfl
|
||||
|
||||
@[simp, grind =]
|
||||
public theorem min?_singleton [Min α] {x : α} : [x].min? = some x :=
|
||||
theorem min?_singleton [Min α] {x : α} : [x].min? = some x :=
|
||||
(rfl)
|
||||
|
||||
-- We don't put `@[simp]` on `min?_cons'`,
|
||||
@@ -52,7 +52,7 @@ theorem min?_cons' [Min α] {xs : List α} : (x :: xs).min? = some (foldl min x
|
||||
cases xs <;> simp [min?]
|
||||
|
||||
@[simp, grind =]
|
||||
public theorem isSome_min?_iff [Min α] {xs : List α} : xs.min?.isSome ↔ xs ≠ [] := by
|
||||
theorem isSome_min?_iff [Min α] {xs : List α} : xs.min?.isSome ↔ xs ≠ [] := by
|
||||
cases xs <;> simp [min?]
|
||||
|
||||
@[grind .]
|
||||
@@ -247,7 +247,7 @@ theorem foldl_min_eq_min [Min α] [Std.IdempotentOp (min : α → α → α)] [S
|
||||
@[simp, grind =] theorem max?_nil [Max α] : ([] : List α).max? = none := rfl
|
||||
|
||||
@[simp, grind =]
|
||||
public theorem max?_singleton [Max α] {x : α} : [x].max? = some x :=
|
||||
theorem max?_singleton [Max α] {x : α} : [x].max? = some x :=
|
||||
(rfl)
|
||||
|
||||
-- We don't put `@[simp]` on `max?_cons'`,
|
||||
@@ -262,7 +262,7 @@ theorem max?_cons' [Max α] {xs : List α} : (x :: xs).max? = some (foldl max x
|
||||
cases xs <;> simp [max?]
|
||||
|
||||
@[simp, grind =]
|
||||
public theorem isSome_max?_iff [Max α] {xs : List α} : xs.max?.isSome ↔ xs ≠ [] := by
|
||||
theorem isSome_max?_iff [Max α] {xs : List α} : xs.max?.isSome ↔ xs ≠ [] := by
|
||||
cases xs <;> simp [max?]
|
||||
|
||||
@[grind .]
|
||||
|
||||
@@ -70,7 +70,7 @@ protected theorem isGE_compare {a b : Nat} :
|
||||
rw [← Nat.compare_swap, Ordering.isGE_swap]
|
||||
exact Nat.isLE_compare
|
||||
|
||||
public instance : Std.LawfulOrderOrd Nat where
|
||||
instance : Std.LawfulOrderOrd Nat where
|
||||
isLE_compare _ _ := Nat.isLE_compare
|
||||
isGE_compare _ _ := Nat.isGE_compare
|
||||
|
||||
|
||||
@@ -60,7 +60,7 @@ theorem gcd_def (x y : Nat) : gcd x y = if x = 0 then y else gcd (y % x) x := by
|
||||
cases n with
|
||||
| zero => simp
|
||||
| succ n =>
|
||||
-- `simp [gcd_succ]` produces an invalid term unless `gcd_succ` is proved with `id rfl` instead
|
||||
-- `simp [gcd_succ]` produces an invalid term unless `gcd_succ` is proved with `(rfl)` instead
|
||||
rw [gcd_succ]
|
||||
exact gcd_zero_left _
|
||||
instance : Std.LawfulIdentity gcd 0 where
|
||||
|
||||
@@ -444,7 +444,7 @@ instance : MonadAttach Option where
|
||||
CanReturn x a := x = some a
|
||||
attach x := x.attach
|
||||
|
||||
public instance : LawfulMonadAttach Option where
|
||||
instance : LawfulMonadAttach Option where
|
||||
map_attach {α} x := by simp [MonadAttach.attach]
|
||||
canReturn_map_imp {α P x a} := by
|
||||
cases x
|
||||
@@ -455,7 +455,7 @@ end Option
|
||||
|
||||
namespace OptionT
|
||||
|
||||
public instance [Monad m] [MonadAttach m] [LawfulMonad m] [WeaklyLawfulMonadAttach m] :
|
||||
instance [Monad m] [MonadAttach m] [LawfulMonad m] [WeaklyLawfulMonadAttach m] :
|
||||
WeaklyLawfulMonadAttach (OptionT m) where
|
||||
map_attach {α} x := by
|
||||
apply OptionT.ext
|
||||
@@ -466,7 +466,7 @@ public instance [Monad m] [MonadAttach m] [LawfulMonad m] [WeaklyLawfulMonadAtta
|
||||
| ⟨some a, _⟩ => simp [OptionT.pure, OptionT.mk]
|
||||
| ⟨none, _⟩ => simp
|
||||
|
||||
public instance [Monad m] [MonadAttach m] [LawfulMonad m] [LawfulMonadAttach m] :
|
||||
instance [Monad m] [MonadAttach m] [LawfulMonad m] [LawfulMonadAttach m] :
|
||||
LawfulMonadAttach (OptionT m) where
|
||||
canReturn_map_imp {α P x a} h := by
|
||||
simp only [MonadAttach.CanReturn, OptionT.run_map] at h
|
||||
|
||||
@@ -152,7 +152,7 @@ public theorem max_eq_if_isGE_compare {α : Type u} [Ord α] [LE α] {_ : Max α
|
||||
{a b : α} : max a b = if (compare a b).isGE then a else b := by
|
||||
open Classical in simp [max_eq_if, isGE_compare]
|
||||
|
||||
private theorem min_le_min [LE α] [Min α] [Std.LawfulOrderLeftLeaningMin α] [IsLinearOrder α] (a b : α) : min a b ≤ min b a := by
|
||||
theorem min_le_min [LE α] [Min α] [Std.LawfulOrderLeftLeaningMin α] [IsLinearOrder α] (a b : α) : min a b ≤ min b a := by
|
||||
apply (LawfulOrderInf.le_min_iff (min a b) b a).2
|
||||
rw [And.comm]
|
||||
by_cases h : a ≤ b
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1718,7 +1718,7 @@ theorem toArray_roc_append_toArray_roc {l m n : Nat} (h : l ≤ m) (h' : m ≤ n
|
||||
@[simp]
|
||||
theorem getElem_toArray_roc {m n i : Nat} (_h : i < (m<...=n).toArray.size) :
|
||||
(m<...=n).toArray[i]'_h = m + 1 + i := by
|
||||
simp [toArray_roc_eq_toArray_rco]
|
||||
simp [toArray_roc_eq_toArray_rco]
|
||||
|
||||
theorem getElem?_toArray_roc {m n i : Nat} :
|
||||
(m<...=n).toArray[i]? = if i < n - m then some (m + 1 + i) else none := by
|
||||
|
||||
@@ -248,11 +248,11 @@ instance : HasModel Int8 (BitVec 8) where
|
||||
le_iff_encode_le := by simp [LE.le, Int8.le]
|
||||
lt_iff_encode_lt := by simp [LT.lt, Int8.lt]
|
||||
|
||||
private theorem succ?_eq_minValueSealed {x : Int8} :
|
||||
theorem succ?_eq_minValueSealed {x : Int8} :
|
||||
UpwardEnumerable.succ? x = if x + 1 = minValueSealed then none else some (x + 1) :=
|
||||
(rfl)
|
||||
|
||||
private theorem succMany?_eq_maxValueSealed {i : Int8} :
|
||||
theorem succMany?_eq_maxValueSealed {i : Int8} :
|
||||
UpwardEnumerable.succMany? n i =
|
||||
have := i.minValue_le_toInt
|
||||
if h : i.toInt + n ≤ maxValueSealed.toInt then some (.ofIntLE _ (by omega) (maxValueSealed_def ▸ h)) else none :=
|
||||
@@ -605,12 +605,12 @@ theorem minValueSealed_def : minValueSealed = ISize.minValue := (rfl)
|
||||
theorem maxValueSealed_def : maxValueSealed = ISize.maxValue := (rfl)
|
||||
seal minValueSealed maxValueSealed
|
||||
|
||||
private theorem toBitVec_minValueSealed_eq_intMinSealed :
|
||||
theorem toBitVec_minValueSealed_eq_intMinSealed :
|
||||
minValueSealed.toBitVec = BitVec.Signed.intMinSealed System.Platform.numBits := by
|
||||
rw [minValueSealed_def, BitVec.Signed.intMinSealed_def, toBitVec_minValue]
|
||||
have := System.Platform.numBits_eq; generalize System.Platform.numBits = a at this ⊢
|
||||
rcases this with rfl | rfl <;> rfl
|
||||
private theorem toBitVec_maxValueSealed_eq_intMaxSealed :
|
||||
theorem toBitVec_maxValueSealed_eq_intMaxSealed :
|
||||
maxValueSealed.toBitVec = BitVec.Signed.intMaxSealed System.Platform.numBits := by
|
||||
rw [maxValueSealed_def, BitVec.Signed.intMaxSealed_def, toBitVec_maxValue]
|
||||
have := System.Platform.numBits_eq; generalize System.Platform.numBits = a at this ⊢
|
||||
|
||||
@@ -233,7 +233,7 @@ public theorem Subarray.toList_eq {xs : Subarray α} :
|
||||
simp [this, ListSlice.toList_eq, lslice]
|
||||
|
||||
-- TODO: The current `List.extract_eq_drop_take` should be called `List.extract_eq_take_drop`
|
||||
private theorem Std.Internal.List.extract_eq_drop_take' {l : List α} {start stop : Nat} :
|
||||
theorem Std.Internal.List.extract_eq_drop_take' {l : List α} {start stop : Nat} :
|
||||
l.extract start stop = (l.take stop).drop start := by
|
||||
simp [List.take_drop]
|
||||
by_cases start ≤ stop
|
||||
|
||||
@@ -94,7 +94,7 @@ public def String.utf8EncodeCharFast (c : Char) : List UInt8 :=
|
||||
(v >>> 6).toUInt8 &&& 0x3f ||| 0x80,
|
||||
v.toUInt8 &&& 0x3f ||| 0x80]
|
||||
|
||||
private theorem Nat.add_two_pow_eq_or_of_lt {b : Nat} (i : Nat) (b_lt : b < 2 ^ i) (a : Nat) :
|
||||
theorem Nat.add_two_pow_eq_or_of_lt {b : Nat} (i : Nat) (b_lt : b < 2 ^ i) (a : Nat) :
|
||||
b + 2 ^ i * a = b ||| 2 ^ i * a := by
|
||||
rw [Nat.add_comm, Nat.or_comm, Nat.two_pow_add_eq_or_of_lt b_lt]
|
||||
|
||||
|
||||
@@ -564,6 +564,28 @@ end Ring
|
||||
|
||||
end IsCharP
|
||||
|
||||
/--
|
||||
`PowIdentity α p` states that `x ^ p = x` holds for all elements of `α`.
|
||||
|
||||
The primary source of instances is Fermat's little theorem: for a finite field with `q` elements,
|
||||
`x ^ q = x` for every `x`. For `Fin p` or `ZMod p` with prime `p`, this gives `x ^ p = x`.
|
||||
|
||||
The `grind` ring solver uses this typeclass to add the relation `x ^ p - x = 0` to the
|
||||
Groebner basis, which allows it to reduce high-degree polynomials. Mathlib can provide
|
||||
instances for general finite fields via `FiniteField.pow_card`.
|
||||
-/
|
||||
class PowIdentity (α : Type u) [CommSemiring α] (p : outParam Nat) : Prop where
|
||||
/-- Every element satisfies `x ^ p = x`. -/
|
||||
pow_eq (x : α) : x ^ p = x
|
||||
|
||||
namespace PowIdentity
|
||||
|
||||
variable [CommSemiring α] [PowIdentity α p]
|
||||
|
||||
theorem pow (x : α) : x ^ p = x := pow_eq x
|
||||
|
||||
end PowIdentity
|
||||
|
||||
open AddCommGroup
|
||||
|
||||
theorem no_int_zero_divisors {α : Type u} [IntModule α] [NoNatZeroDivisors α] {k : Int} {a : α}
|
||||
|
||||
@@ -193,7 +193,7 @@ theorem mul_assoc (a b c : Q α) : mul (mul a b) c = mul a (mul b c) := by
|
||||
simp [Semiring.left_distrib, Semiring.right_distrib]; refine ⟨0, ?_⟩; ac_rfl
|
||||
|
||||
theorem mul_one (a : Q α) : mul a (natCast 1) = a := by
|
||||
obtain ⟨⟨_, _⟩⟩ := a; simp
|
||||
obtain ⟨⟨_, _⟩⟩ := a; simp
|
||||
|
||||
theorem one_mul (a : Q α) : mul (natCast 1) a = a := by
|
||||
obtain ⟨⟨_, _⟩⟩ := a; simp
|
||||
|
||||
@@ -156,6 +156,12 @@ instance [i : NeZero n] : ToInt.Pow (Fin n) (.co 0 n) where
|
||||
rw [pow_succ, ToInt.Mul.toInt_mul, ih, ← ToInt.wrap_toInt,
|
||||
← IntInterval.wrap_mul (by simp), Int.pow_succ, ToInt.wrap_toInt]
|
||||
|
||||
instance : PowIdentity (Fin 2) 2 where
|
||||
pow_eq x := by
|
||||
match x with
|
||||
| ⟨0, _⟩ => rfl
|
||||
| ⟨1, _⟩ => rfl
|
||||
|
||||
end Fin
|
||||
|
||||
end Lean.Grind
|
||||
|
||||
@@ -9,6 +9,7 @@ prelude
|
||||
public import Lean.Meta.Sorry
|
||||
public import Lean.Util.CollectAxioms
|
||||
public import Lean.OriginalConstKind
|
||||
import Lean.Compiler.MetaAttr
|
||||
import all Lean.OriginalConstKind -- for accessing `privateConstKindsExt`
|
||||
|
||||
public section
|
||||
@@ -208,8 +209,12 @@ where
|
||||
catch _ => pure ()
|
||||
|
||||
|
||||
def addAndCompile (decl : Declaration) (logCompileErrors : Bool := true) : CoreM Unit := do
|
||||
def addAndCompile (decl : Declaration) (logCompileErrors : Bool := true)
|
||||
(markMeta : Bool := false) : CoreM Unit := do
|
||||
addDecl decl
|
||||
if markMeta then
|
||||
for n in decl.getNames do
|
||||
modifyEnv (Lean.markMeta · n)
|
||||
compileDecl decl (logErrors := logCompileErrors)
|
||||
|
||||
end Lean
|
||||
|
||||
@@ -56,11 +56,11 @@ def markSparseCasesOn (env : Environment) (declName : Name) : Environment :=
|
||||
sparseCasesOnExt.tag env declName
|
||||
|
||||
/-- Is this a constructor elimination or a sparse casesOn? -/
|
||||
public def isSparseCasesOn (env : Environment) (declName : Name) : Bool :=
|
||||
def isSparseCasesOn (env : Environment) (declName : Name) : Bool :=
|
||||
sparseCasesOnExt.isTagged env declName
|
||||
|
||||
/-- Is this a `.casesOn`, a constructor elimination or a sparse casesOn? -/
|
||||
public def isCasesOnLike (env : Environment) (declName : Name) : Bool :=
|
||||
def isCasesOnLike (env : Environment) (declName : Name) : Bool :=
|
||||
isCasesOnRecursor env declName || isSparseCasesOn env declName
|
||||
|
||||
/--
|
||||
|
||||
@@ -54,7 +54,7 @@ unsafe def registerInitAttrUnsafe (attrName : Name) (runAfterImport : Bool) (ref
|
||||
descr := "initialization procedure for global references"
|
||||
-- We want to run `[init]` in declaration order
|
||||
preserveOrder := true
|
||||
getParam := fun declName stx => do
|
||||
getParam := fun declName stx => withoutExporting do
|
||||
let decl ← getConstInfo declName
|
||||
match (← Attribute.Builtin.getIdent? stx) with
|
||||
| some initFnName =>
|
||||
@@ -149,8 +149,6 @@ def setBuiltinInitAttr (env : Environment) (declName : Name) (initFnName : Name
|
||||
def declareBuiltin (forDecl : Name) (value : Expr) : CoreM Unit :=
|
||||
-- can always be private, not referenced directly except through emitted C code
|
||||
withoutExporting do
|
||||
-- TODO: needs an update-stage0 + prefer_native=true for breaking symbol name
|
||||
withExporting do
|
||||
let name ← mkAuxDeclName (kind := `_regBuiltin ++ forDecl)
|
||||
let type := mkApp (mkConst `IO) (mkConst `Unit)
|
||||
let decl := Declaration.defnDecl { name, levelParams := [], type, value, hints := ReducibilityHints.opaque,
|
||||
|
||||
@@ -774,7 +774,7 @@ where
|
||||
|
||||
mutual
|
||||
|
||||
private partial def emitBasicBlock (code : Code .impure) : EmitM Unit := do
|
||||
partial def emitBasicBlock (code : Code .impure) : EmitM Unit := do
|
||||
match code with
|
||||
| .jp (k := k) .. => emitBasicBlock k
|
||||
| .let decl k =>
|
||||
@@ -896,7 +896,7 @@ where
|
||||
emitUnreach : EmitM Unit := do
|
||||
emitLn "lean_internal_panic_unreachable();"
|
||||
|
||||
private partial def emitJoinPoints (code : Code .impure) : EmitM Unit := do
|
||||
partial def emitJoinPoints (code : Code .impure) : EmitM Unit := do
|
||||
match code with
|
||||
| .jp decl k =>
|
||||
emit decl.binderName; emitLn ":"
|
||||
@@ -906,7 +906,7 @@ private partial def emitJoinPoints (code : Code .impure) : EmitM Unit := do
|
||||
| .sset (k := k) .. | .uset (k := k) .. | .oset (k := k) .. => emitJoinPoints k
|
||||
| .cases .. | .return .. | .jmp .. | .unreach .. => return ()
|
||||
|
||||
private partial def emitCode (code : Code .impure) : EmitM Unit := do
|
||||
partial def emitCode (code : Code .impure) : EmitM Unit := do
|
||||
withEmitBlock do
|
||||
let declared ← declareVars code
|
||||
if declared then emitLn ""
|
||||
|
||||
@@ -12,7 +12,7 @@ import Lean.Compiler.InitAttr
|
||||
|
||||
namespace Lean.Compiler.LCNF
|
||||
|
||||
private structure CollectUsedDeclsState where
|
||||
structure CollectUsedDeclsState where
|
||||
visited : NameSet := {}
|
||||
localDecls : Array (Decl .impure) := #[]
|
||||
extSigs : Array (Signature .impure) := #[]
|
||||
|
||||
@@ -29,7 +29,7 @@ public def mkOrderedDeclSetExt : IO (EnvExtension (List Name × NameSet)) :=
|
||||
/--
|
||||
Set of declarations to be exported to other modules; visibility shared by base/mono/IR phases.
|
||||
-/
|
||||
private builtin_initialize publicDeclsExt : EnvExtension (List Name × NameSet) ← mkOrderedDeclSetExt
|
||||
builtin_initialize publicDeclsExt : EnvExtension (List Name × NameSet) ← mkOrderedDeclSetExt
|
||||
|
||||
public def isDeclPublic (env : Environment) (declName : Name) : Bool := Id.run do
|
||||
if !env.header.isModule then
|
||||
|
||||
@@ -142,10 +142,10 @@ partial def Code.toExprM (code : Code pu) : ToExprM Expr := do
|
||||
return .letE `dummy (mkConst ``Unit) value body true
|
||||
end
|
||||
|
||||
public def Code.toExpr (code : Code pu) (xs : Array FVarId := #[]) : Expr :=
|
||||
def Code.toExpr (code : Code pu) (xs : Array FVarId := #[]) : Expr :=
|
||||
run' code.toExprM xs
|
||||
|
||||
public def FunDecl.toExpr (decl : FunDecl pu) (xs : Array FVarId := #[]) : Expr :=
|
||||
def FunDecl.toExpr (decl : FunDecl pu) (xs : Array FVarId := #[]) : Expr :=
|
||||
run' decl.toExprM xs
|
||||
|
||||
end Lean.Compiler.LCNF
|
||||
|
||||
@@ -213,11 +213,22 @@ structure Context where
|
||||
-/
|
||||
expectedType : Option Expr
|
||||
|
||||
/--
|
||||
Key for the LCNF translation cache. `ignoreNoncomputable` is part of the key
|
||||
because entries cached in irrelevant positions skip the `checkComputable`
|
||||
check and must not be reused in relevant positions.
|
||||
-/
|
||||
structure CacheKey where
|
||||
expr : Expr
|
||||
expectedType? : Option Expr
|
||||
ignoreNoncomputable : Bool
|
||||
deriving BEq, Hashable
|
||||
|
||||
structure State where
|
||||
/-- Local context containing the original Lean types (not LCNF ones). -/
|
||||
lctx : LocalContext := {}
|
||||
/-- Cache from Lean regular expression to LCNF argument. -/
|
||||
cache : PHashMap (Expr × Option Expr) (Arg .pure) := {}
|
||||
cache : PHashMap CacheKey (Arg .pure) := {}
|
||||
/--
|
||||
Determines whether caching has been disabled due to finding a use of
|
||||
a constant marked with `never_extract`.
|
||||
@@ -473,7 +484,9 @@ partial def toLCNF (e : Expr) (eType : Expr) : CompilerM (Code .pure) := do
|
||||
where
|
||||
visitCore (e : Expr) : M (Arg .pure) := withIncRecDepth do
|
||||
let eType? := (← read).expectedType
|
||||
if let some arg := (← get).cache.find? (e, eType?) then
|
||||
let ignoreNoncomputable := (← read).ignoreNoncomputable
|
||||
let key : CacheKey := { expr := e, expectedType? := eType?, ignoreNoncomputable }
|
||||
if let some arg := (← get).cache.find? key then
|
||||
return arg
|
||||
let r : Arg .pure ← match e with
|
||||
| .app .. => visitApp e
|
||||
@@ -485,7 +498,7 @@ where
|
||||
| .lit lit => visitLit lit
|
||||
| .fvar fvarId => if (← get).toAny.contains fvarId then pure .erased else pure (.fvar fvarId)
|
||||
| .forallE .. | .mvar .. | .bvar .. | .sort .. => unreachable!
|
||||
modify fun s => if s.shouldCache then { s with cache := s.cache.insert (e, eType?) r } else s
|
||||
modify fun s => if s.shouldCache then { s with cache := s.cache.insert key r } else s
|
||||
return r
|
||||
|
||||
visit (e : Expr) : M (Arg .pure) := withIncRecDepth do
|
||||
|
||||
@@ -37,7 +37,7 @@ public def getStateByIdx? [Inhabited σ] (ext : ModuleEnvExtension σ) (env : En
|
||||
|
||||
end ModuleEnvExtension
|
||||
|
||||
private initialize modPkgExt : ModuleEnvExtension (Option PkgId) ←
|
||||
initialize modPkgExt : ModuleEnvExtension (Option PkgId) ←
|
||||
registerModuleEnvExtension (pure none)
|
||||
|
||||
/-- Returns the package (if any) of an imported module (by its index). -/
|
||||
|
||||
@@ -20,13 +20,13 @@ line parsing. Called from the C runtime via `@[export]` for backtrace display. -
|
||||
namespace Lean.Name.Demangle
|
||||
|
||||
/-- `String.dropPrefix?` returning a `String` instead of a `Slice`. -/
|
||||
private def dropPrefix? (s : String) (pre : String) : Option String :=
|
||||
def dropPrefix? (s : String) (pre : String) : Option String :=
|
||||
(s.dropPrefix? pre).map (·.toString)
|
||||
|
||||
private def isAllDigits (s : String) : Bool :=
|
||||
def isAllDigits (s : String) : Bool :=
|
||||
!s.isEmpty && s.all (·.isDigit)
|
||||
|
||||
private def nameToNameParts (n : Name) : Array NamePart :=
|
||||
def nameToNameParts (n : Name) : Array NamePart :=
|
||||
go n [] |>.toArray
|
||||
where
|
||||
go : Name → List NamePart → List NamePart
|
||||
@@ -34,17 +34,17 @@ where
|
||||
| .str pre s, acc => go pre (NamePart.str s :: acc)
|
||||
| .num pre n, acc => go pre (NamePart.num n :: acc)
|
||||
|
||||
private def namePartsToName (parts : Array NamePart) : Name :=
|
||||
def namePartsToName (parts : Array NamePart) : Name :=
|
||||
parts.foldl (fun acc p =>
|
||||
match p with
|
||||
| .str s => acc.mkStr s
|
||||
| .num n => acc.mkNum n) .anonymous
|
||||
|
||||
/-- Format name parts using `Name.toString` for correct escaping. -/
|
||||
private def formatNameParts (comps : Array NamePart) : String :=
|
||||
def formatNameParts (comps : Array NamePart) : String :=
|
||||
if comps.isEmpty then "" else (namePartsToName comps).toString
|
||||
|
||||
private def matchSuffix (c : NamePart) : Option String :=
|
||||
def matchSuffix (c : NamePart) : Option String :=
|
||||
match c with
|
||||
| NamePart.str s =>
|
||||
if s == "_redArg" then some "arity↓"
|
||||
@@ -58,12 +58,12 @@ private def matchSuffix (c : NamePart) : Option String :=
|
||||
else none
|
||||
| _ => none
|
||||
|
||||
private def isSpecIndex (c : NamePart) : Bool :=
|
||||
def isSpecIndex (c : NamePart) : Bool :=
|
||||
match c with
|
||||
| NamePart.str s => (dropPrefix? s "spec_").any isAllDigits
|
||||
| _ => false
|
||||
|
||||
private def stripPrivate (comps : Array NamePart) (start stop : Nat) :
|
||||
def stripPrivate (comps : Array NamePart) (start stop : Nat) :
|
||||
Nat × Bool :=
|
||||
if stop - start >= 3 && comps[start]? == some (NamePart.str "_private") then
|
||||
Id.run do
|
||||
@@ -75,11 +75,11 @@ private def stripPrivate (comps : Array NamePart) (start stop : Nat) :
|
||||
else
|
||||
(start, false)
|
||||
|
||||
private structure SpecEntry where
|
||||
structure SpecEntry where
|
||||
name : String
|
||||
flags : Array String
|
||||
|
||||
private def processSpecContext (comps : Array NamePart) : SpecEntry := Id.run do
|
||||
def processSpecContext (comps : Array NamePart) : SpecEntry := Id.run do
|
||||
let mut begin_ := 0
|
||||
if comps.size >= 3 && comps[0]? == some (NamePart.str "_private") then
|
||||
for i in [1:comps.size] do
|
||||
@@ -99,7 +99,7 @@ private def processSpecContext (comps : Array NamePart) : SpecEntry := Id.run do
|
||||
else parts := parts.push c
|
||||
{ name := formatNameParts parts, flags }
|
||||
|
||||
private def postprocessNameParts (components : Array NamePart) : String := Id.run do
|
||||
def postprocessNameParts (components : Array NamePart) : String := Id.run do
|
||||
if components.isEmpty then return ""
|
||||
|
||||
let (privStart, isPrivate) := stripPrivate components 0 components.size
|
||||
@@ -206,14 +206,14 @@ private def postprocessNameParts (components : Array NamePart) : String := Id.ru
|
||||
|
||||
return result
|
||||
|
||||
private def demangleBody (body : String) : String :=
|
||||
def demangleBody (body : String) : String :=
|
||||
let name := Name.demangle body
|
||||
postprocessNameParts (nameToNameParts name)
|
||||
|
||||
/-- Split a `lp_`-prefixed symbol into (demangled body, package name).
|
||||
Tries each underscore as a split point; the first valid split (shortest single-component
|
||||
package where the remainder is a valid mangled name) is correct. -/
|
||||
private def demangleWithPkg (s : String) : Option (String × String) := do
|
||||
def demangleWithPkg (s : String) : Option (String × String) := do
|
||||
for ⟨pos, h⟩ in s.positions do
|
||||
if pos.get h == '_' && pos ≠ s.startPos then
|
||||
let nextPos := pos.next h
|
||||
@@ -230,12 +230,12 @@ private def demangleWithPkg (s : String) : Option (String × String) := do
|
||||
return (demangleBody body, pkgName)
|
||||
none
|
||||
|
||||
private def stripColdSuffix (s : String) : String × String :=
|
||||
def stripColdSuffix (s : String) : String × String :=
|
||||
match s.find? ".cold" with
|
||||
| some pos => (s.extract s.startPos pos, s.extract pos s.endPos)
|
||||
| none => (s, "")
|
||||
|
||||
private def demangleCore (s : String) : Option String := do
|
||||
def demangleCore (s : String) : Option String := do
|
||||
-- _init_l_
|
||||
if let some body := dropPrefix? s "_init_l_" then
|
||||
if !body.isEmpty then return s!"[init] {demangleBody body}"
|
||||
@@ -291,17 +291,17 @@ public def demangleSymbol (symbol : String) : Option String := do
|
||||
if coldSuffix.isEmpty then return result
|
||||
else return s!"{result} {coldSuffix}"
|
||||
|
||||
private def skipWhile (s : String) (pos : s.Pos) (pred : Char → Bool) : s.Pos :=
|
||||
def skipWhile (s : String) (pos : s.Pos) (pred : Char → Bool) : s.Pos :=
|
||||
if h : pos = s.endPos then pos
|
||||
else if pred (pos.get h) then skipWhile s (pos.next h) pred
|
||||
else pos
|
||||
termination_by pos
|
||||
|
||||
private def splitAt₂ (s : String) (p₁ p₂ : s.Pos) : String × String × String :=
|
||||
def splitAt₂ (s : String) (p₁ p₂ : s.Pos) : String × String × String :=
|
||||
(s.extract s.startPos p₁, s.extract p₁ p₂, s.extract p₂ s.endPos)
|
||||
|
||||
/-- Extract the symbol from a backtrace line (Linux glibc or macOS format). -/
|
||||
private def extractSymbol (line : String) :
|
||||
def extractSymbol (line : String) :
|
||||
Option (String × String × String) :=
|
||||
tryLinux line |>.orElse (fun _ => tryMacOS line)
|
||||
where
|
||||
|
||||
@@ -400,7 +400,7 @@ Namely:
|
||||
def parseMessageMetaData (input : String) : Except String MessageMetaData :=
|
||||
messageMetaDataParser input |>.run input
|
||||
|
||||
public inductive MessageDirection where
|
||||
inductive MessageDirection where
|
||||
| clientToServer
|
||||
| serverToClient
|
||||
deriving Inhabited, FromJson, ToJson
|
||||
|
||||
@@ -227,7 +227,7 @@ variable {β : Type v}
|
||||
set_option linter.unusedVariables.funArgs false in
|
||||
@[specialize]
|
||||
partial def forInAux {α : Type u} {β : Type v} {m : Type v → Type w} [Monad m] [inh : Inhabited β]
|
||||
(f : α → β → m (ForInStep β)) (n : PersistentArrayNode α) (b : β) : m (ForInStep β) := do
|
||||
(f : α → β → m (ForInStep β)) (n : @&PersistentArrayNode α) (b : β) : m (ForInStep β) := do
|
||||
let mut b := b
|
||||
match n with
|
||||
| leaf vs =>
|
||||
@@ -243,7 +243,7 @@ partial def forInAux {α : Type u} {β : Type v} {m : Type v → Type w} [Monad
|
||||
| ForInStep.yield bNew => b := bNew
|
||||
return ForInStep.yield b
|
||||
|
||||
@[specialize] protected def forIn (t : PersistentArray α) (init : β) (f : α → β → m (ForInStep β)) : m β := do
|
||||
@[specialize] protected def forIn (t : @&PersistentArray α) (init : β) (f : α → β → m (ForInStep β)) : m β := do
|
||||
match (← forInAux (inh := ⟨init⟩) f t.root init) with
|
||||
| ForInStep.done b => pure b
|
||||
| ForInStep.yield b =>
|
||||
|
||||
@@ -153,7 +153,7 @@ partial def findAtAux [BEq α] (keys : Array α) (vals : Array β) (heq : keys.s
|
||||
else findAtAux keys vals heq (i+1) k
|
||||
else none
|
||||
|
||||
partial def findAux [BEq α] : Node α β → USize → α → Option β
|
||||
partial def findAux [BEq α] : @&Node α β → USize → α → Option β
|
||||
| Node.entries entries, h, k =>
|
||||
let j := (mod2Shift h shift).toNat
|
||||
match entries[j]! with
|
||||
@@ -162,7 +162,7 @@ partial def findAux [BEq α] : Node α β → USize → α → Option β
|
||||
| Entry.entry k' v => if k == k' then some v else none
|
||||
| Node.collision keys vals heq, _, k => findAtAux keys vals heq 0 k
|
||||
|
||||
def find? {_ : BEq α} {_ : Hashable α} : PersistentHashMap α β → α → Option β
|
||||
def find? {_ : BEq α} {_ : Hashable α} : @&PersistentHashMap α β → α → Option β
|
||||
| { root }, k => findAux root (hash k |>.toUSize) k
|
||||
|
||||
instance {_ : BEq α} {_ : Hashable α} : GetElem (PersistentHashMap α β) α (Option β) fun _ _ => True where
|
||||
@@ -184,7 +184,7 @@ partial def findEntryAtAux [BEq α] (keys : Array α) (vals : Array β) (heq : k
|
||||
else findEntryAtAux keys vals heq (i+1) k
|
||||
else none
|
||||
|
||||
partial def findEntryAux [BEq α] : Node α β → USize → α → Option (α × β)
|
||||
partial def findEntryAux [BEq α] : @&Node α β → USize → α → Option (α × β)
|
||||
| Node.entries entries, h, k =>
|
||||
let j := (mod2Shift h shift).toNat
|
||||
match entries[j]! with
|
||||
@@ -193,7 +193,7 @@ partial def findEntryAux [BEq α] : Node α β → USize → α → Option (α
|
||||
| Entry.entry k' v => if k == k' then some (k', v) else none
|
||||
| Node.collision keys vals heq, _, k => findEntryAtAux keys vals heq 0 k
|
||||
|
||||
def findEntry? {_ : BEq α} {_ : Hashable α} : PersistentHashMap α β → α → Option (α × β)
|
||||
def findEntry? {_ : BEq α} {_ : Hashable α} : @&PersistentHashMap α β → α → Option (α × β)
|
||||
| { root }, k => findEntryAux root (hash k |>.toUSize) k
|
||||
|
||||
partial def findKeyDAtAux [BEq α] (keys : Array α) (vals : Array β) (heq : keys.size = vals.size) (i : Nat) (k : α) (k₀ : α) : α :=
|
||||
@@ -320,7 +320,7 @@ def foldl {_ : BEq α} {_ : Hashable α} (map : PersistentHashMap α β) (f : σ
|
||||
Id.run <| map.foldlM (pure <| f · · ·) init
|
||||
|
||||
protected def forIn {_ : BEq α} {_ : Hashable α} [Monad m]
|
||||
(map : PersistentHashMap α β) (init : σ) (f : α × β → σ → m (ForInStep σ)) : m σ := do
|
||||
(map : @&PersistentHashMap α β) (init : σ) (f : α × β → σ → m (ForInStep σ)) : m σ := do
|
||||
let intoError : ForInStep σ → Except σ σ
|
||||
| .done s => .error s
|
||||
| .yield s => .ok s
|
||||
|
||||
@@ -131,9 +131,9 @@ partial def find? (t : Trie α) (s : String) : Option α :=
|
||||
loop 0 t
|
||||
|
||||
/-- Returns an `Array` of all values in the trie, in no particular order. -/
|
||||
partial def values (t : Trie α) : Array α := go t |>.run #[] |>.2
|
||||
partial def values (t : @&Trie α) : Array α := go t |>.run #[] |>.2
|
||||
where
|
||||
go : Trie α → StateM (Array α) Unit
|
||||
go : @&Trie α → StateM (Array α) Unit
|
||||
| leaf a? => do
|
||||
if let some a := a? then
|
||||
modify (·.push a)
|
||||
|
||||
@@ -43,14 +43,14 @@ public structure State where
|
||||
/-- Footnotes -/
|
||||
footnotes : Array (String × String) := #[]
|
||||
|
||||
private def combineBlocks (prior current : String) :=
|
||||
def combineBlocks (prior current : String) :=
|
||||
if prior.isEmpty then current
|
||||
else if current.isEmpty then prior
|
||||
else if prior.endsWith "\n\n" then prior ++ current
|
||||
else if prior.endsWith "\n" then prior ++ "\n" ++ current
|
||||
else prior ++ "\n\n" ++ current
|
||||
|
||||
private def State.endBlock (state : State) : State :=
|
||||
def State.endBlock (state : State) : State :=
|
||||
{ state with
|
||||
priorBlocks :=
|
||||
combineBlocks state.priorBlocks state.currentBlock ++
|
||||
@@ -60,13 +60,13 @@ private def State.endBlock (state : State) : State :=
|
||||
footnotes := #[]
|
||||
}
|
||||
|
||||
private def State.render (state : State) : String :=
|
||||
def State.render (state : State) : String :=
|
||||
state.endBlock.priorBlocks
|
||||
|
||||
private def State.push (state : State) (txt : String) : State :=
|
||||
def State.push (state : State) (txt : String) : State :=
|
||||
{ state with currentBlock := state.currentBlock ++ txt }
|
||||
|
||||
private def State.endsWith (state : State) (txt : String) : Bool :=
|
||||
def State.endsWith (state : State) (txt : String) : Bool :=
|
||||
state.currentBlock.endsWith txt || (state.currentBlock.isEmpty && state.priorBlocks.endsWith txt)
|
||||
|
||||
end MarkdownM
|
||||
@@ -150,7 +150,7 @@ public class MarkdownBlock (i : Type u) (b : Type v) where
|
||||
public instance : MarkdownBlock i Empty where
|
||||
toMarkdown := nofun
|
||||
|
||||
private def escape (s : String) : String := Id.run do
|
||||
def escape (s : String) : String := Id.run do
|
||||
let mut s' := ""
|
||||
let mut iter := s.startPos
|
||||
while h : ¬iter.IsAtEnd do
|
||||
@@ -163,7 +163,7 @@ private def escape (s : String) : String := Id.run do
|
||||
where
|
||||
isSpecial c := "*_`-+.!<>[]{}()#".any (· == c)
|
||||
|
||||
private def quoteCode (str : String) : String := Id.run do
|
||||
def quoteCode (str : String) : String := Id.run do
|
||||
let mut longest := 0
|
||||
let mut current := 0
|
||||
let mut iter := str.startPos
|
||||
@@ -179,7 +179,7 @@ private def quoteCode (str : String) : String := Id.run do
|
||||
let str := if str.startsWith "`" || str.endsWith "`" then " " ++ str ++ " " else str
|
||||
backticks ++ str ++ backticks
|
||||
|
||||
private partial def trimLeft (inline : Inline i) : (String × Inline i) := go [inline]
|
||||
partial def trimLeft (inline : Inline i) : (String × Inline i) := go [inline]
|
||||
where
|
||||
go : List (Inline i) → String × Inline i
|
||||
| [] => ("", .empty)
|
||||
@@ -194,7 +194,7 @@ where
|
||||
| .concat xs :: more => go (xs.toList ++ more)
|
||||
| here :: more => ("", here ++ .concat more.toArray)
|
||||
|
||||
private partial def trimRight (inline : Inline i) : (Inline i × String) := go [inline]
|
||||
partial def trimRight (inline : Inline i) : (Inline i × String) := go [inline]
|
||||
where
|
||||
go : List (Inline i) → Inline i × String
|
||||
| [] => (.empty, "")
|
||||
@@ -209,13 +209,13 @@ where
|
||||
| .concat xs :: more => go (xs.reverse.toList ++ more)
|
||||
| here :: more => (.concat more.toArray.reverse ++ here, "")
|
||||
|
||||
private def trim (inline : Inline i) : (String × Inline i × String) :=
|
||||
def trim (inline : Inline i) : (String × Inline i × String) :=
|
||||
let (pre, more) := trimLeft inline
|
||||
let (mid, post) := trimRight more
|
||||
(pre, mid, post)
|
||||
|
||||
open MarkdownM in
|
||||
private partial def inlineMarkdown [MarkdownInline i] : Inline i → MarkdownM Unit
|
||||
partial def inlineMarkdown [MarkdownInline i] : Inline i → MarkdownM Unit
|
||||
| .text s =>
|
||||
push (escape s)
|
||||
| .linebreak s => do
|
||||
@@ -271,7 +271,7 @@ private partial def inlineMarkdown [MarkdownInline i] : Inline i → MarkdownM U
|
||||
public instance [MarkdownInline i] : ToMarkdown (Inline i) where
|
||||
toMarkdown inline := private inlineMarkdown inline
|
||||
|
||||
private def quoteCodeBlock (indent : Nat) (str : String) : String := Id.run do
|
||||
def quoteCodeBlock (indent : Nat) (str : String) : String := Id.run do
|
||||
let mut longest := 2
|
||||
let mut current := 0
|
||||
let mut iter := str.startPos
|
||||
@@ -292,7 +292,7 @@ private def quoteCodeBlock (indent : Nat) (str : String) : String := Id.run do
|
||||
backticks ++ "\n" ++ out ++ backticks ++ "\n"
|
||||
|
||||
open MarkdownM in
|
||||
private partial def blockMarkdown [MarkdownInline i] [MarkdownBlock i b] : Block i b → MarkdownM Unit
|
||||
partial def blockMarkdown [MarkdownInline i] [MarkdownBlock i b] : Block i b → MarkdownM Unit
|
||||
| .para xs => do
|
||||
for i in xs do
|
||||
ToMarkdown.toMarkdown i
|
||||
@@ -345,7 +345,7 @@ public instance [MarkdownInline i] [MarkdownBlock i b] : ToMarkdown (Block i b)
|
||||
|
||||
open MarkdownM in
|
||||
open ToMarkdown in
|
||||
private partial def partMarkdown [MarkdownInline i] [MarkdownBlock i b] (level : Nat) (part : Part i b p) : MarkdownM Unit := do
|
||||
partial def partMarkdown [MarkdownInline i] [MarkdownBlock i b] (level : Nat) (part : Part i b p) : MarkdownM Unit := do
|
||||
push ("".pushn '#' (level + 1))
|
||||
push " "
|
||||
for i in part.title do
|
||||
|
||||
@@ -18,7 +18,7 @@ open Lean.Doc.Syntax
|
||||
local instance : Coe Char ParserFn where
|
||||
coe := chFn
|
||||
|
||||
private partial def atLeastAux (n : Nat) (p : ParserFn) : ParserFn := fun c s => Id.run do
|
||||
partial def atLeastAux (n : Nat) (p : ParserFn) : ParserFn := fun c s => Id.run do
|
||||
let iniSz := s.stackSize
|
||||
let iniPos := s.pos
|
||||
let mut s := p c s
|
||||
@@ -30,7 +30,7 @@ private partial def atLeastAux (n : Nat) (p : ParserFn) : ParserFn := fun c s =>
|
||||
s := s.mkNode nullKind iniSz
|
||||
atLeastAux (n - 1) p c s
|
||||
|
||||
private def atLeastFn (n : Nat) (p : ParserFn) : ParserFn := fun c s =>
|
||||
def atLeastFn (n : Nat) (p : ParserFn) : ParserFn := fun c s =>
|
||||
let iniSz := s.stackSize
|
||||
let s := atLeastAux n p c s
|
||||
s.mkNode nullKind iniSz
|
||||
@@ -40,9 +40,9 @@ A parser that does nothing.
|
||||
-/
|
||||
public def skipFn : ParserFn := fun _ s => s
|
||||
|
||||
private def eatSpaces := takeWhileFn (· == ' ')
|
||||
def eatSpaces := takeWhileFn (· == ' ')
|
||||
|
||||
private def repFn : Nat → ParserFn → ParserFn
|
||||
def repFn : Nat → ParserFn → ParserFn
|
||||
| 0, _ => skipFn
|
||||
| n+1, p => p >> repFn n p
|
||||
|
||||
@@ -55,7 +55,7 @@ partial def satisfyFn' (p : Char → Bool)
|
||||
else if p (c.get' i h) then s.next' c i h
|
||||
else s.mkUnexpectedError errorMsg
|
||||
|
||||
private partial def atMostAux (n : Nat) (p : ParserFn) (msg : String) : ParserFn :=
|
||||
partial def atMostAux (n : Nat) (p : ParserFn) (msg : String) : ParserFn :=
|
||||
fun c s => Id.run do
|
||||
let iniSz := s.stackSize
|
||||
let iniPos := s.pos
|
||||
@@ -70,13 +70,13 @@ private partial def atMostAux (n : Nat) (p : ParserFn) (msg : String) : ParserFn
|
||||
s := s.mkNode nullKind iniSz
|
||||
atMostAux (n - 1) p msg c s
|
||||
|
||||
private def atMostFn (n : Nat) (p : ParserFn) (msg : String) : ParserFn := fun c s =>
|
||||
def atMostFn (n : Nat) (p : ParserFn) (msg : String) : ParserFn := fun c s =>
|
||||
let iniSz := s.stackSize
|
||||
let s := atMostAux n p msg c s
|
||||
s.mkNode nullKind iniSz
|
||||
|
||||
/-- Like `satisfyFn`, but allows any escape sequence through -/
|
||||
private partial def satisfyEscFn (p : Char → Bool)
|
||||
partial def satisfyEscFn (p : Char → Bool)
|
||||
(errorMsg : String := "unexpected character") :
|
||||
ParserFn := fun c s =>
|
||||
let i := s.pos
|
||||
@@ -89,7 +89,7 @@ private partial def satisfyEscFn (p : Char → Bool)
|
||||
else if p (c.get' i h) then s.next' c i h
|
||||
else s.mkUnexpectedError errorMsg
|
||||
|
||||
private partial def takeUntilEscFn (p : Char → Bool) : ParserFn := fun c s =>
|
||||
partial def takeUntilEscFn (p : Char → Bool) : ParserFn := fun c s =>
|
||||
let i := s.pos
|
||||
if h : c.atEnd i then s
|
||||
else if c.get' i h == '\\' then
|
||||
@@ -100,7 +100,7 @@ private partial def takeUntilEscFn (p : Char → Bool) : ParserFn := fun c s =>
|
||||
else if p (c.get' i h) then s
|
||||
else takeUntilEscFn p c (s.next' c i h)
|
||||
|
||||
private partial def takeWhileEscFn (p : Char → Bool) : ParserFn := takeUntilEscFn (not ∘ p)
|
||||
partial def takeWhileEscFn (p : Char → Bool) : ParserFn := takeUntilEscFn (not ∘ p)
|
||||
|
||||
/--
|
||||
Parses as `p`, but discards the result.
|
||||
@@ -111,7 +111,7 @@ public def ignoreFn (p : ParserFn) : ParserFn := fun c s =>
|
||||
s'.shrinkStack iniSz
|
||||
|
||||
|
||||
private def withInfoSyntaxFn (p : ParserFn) (infoP : SourceInfo → ParserFn) : ParserFn := fun c s =>
|
||||
def withInfoSyntaxFn (p : ParserFn) (infoP : SourceInfo → ParserFn) : ParserFn := fun c s =>
|
||||
let iniSz := s.stxStack.size
|
||||
let startPos := s.pos
|
||||
let s := p c s
|
||||
@@ -121,7 +121,7 @@ private def withInfoSyntaxFn (p : ParserFn) (infoP : SourceInfo → ParserFn) :
|
||||
let info := SourceInfo.original leading startPos trailing stopPos
|
||||
infoP info c (s.shrinkStack iniSz)
|
||||
|
||||
private def unescapeStr (str : String) : String := Id.run do
|
||||
def unescapeStr (str : String) : String := Id.run do
|
||||
let mut out := ""
|
||||
let mut iter := str.startPos
|
||||
while h : ¬iter.IsAtEnd do
|
||||
@@ -135,7 +135,7 @@ private def unescapeStr (str : String) : String := Id.run do
|
||||
out := out.push c
|
||||
out
|
||||
|
||||
private def asStringAux (quoted : Bool) (startPos : String.Pos.Raw) (transform : String → String) :
|
||||
def asStringAux (quoted : Bool) (startPos : String.Pos.Raw) (transform : String → String) :
|
||||
ParserFn := fun c s =>
|
||||
let stopPos := s.pos
|
||||
let leading := c.mkEmptySubstringAt startPos
|
||||
@@ -156,26 +156,26 @@ public def asStringFn (p : ParserFn) (quoted := false) (transform : String → S
|
||||
if s.hasError then s
|
||||
else asStringAux quoted startPos transform c (s.shrinkStack iniSz)
|
||||
|
||||
private def checkCol0Fn (errorMsg : String) : ParserFn := fun c s =>
|
||||
def checkCol0Fn (errorMsg : String) : ParserFn := fun c s =>
|
||||
let pos := c.fileMap.toPosition s.pos
|
||||
if pos.column = 1 then s
|
||||
else s.mkError errorMsg
|
||||
|
||||
private def _root_.Lean.Parser.ParserContext.currentColumn
|
||||
def _root_.Lean.Parser.ParserContext.currentColumn
|
||||
(c : ParserContext) (s : ParserState) : Nat :=
|
||||
c.fileMap.toPosition s.pos |>.column
|
||||
|
||||
private def pushColumn : ParserFn := fun c s =>
|
||||
def pushColumn : ParserFn := fun c s =>
|
||||
let col := c.fileMap.toPosition s.pos |>.column
|
||||
s.pushSyntax <| Syntax.mkLit `column (toString col) (SourceInfo.synthetic s.pos s.pos)
|
||||
|
||||
private def guardColumn (p : Nat → Bool) (message : String) : ParserFn := fun c s =>
|
||||
def guardColumn (p : Nat → Bool) (message : String) : ParserFn := fun c s =>
|
||||
if p (c.currentColumn s) then s else s.mkErrorAt message s.pos
|
||||
|
||||
private def guardMinColumn (min : Nat) (description : String := s!"expected column at least {min}") : ParserFn :=
|
||||
def guardMinColumn (min : Nat) (description : String := s!"expected column at least {min}") : ParserFn :=
|
||||
guardColumn (· ≥ min) description
|
||||
|
||||
private def withCurrentColumn (p : Nat → ParserFn) : ParserFn := fun c s =>
|
||||
def withCurrentColumn (p : Nat → ParserFn) : ParserFn := fun c s =>
|
||||
p (c.currentColumn s) c s
|
||||
|
||||
|
||||
@@ -183,7 +183,7 @@ private def withCurrentColumn (p : Nat → ParserFn) : ParserFn := fun c s =>
|
||||
We can only start a nestable block if we're immediately after a newline followed by a sequence of
|
||||
nestable block openers
|
||||
-/
|
||||
private def onlyBlockOpeners : ParserFn := fun c s =>
|
||||
def onlyBlockOpeners : ParserFn := fun c s =>
|
||||
let position := c.fileMap.toPosition s.pos
|
||||
let lineStart := c.fileMap.lineStart position.line
|
||||
let ok : Bool := Id.run do
|
||||
@@ -206,7 +206,7 @@ private def onlyBlockOpeners : ParserFn := fun c s =>
|
||||
if ok then s
|
||||
else s.mkErrorAt "beginning of line or sequence of nestable block openers" s.pos
|
||||
|
||||
private def nl := satisfyFn (· == '\n') "newline"
|
||||
def nl := satisfyFn (· == '\n') "newline"
|
||||
|
||||
/--
|
||||
Construct a “fake” atom with the given string content and source information.
|
||||
@@ -225,13 +225,13 @@ current position.
|
||||
Normally, atoms are always substrings of the original input; however, Verso's concrete syntax is
|
||||
different enough from Lean's that this isn't always a good match.
|
||||
-/
|
||||
private def fakeAtomHere (str : String) : ParserFn :=
|
||||
def fakeAtomHere (str : String) : ParserFn :=
|
||||
withInfoSyntaxFn skip.fn (fun info => fakeAtom str (info := info))
|
||||
|
||||
private def pushMissing : ParserFn := fun _c s =>
|
||||
def pushMissing : ParserFn := fun _c s =>
|
||||
s.pushSyntax .missing
|
||||
|
||||
private def strFn (str : String) : ParserFn := asStringFn <| fun c s =>
|
||||
def strFn (str : String) : ParserFn := asStringFn <| fun c s =>
|
||||
let rec go (iter : str.Pos) (s : ParserState) :=
|
||||
if h : iter.IsAtEnd then s
|
||||
else
|
||||
@@ -260,10 +260,10 @@ public instance : Ord OrderedListType where
|
||||
| .parenAfter, .numDot => .gt
|
||||
| .parenAfter, .parenAfter => .eq
|
||||
|
||||
private def OrderedListType.all : List OrderedListType :=
|
||||
def OrderedListType.all : List OrderedListType :=
|
||||
[.numDot, .parenAfter]
|
||||
|
||||
private theorem OrderedListType.all_complete : ∀ x : OrderedListType, x ∈ all := by
|
||||
theorem OrderedListType.all_complete : ∀ x : OrderedListType, x ∈ all := by
|
||||
unfold all; intro x; cases x <;> repeat constructor
|
||||
|
||||
/--
|
||||
@@ -288,40 +288,40 @@ public instance : Ord UnorderedListType where
|
||||
| .plus, .plus => .eq
|
||||
| .plus, _ => .gt
|
||||
|
||||
private def UnorderedListType.all : List UnorderedListType :=
|
||||
def UnorderedListType.all : List UnorderedListType :=
|
||||
[.asterisk, .dash, .plus]
|
||||
|
||||
private theorem UnorderedListType.all_complete : ∀ x : UnorderedListType, x ∈ all := by
|
||||
theorem UnorderedListType.all_complete : ∀ x : UnorderedListType, x ∈ all := by
|
||||
unfold all; intro x; cases x <;> repeat constructor
|
||||
|
||||
private def unorderedListIndicator (type : UnorderedListType) : ParserFn :=
|
||||
def unorderedListIndicator (type : UnorderedListType) : ParserFn :=
|
||||
asStringFn <|
|
||||
match type with
|
||||
| .asterisk => chFn '*'
|
||||
| .dash => chFn '-'
|
||||
| .plus => chFn '+'
|
||||
|
||||
private def orderedListIndicator (type : OrderedListType) : ParserFn :=
|
||||
def orderedListIndicator (type : OrderedListType) : ParserFn :=
|
||||
asStringFn <|
|
||||
takeWhile1Fn (·.isDigit) "digits" >>
|
||||
match type with
|
||||
| .numDot => chFn '.'
|
||||
| .parenAfter => chFn ')'
|
||||
|
||||
private def blankLine : ParserFn :=
|
||||
def blankLine : ParserFn :=
|
||||
nodeFn `blankLine <| atomicFn <| asStringFn <| takeWhileFn (· == ' ') >> nl
|
||||
|
||||
private def endLine : ParserFn :=
|
||||
def endLine : ParserFn :=
|
||||
ignoreFn <| atomicFn <| asStringFn <| takeWhileFn (· == ' ') >> eoiFn
|
||||
|
||||
private def bullet := atomicFn (go UnorderedListType.all)
|
||||
def bullet := atomicFn (go UnorderedListType.all)
|
||||
where
|
||||
go
|
||||
| [] => fun _ s => s.mkError "no list type"
|
||||
| [x] => atomicFn (unorderedListIndicator x)
|
||||
| x :: xs => atomicFn (unorderedListIndicator x) <|> go xs
|
||||
|
||||
private def numbering := atomicFn (go OrderedListType.all)
|
||||
def numbering := atomicFn (go OrderedListType.all)
|
||||
where
|
||||
go
|
||||
| [] => fun _ s => s.mkError "no list type"
|
||||
@@ -374,7 +374,7 @@ public def inlineTextChar : ParserFn := fun c s =>
|
||||
/-- Return some inline text up to the next inline opener or the end of
|
||||
the line, whichever is first. Always consumes at least one
|
||||
logical character on success, taking escaping into account. -/
|
||||
private def inlineText : ParserFn :=
|
||||
def inlineText : ParserFn :=
|
||||
asStringFn (transform := unescapeStr) <| atomicFn inlineTextChar >> manyFn inlineTextChar
|
||||
|
||||
/--
|
||||
@@ -410,23 +410,23 @@ public def val : ParserFn := fun c s =>
|
||||
else
|
||||
s.mkError "expected identifier, string, or number"
|
||||
|
||||
private def withCurrentStackSize (p : Nat → ParserFn) : ParserFn := fun c s =>
|
||||
def withCurrentStackSize (p : Nat → ParserFn) : ParserFn := fun c s =>
|
||||
p s.stxStack.size c s
|
||||
|
||||
/-- Match the character indicated, pushing nothing to the stack in case of success -/
|
||||
private def skipChFn (c : Char) : ParserFn :=
|
||||
def skipChFn (c : Char) : ParserFn :=
|
||||
satisfyFn (· == c) c.toString
|
||||
|
||||
private def skipToNewline : ParserFn :=
|
||||
def skipToNewline : ParserFn :=
|
||||
takeUntilFn (· == '\n')
|
||||
|
||||
private def skipToSpace : ParserFn :=
|
||||
def skipToSpace : ParserFn :=
|
||||
takeUntilFn (· == ' ')
|
||||
|
||||
private def skipRestOfLine : ParserFn :=
|
||||
def skipRestOfLine : ParserFn :=
|
||||
skipToNewline >> (eoiFn <|> nl)
|
||||
|
||||
private def skipBlock : ParserFn :=
|
||||
def skipBlock : ParserFn :=
|
||||
skipToNewline >> manyFn nonEmptyLine >> takeWhileFn (· == '\n')
|
||||
where
|
||||
nonEmptyLine : ParserFn :=
|
||||
@@ -444,7 +444,7 @@ public def recoverBlock (p : ParserFn) (final : ParserFn := skipFn) : ParserFn :
|
||||
ignoreFn skipBlock >> final
|
||||
|
||||
-- Like `recoverBlock` but stores recovered errors at the original error position.
|
||||
private def recoverBlockAtErrPos (p : ParserFn) : ParserFn := fun c s =>
|
||||
def recoverBlockAtErrPos (p : ParserFn) : ParserFn := fun c s =>
|
||||
let s := p c s
|
||||
if let some msg := s.errorMsg then
|
||||
let errPos := s.pos
|
||||
@@ -457,36 +457,36 @@ private def recoverBlockAtErrPos (p : ParserFn) : ParserFn := fun c s =>
|
||||
recoveredErrors := s.recoveredErrors.push (errPos, s'.stxStack, msg)}
|
||||
else s
|
||||
|
||||
private def recoverBlockWith (stxs : Array Syntax) (p : ParserFn) : ParserFn :=
|
||||
def recoverBlockWith (stxs : Array Syntax) (p : ParserFn) : ParserFn :=
|
||||
recoverFn p fun rctx =>
|
||||
ignoreFn skipBlock >>
|
||||
show ParserFn from
|
||||
fun _ s => stxs.foldl (init := s.shrinkStack rctx.initialSize) (·.pushSyntax ·)
|
||||
|
||||
private def recoverLine (p : ParserFn) : ParserFn :=
|
||||
def recoverLine (p : ParserFn) : ParserFn :=
|
||||
recoverFn p fun _ =>
|
||||
ignoreFn skipRestOfLine
|
||||
|
||||
private def recoverWs (p : ParserFn) : ParserFn :=
|
||||
def recoverWs (p : ParserFn) : ParserFn :=
|
||||
recoverFn p fun _ =>
|
||||
ignoreFn <| takeUntilFn (fun c => c == ' ' || c == '\n')
|
||||
|
||||
private def recoverNonSpace (p : ParserFn) : ParserFn :=
|
||||
def recoverNonSpace (p : ParserFn) : ParserFn :=
|
||||
recoverFn p fun rctx =>
|
||||
ignoreFn (takeUntilFn (fun c => c != ' ')) >>
|
||||
show ParserFn from
|
||||
fun _ s => s.shrinkStack rctx.initialSize
|
||||
|
||||
private def recoverWsWith (stxs : Array Syntax) (p : ParserFn) : ParserFn :=
|
||||
def recoverWsWith (stxs : Array Syntax) (p : ParserFn) : ParserFn :=
|
||||
recoverFn p fun rctx =>
|
||||
ignoreFn <| takeUntilFn (fun c => c == ' ' || c == '\n') >>
|
||||
show ParserFn from
|
||||
fun _ s => stxs.foldl (init := s.shrinkStack rctx.initialSize) (·.pushSyntax ·)
|
||||
|
||||
private def recoverEol (p : ParserFn) : ParserFn :=
|
||||
def recoverEol (p : ParserFn) : ParserFn :=
|
||||
recoverFn p fun _ => ignoreFn <| skipToNewline
|
||||
|
||||
private def recoverEolWith (stxs : Array Syntax) (p : ParserFn) : ParserFn :=
|
||||
def recoverEolWith (stxs : Array Syntax) (p : ParserFn) : ParserFn :=
|
||||
recoverFn p fun rctx =>
|
||||
ignoreFn skipToNewline >>
|
||||
show ParserFn from
|
||||
@@ -494,7 +494,7 @@ private def recoverEolWith (stxs : Array Syntax) (p : ParserFn) : ParserFn :=
|
||||
|
||||
-- Like `recoverEol` but stores recovered errors at the original error position
|
||||
-- rather than the post-recovery position.
|
||||
private def recoverEolAtErrPos (p : ParserFn) : ParserFn := fun c s =>
|
||||
def recoverEolAtErrPos (p : ParserFn) : ParserFn := fun c s =>
|
||||
let s := p c s
|
||||
if let some msg := s.errorMsg then
|
||||
let errPos := s.pos
|
||||
@@ -509,7 +509,7 @@ private def recoverEolAtErrPos (p : ParserFn) : ParserFn := fun c s =>
|
||||
|
||||
-- Like `recoverEolWith` but stores recovered errors at the original error position
|
||||
-- rather than the post-recovery position.
|
||||
private def recoverEolWithAtErrPos (stxs : Array Syntax) (p : ParserFn) : ParserFn := fun c s =>
|
||||
def recoverEolWithAtErrPos (stxs : Array Syntax) (p : ParserFn) : ParserFn := fun c s =>
|
||||
let iniSz := s.stxStack.size
|
||||
let s := p c s
|
||||
if let some msg := s.errorMsg then
|
||||
@@ -521,10 +521,10 @@ private def recoverEolWithAtErrPos (stxs : Array Syntax) (p : ParserFn) : Parser
|
||||
{s' with recoveredErrors := s.recoveredErrors.push (errPos, s'.stxStack, msg)}
|
||||
else s
|
||||
|
||||
private def recoverSkip (p : ParserFn) : ParserFn :=
|
||||
def recoverSkip (p : ParserFn) : ParserFn :=
|
||||
recoverFn p fun _ => skipFn
|
||||
|
||||
private def recoverSkipWith (stxs : Array Syntax) (p : ParserFn) : ParserFn :=
|
||||
def recoverSkipWith (stxs : Array Syntax) (p : ParserFn) : ParserFn :=
|
||||
recoverFn p fun rctx =>
|
||||
show ParserFn from
|
||||
fun _ s => stxs.foldl (init := s.shrinkStack rctx.initialSize) (·.pushSyntax ·)
|
||||
@@ -535,7 +535,7 @@ def recoverHereWith (stxs : Array Syntax) (p : ParserFn) : ParserFn :=
|
||||
show ParserFn from
|
||||
fun _ s => stxs.foldl (init := s.restore rctx.initialSize rctx.initialPos) (·.pushSyntax ·)
|
||||
|
||||
private def recoverHereWithKeeping (stxs : Array Syntax) (keep : Nat) (p : ParserFn) : ParserFn :=
|
||||
def recoverHereWithKeeping (stxs : Array Syntax) (keep : Nat) (p : ParserFn) : ParserFn :=
|
||||
recoverFn p fun rctx =>
|
||||
show ParserFn from
|
||||
fun _ s => stxs.foldl (init := s.restore (rctx.initialSize + keep) rctx.initialPos) (·.pushSyntax ·)
|
||||
@@ -584,7 +584,7 @@ it's in a single-line context and whitespace may only be the space
|
||||
character. If it's `some N`, then newlines are allowed, but `N` is the
|
||||
minimum indentation column.
|
||||
-/
|
||||
private def nameArgWhitespace : (multiline : Option Nat) → ParserFn
|
||||
def nameArgWhitespace : (multiline : Option Nat) → ParserFn
|
||||
| none => eatSpaces
|
||||
| some n => takeWhileFn (fun c => c == ' ' || c == '\n') >> guardMinColumn n
|
||||
|
||||
@@ -598,7 +598,7 @@ each sub-parser of `delimitedInline` contributes a clear expected-token name, an
|
||||
unhelpful generic "unexpected" messages from inner parsers so that the more informative message
|
||||
from `inlineTextChar` survives error merging via `<|>`.
|
||||
-/
|
||||
private def expectedFn (msg : String) (p : ParserFn) : ParserFn := fun c s =>
|
||||
def expectedFn (msg : String) (p : ParserFn) : ParserFn := fun c s =>
|
||||
let iniPos := s.pos
|
||||
let s := p c s
|
||||
if s.hasError && s.pos == iniPos then
|
||||
@@ -649,18 +649,18 @@ def linebreak (ctxt : InlineCtxt) : ParserFn :=
|
||||
else
|
||||
errorFn "Newlines not allowed here"
|
||||
|
||||
private partial def notInLink (ctxt : InlineCtxt) : ParserFn := fun _ s =>
|
||||
partial def notInLink (ctxt : InlineCtxt) : ParserFn := fun _ s =>
|
||||
if ctxt.inLink then s.mkError "Already in a link" else s
|
||||
|
||||
-- Like `satisfyFn (· == '\n')` but with a better error message that mentions what was expected.
|
||||
private def newlineOrUnexpected (msg : String) : ParserFn := fun c s =>
|
||||
def newlineOrUnexpected (msg : String) : ParserFn := fun c s =>
|
||||
let i := s.pos
|
||||
if h : c.atEnd i then s.mkEOIError
|
||||
else if c.get' i h == '\n' then s.next' c i h
|
||||
else s.mkUnexpectedError s!"unexpected '{c.get' i h}'" [msg]
|
||||
|
||||
mutual
|
||||
private partial def emphLike
|
||||
partial def emphLike
|
||||
(name : SyntaxNodeKind) (char : Char) (what plural : String)
|
||||
(getter : InlineCtxt → Option Nat) (setter : InlineCtxt → Option Nat → InlineCtxt)
|
||||
(ctxt : InlineCtxt) : ParserFn :=
|
||||
@@ -799,7 +799,7 @@ mutual
|
||||
nodeFn `str (asStringFn (quoted := true) (many1Fn (satisfyEscFn (fun c => c != ']' && c != '\n') "other than ']' or newline"))) >>
|
||||
strFn "]")
|
||||
|
||||
private partial def linkTarget : ParserFn := fun c s =>
|
||||
partial def linkTarget : ParserFn := fun c s =>
|
||||
let s := (ref <|> url) c s
|
||||
if s.hasError then
|
||||
match s.errorMsg with
|
||||
@@ -922,7 +922,7 @@ deriving Inhabited, Repr
|
||||
Finds the minimum column of the first non-whitespace character on each non-empty content line
|
||||
between `startPos` and `endPos`, returning `init` if no such line exists.
|
||||
-/
|
||||
private def minContentIndent (text : FileMap) (startPos endPos : String.Pos.Raw)
|
||||
def minContentIndent (text : FileMap) (startPos endPos : String.Pos.Raw)
|
||||
(init : Nat) : Nat := Id.run do
|
||||
let mut result := init
|
||||
let mut thisLineCol := 0
|
||||
@@ -980,13 +980,13 @@ public def BlockCtxt.forDocString (text : FileMap)
|
||||
else text.source.rawEndPos
|
||||
{ docStartPosition := text.toPosition pos, baseColumn }
|
||||
|
||||
private def bol (ctxt : BlockCtxt) : ParserFn := fun c s =>
|
||||
def bol (ctxt : BlockCtxt) : ParserFn := fun c s =>
|
||||
let pos := c.fileMap.toPosition s.pos
|
||||
if pos.column ≤ ctxt.baseColumn then s
|
||||
else if pos.line == ctxt.docStartPosition.line && pos.column ≤ ctxt.docStartPosition.column then s
|
||||
else s.mkErrorAt s!"beginning of line at {pos}" s.pos
|
||||
|
||||
private def bolThen (ctxt : BlockCtxt) (p : ParserFn) (description : String) : ParserFn := fun c s =>
|
||||
def bolThen (ctxt : BlockCtxt) (p : ParserFn) (description : String) : ParserFn := fun c s =>
|
||||
let position := c.fileMap.toPosition s.pos
|
||||
let positionOk :=
|
||||
position.column ≤ ctxt.baseColumn ||
|
||||
@@ -1075,16 +1075,16 @@ public def lookaheadUnorderedListIndicator (ctxt : BlockCtxt) (p : UnorderedList
|
||||
if s.hasError then s.setPos iniPos
|
||||
else p type c (s.shrinkStack iniSz |>.setPos bulletPos)
|
||||
|
||||
private def skipUntilDedent (indent : Nat) : ParserFn :=
|
||||
def skipUntilDedent (indent : Nat) : ParserFn :=
|
||||
skipRestOfLine >>
|
||||
manyFn (chFn ' ' >> takeWhileFn (· == ' ') >> guardColumn (· ≥ indent) s!"indentation at {indent}" >> skipRestOfLine)
|
||||
|
||||
private def recoverUnindent (indent : Nat) (p : ParserFn) (finish : ParserFn := skipFn) :
|
||||
def recoverUnindent (indent : Nat) (p : ParserFn) (finish : ParserFn := skipFn) :
|
||||
ParserFn :=
|
||||
recoverFn p (fun _ => ignoreFn (skipUntilDedent indent) >> finish)
|
||||
|
||||
|
||||
private def blockSep := ignoreFn (manyFn blankLine >> optionalFn endLine)
|
||||
def blockSep := ignoreFn (manyFn blankLine >> optionalFn endLine)
|
||||
|
||||
mutual
|
||||
/-- Parses a list item according to the current nesting context. -/
|
||||
|
||||
@@ -13,6 +13,7 @@ public import Lean.IdentifierSuggestion
|
||||
import all Lean.Elab.ErrorUtils
|
||||
import Lean.Elab.DeprecatedArg
|
||||
import Init.Omega
|
||||
import Init.Data.List.MapIdx
|
||||
|
||||
public section
|
||||
|
||||
@@ -1299,13 +1300,13 @@ where
|
||||
inductive LValResolution where
|
||||
/-- When applied to `f`, effectively expands to `BaseStruct.fieldName (self := Struct.toBase f)`.
|
||||
This is a special named argument where it suppresses any explicit arguments depending on it so that type parameters don't need to be supplied. -/
|
||||
| projFn (baseStructName : Name) (structName : Name) (fieldName : Name)
|
||||
| projFn (baseStructName : Name) (structName : Name) (fieldName : Name) (levels : List Level)
|
||||
/-- Similar to `projFn`, but for extracting field indexed by `idx`. Works for one-constructor inductive types in general. -/
|
||||
| projIdx (structName : Name) (idx : Nat)
|
||||
/-- When applied to `f`, effectively expands to `constName ... (Struct.toBase f)`, with the argument placed in the correct
|
||||
positional argument if possible, or otherwise as a named argument. The `Struct.toBase` is not present if `baseStructName == structName`,
|
||||
in which case these do not need to be structures. Supports generalized field notation. -/
|
||||
| const (baseStructName : Name) (structName : Name) (constName : Name)
|
||||
| const (baseStructName : Name) (structName : Name) (constName : Name) (levels : List Level)
|
||||
/-- Like `const`, but with `fvar` instead of `constName`.
|
||||
The `baseName` is the base name of the type to search for in the parameter list. -/
|
||||
| localRec (baseName : Name) (fvar : Expr)
|
||||
@@ -1380,7 +1381,7 @@ private def reverseFieldLookup (env : Environment) (fieldName : String) :=
|
||||
|
||||
private def resolveLValAux (e : Expr) (eType : Expr) (lval : LVal) : TermElabM LValResolution := do
|
||||
match eType.getAppFn, lval with
|
||||
| .const structName _, LVal.fieldIdx ref idx =>
|
||||
| .const structName _, LVal.fieldIdx ref idx levels =>
|
||||
if idx == 0 then
|
||||
throwError "Invalid projection: Index must be greater than 0"
|
||||
let env ← getEnv
|
||||
@@ -1393,10 +1394,14 @@ private def resolveLValAux (e : Expr) (eType : Expr) (lval : LVal) : TermElabM L
|
||||
if idx - 1 < numFields then
|
||||
if isStructure env structName then
|
||||
let fieldNames := getStructureFields env structName
|
||||
return LValResolution.projFn structName structName fieldNames[idx - 1]!
|
||||
return LValResolution.projFn structName structName fieldNames[idx - 1]! levels
|
||||
else
|
||||
/- `structName` was declared using `inductive` command.
|
||||
So, we don't projection functions for it. Thus, we use `Expr.proj` -/
|
||||
unless levels.isEmpty do
|
||||
throwError "Invalid projection: Explicit universe levels are only supported for inductive types \
|
||||
defined using the `structure` command. \
|
||||
The expression{indentExpr e}\nhas type{inlineExpr eType}which is not a `structure`."
|
||||
return LValResolution.projIdx structName (idx - 1)
|
||||
else
|
||||
if numFields == 0 then
|
||||
@@ -1409,31 +1414,33 @@ private def resolveLValAux (e : Expr) (eType : Expr) (lval : LVal) : TermElabM L
|
||||
++ MessageData.note m!"The expression{indentExpr e}\nhas type{inlineExpr eType}which has only \
|
||||
{numFields} field{numFields.plural}"
|
||||
++ tupleHint
|
||||
| .const structName _, LVal.fieldName ref fieldName _ _ => withRef ref do
|
||||
| .const structName _, LVal.fieldName ref fieldName levels _ _ => withRef ref do
|
||||
let env ← getEnv
|
||||
if isStructure env structName then
|
||||
if let some baseStructName := findField? env structName (Name.mkSimple fieldName) then
|
||||
return LValResolution.projFn baseStructName structName (Name.mkSimple fieldName)
|
||||
return LValResolution.projFn baseStructName structName (Name.mkSimple fieldName) levels
|
||||
-- Search the local context first
|
||||
let fullName := Name.mkStr (privateToUserName structName) fieldName
|
||||
for localDecl in (← getLCtx) do
|
||||
if localDecl.isAuxDecl then
|
||||
if let some localDeclFullName := (← getLCtx).auxDeclToFullName.get? localDecl.fvarId then
|
||||
if fullName == privateToUserName localDeclFullName then
|
||||
unless levels.isEmpty do
|
||||
throwInvalidExplicitUniversesForLocal localDecl.toExpr
|
||||
/- LVal notation is being used to make a "local" recursive call. -/
|
||||
return LValResolution.localRec structName localDecl.toExpr
|
||||
-- Then search the environment
|
||||
if let some (baseStructName, fullName) ← findMethod? structName (.mkSimple fieldName) then
|
||||
return LValResolution.const baseStructName structName fullName
|
||||
return LValResolution.const baseStructName structName fullName levels
|
||||
throwInvalidFieldAt ref fieldName fullName
|
||||
-- Suggest a potential unreachable private name as hint. This does not cover structure
|
||||
-- inheritance, nor `import all`.
|
||||
(declHint := (mkPrivateName env structName).mkStr fieldName)
|
||||
|
||||
| .forallE .., LVal.fieldName ref fieldName suffix? fullRef =>
|
||||
| .forallE .., LVal.fieldName ref fieldName levels suffix? fullRef =>
|
||||
let fullName := Name.str `Function fieldName
|
||||
if (← getEnv).contains fullName then
|
||||
return LValResolution.const `Function `Function fullName
|
||||
return LValResolution.const `Function `Function fullName levels
|
||||
match e.getAppFn, suffix? with
|
||||
| Expr.const c _, some suffix =>
|
||||
throwUnknownNameWithSuggestions (idOrConst := "constant") (ref? := fullRef) (c ++ suffix)
|
||||
@@ -1443,7 +1450,7 @@ private def resolveLValAux (e : Expr) (eType : Expr) (lval : LVal) : TermElabM L
|
||||
throwError "Invalid projection: Projections cannot be used on functions, and{indentExpr e}\n\
|
||||
has function type{inlineExprTrailing eType}"
|
||||
|
||||
| .mvar .., .fieldName _ fieldName _ _ =>
|
||||
| .mvar .., .fieldName _ fieldName levels _ _ =>
|
||||
let hint := match reverseFieldLookup (← getEnv) fieldName with
|
||||
| #[] => MessageData.nil
|
||||
| #[opt] => .hint' m!"Consider replacing the field projection `.{fieldName}` with a call to the function `{.ofConstName opt}`."
|
||||
@@ -1451,13 +1458,13 @@ private def resolveLValAux (e : Expr) (eType : Expr) (lval : LVal) : TermElabM L
|
||||
{MessageData.joinSep (opts.toList.map (indentD m!"• `{.ofConstName ·}`")) .nil}"
|
||||
throwNamedError lean.invalidField (m!"Invalid field notation: Type of{indentExpr e}\nis not \
|
||||
known; cannot resolve field `{fieldName}`" ++ hint)
|
||||
| .mvar .., .fieldIdx _ i =>
|
||||
| .mvar .., .fieldIdx _ i _ =>
|
||||
throwError m!"Invalid projection: Type of{indentExpr e}\nis not known; cannot resolve \
|
||||
projection `{i}`"
|
||||
|
||||
| _, _ =>
|
||||
match e.getAppFn, lval with
|
||||
| Expr.const c _, .fieldName _ref _fieldName (some suffix) fullRef =>
|
||||
| Expr.const c _, .fieldName _ref _fieldName _levels (some suffix) fullRef =>
|
||||
throwUnknownNameWithSuggestions (idOrConst := "constant") (ref? := fullRef) (c ++ suffix)
|
||||
| _, .fieldName .. =>
|
||||
throwNamedError lean.invalidField m!"Invalid field notation: Field projection operates on \
|
||||
@@ -1706,12 +1713,12 @@ private def elabAppLValsAux (namedArgs : Array NamedArg) (args : Array Arg) (exp
|
||||
let f ← mkProjAndCheck structName idx f
|
||||
let f ← addTermInfo lval.getRef f
|
||||
loop f lvals
|
||||
| LValResolution.projFn baseStructName structName fieldName =>
|
||||
| LValResolution.projFn baseStructName structName fieldName levels =>
|
||||
let f ← mkBaseProjections baseStructName structName f
|
||||
let some info := getFieldInfo? (← getEnv) baseStructName fieldName | unreachable!
|
||||
if (← isInaccessiblePrivateName info.projFn) then
|
||||
throwError "Field `{fieldName}` from structure `{structName}` is private"
|
||||
let projFn ← withRef lval.getRef <| mkConst info.projFn
|
||||
let projFn ← withRef lval.getRef <| mkConst info.projFn levels
|
||||
let projFn ← addProjTermInfo lval.getRef projFn
|
||||
if lvals.isEmpty then
|
||||
let namedArgs ← addNamedArg namedArgs { name := `self, val := Arg.expr f, suppressDeps := true }
|
||||
@@ -1719,9 +1726,9 @@ private def elabAppLValsAux (namedArgs : Array NamedArg) (args : Array Arg) (exp
|
||||
else
|
||||
let f ← elabAppArgs projFn #[{ name := `self, val := Arg.expr f, suppressDeps := true }] #[] (expectedType? := none) (explicit := false) (ellipsis := false)
|
||||
loop f lvals
|
||||
| LValResolution.const baseStructName structName constName =>
|
||||
| LValResolution.const baseStructName structName constName levels =>
|
||||
let f ← if baseStructName != structName then mkBaseProjections baseStructName structName f else pure f
|
||||
let projFn ← withRef lval.getRef <| mkConst constName
|
||||
let projFn ← withRef lval.getRef <| mkConst constName levels
|
||||
let projFn ← addProjTermInfo lval.getRef projFn
|
||||
if lvals.isEmpty then
|
||||
let (args, namedArgs) ← addLValArg baseStructName f args namedArgs projFn explicit
|
||||
@@ -1772,15 +1779,19 @@ false, no elaboration function executed by `x` will reset it to
|
||||
/--
|
||||
Elaborates the resolutions of a function. The `fns` array is the output of `resolveName'`.
|
||||
-/
|
||||
private def elabAppFnResolutions (fRef : Syntax) (fns : List (Expr × Syntax × List Syntax)) (lvals : List LVal)
|
||||
private def elabAppFnResolutions (fRef : Syntax) (fns : List (Expr × Syntax × List Syntax × List Level)) (lvals : List LVal)
|
||||
(namedArgs : Array NamedArg) (args : Array Arg) (expectedType? : Option Expr) (explicit ellipsis overloaded : Bool)
|
||||
(acc : Array (TermElabResult Expr)) (forceTermInfo : Bool := false) :
|
||||
TermElabM (Array (TermElabResult Expr)) := do
|
||||
let overloaded := overloaded || fns.length > 1
|
||||
-- Set `errToSorry` to `false` if `fns` > 1. See comment above about the interaction between `errToSorry` and `observing`.
|
||||
withReader (fun ctx => { ctx with errToSorry := fns.length == 1 && ctx.errToSorry }) do
|
||||
fns.foldlM (init := acc) fun acc (f, fIdent, fields) => do
|
||||
let lvals' := toLVals fields (first := true)
|
||||
fns.foldlM (init := acc) fun acc (f, fIdent, fields, projLevels) => do
|
||||
let lastIdx := fields.length - 1
|
||||
let lvals' := fields.mapIdx fun idx field =>
|
||||
let suffix? := if idx == 0 then some <| toName fields else none
|
||||
let levels := if idx == lastIdx then projLevels else []
|
||||
LVal.fieldName field field.getId.getString! levels suffix? fRef
|
||||
let s ← observing do
|
||||
checkDeprecated fIdent f
|
||||
let f ← addTermInfo fIdent f expectedType? (force := forceTermInfo)
|
||||
@@ -1794,11 +1805,6 @@ where
|
||||
| field :: fields => .mkStr (go fields) field.getId.toString
|
||||
go fields.reverse
|
||||
|
||||
toLVals : List Syntax → (first : Bool) → List LVal
|
||||
| [], _ => []
|
||||
| field::fields, true => .fieldName field field.getId.getString! (toName (field::fields)) fRef :: toLVals fields false
|
||||
| field::fields, false => .fieldName field field.getId.getString! none fRef :: toLVals fields false
|
||||
|
||||
private def elabAppFnId (fIdent : Syntax) (fExplicitUnivs : List Level) (lvals : List LVal)
|
||||
(namedArgs : Array NamedArg) (args : Array Arg) (expectedType? : Option Expr) (explicit ellipsis overloaded : Bool)
|
||||
(acc : Array (TermElabResult Expr)) :
|
||||
@@ -1832,7 +1838,7 @@ To infer a namespace from the expected type, we do the following operations:
|
||||
- if the type is of the form `c x₁ ... xₙ` with `c` a constant, then try using `c` as the namespace,
|
||||
and if that doesn't work, try unfolding the expression and continuing.
|
||||
-/
|
||||
private partial def resolveDottedIdentFn (idRef : Syntax) (id : Name) (explicitUnivs : List Level) (expectedType? : Option Expr) : TermElabM (List (Expr × Syntax × List Syntax)) := do
|
||||
private partial def resolveDottedIdentFn (idRef : Syntax) (id : Name) (explicitUnivs : List Level) (expectedType? : Option Expr) : TermElabM (List (Expr × Syntax × List Syntax × List Level)) := do
|
||||
unless id.isAtomic do
|
||||
throwError "Invalid dotted identifier notation: The name `{id}` must be atomic"
|
||||
tryPostponeIfNoneOrMVar expectedType?
|
||||
@@ -1844,7 +1850,7 @@ private partial def resolveDottedIdentFn (idRef : Syntax) (id : Name) (explicitU
|
||||
withForallBody expectedType fun resultType => do
|
||||
go resultType expectedType #[]
|
||||
where
|
||||
throwNoExpectedType := do
|
||||
throwNoExpectedType {α} : TermElabM α := do
|
||||
let hint ← match reverseFieldLookup (← getEnv) (id.getString!) with
|
||||
| #[] => pure MessageData.nil
|
||||
| suggestions =>
|
||||
@@ -1863,7 +1869,7 @@ where
|
||||
withForallBody body k
|
||||
else
|
||||
k type
|
||||
go (resultType : Expr) (expectedType : Expr) (previousExceptions : Array Exception) : TermElabM (List (Expr × Syntax × List Syntax)) := do
|
||||
go (resultType : Expr) (expectedType : Expr) (previousExceptions : Array Exception) : TermElabM (List (Expr × Syntax × List Syntax × List Level)) := do
|
||||
let resultType ← instantiateMVars resultType
|
||||
let resultTypeFn := resultType.getAppFn
|
||||
try
|
||||
@@ -1880,11 +1886,11 @@ where
|
||||
|>.filter (fun (_, fieldList) => fieldList.isEmpty)
|
||||
|>.map Prod.fst
|
||||
if !candidates.isEmpty then
|
||||
candidates.mapM fun resolvedName => return (← mkConst resolvedName explicitUnivs, ← getRef, [])
|
||||
candidates.mapM fun resolvedName => return (← mkConst resolvedName explicitUnivs, ← getRef, [], [])
|
||||
else if let some (fvar, []) ← resolveLocalName fullName then
|
||||
unless explicitUnivs.isEmpty do
|
||||
throwInvalidExplicitUniversesForLocal fvar
|
||||
return [(fvar, ← getRef, [])]
|
||||
return [(fvar, ← getRef, [], [])]
|
||||
else
|
||||
throwUnknownIdentifierAt (← getRef) (declHint := fullName) <| m!"Unknown constant `{.ofConstName fullName}`"
|
||||
++ .note m!"Inferred this name from the expected resulting type of `.{id}`:{indentExpr expectedType}"
|
||||
@@ -1914,26 +1920,37 @@ private partial def elabAppFn (f : Syntax) (lvals : List LVal) (namedArgs : Arra
|
||||
withReader (fun ctx => { ctx with errToSorry := false }) do
|
||||
f.getArgs.foldlM (init := acc) fun acc f => elabAppFn f lvals namedArgs args expectedType? explicit ellipsis true acc
|
||||
else
|
||||
let elabFieldName (e field : Syntax) (explicit : Bool) := do
|
||||
let newLVals := field.identComponents.map fun comp =>
|
||||
-- We use `none` in `suffix?` since `field` can't be part of a composite name
|
||||
LVal.fieldName comp comp.getId.getString! none f
|
||||
let elabFieldName (e field : Syntax) (explicitUnivs : List Level) := do
|
||||
let comps := field.identComponents
|
||||
let lastIdx := comps.length - 1
|
||||
let newLVals := comps.mapIdx fun idx comp =>
|
||||
let levels := if idx = lastIdx then explicitUnivs else []
|
||||
let suffix? := none -- We use `none` since the field can't be part of a composite name
|
||||
LVal.fieldName comp comp.getId.getString! levels suffix? f
|
||||
elabAppFn e (newLVals ++ lvals) namedArgs args expectedType? explicit ellipsis overloaded acc
|
||||
let elabFieldIdx (e idxStx : Syntax) (explicit : Bool) := do
|
||||
let elabFieldIdx (e idxStx : Syntax) (explicitUnivs : List Level) := do
|
||||
let some idx := idxStx.isFieldIdx?
|
||||
| throwError "Internal error: Unexpected field index syntax `{idxStx}`"
|
||||
elabAppFn e (LVal.fieldIdx idxStx idx :: lvals) namedArgs args expectedType? explicit ellipsis overloaded acc
|
||||
let elabDottedIdent (id : Syntax) (explicitUnivs : List Level) (explicit : Bool) : TermElabM (Array (TermElabResult Expr)) := do
|
||||
elabAppFn e (LVal.fieldIdx idxStx idx explicitUnivs :: lvals) namedArgs args expectedType? explicit ellipsis overloaded acc
|
||||
let elabDottedIdent (id : Syntax) (explicitUnivs : List Level) : TermElabM (Array (TermElabResult Expr)) := do
|
||||
let res ← withRef f <| resolveDottedIdentFn id id.getId.eraseMacroScopes explicitUnivs expectedType?
|
||||
-- Use (forceTermInfo := true) because we want to record the result of .ident resolution even in patterns
|
||||
elabAppFnResolutions f res lvals namedArgs args expectedType? explicit ellipsis overloaded acc (forceTermInfo := true)
|
||||
match f with
|
||||
| `($(e).$idx:fieldIdx) => elabFieldIdx e idx explicit
|
||||
| `($e |>.$idx:fieldIdx) => elabFieldIdx e idx explicit
|
||||
| `($(e).$field:ident) => elabFieldName e field explicit
|
||||
| `($e |>.$field:ident) => elabFieldName e field explicit
|
||||
| `(@$(e).$idx:fieldIdx) => elabFieldIdx e idx (explicit := true)
|
||||
| `(@$(e).$field:ident) => elabFieldName e field (explicit := true)
|
||||
| `($(e).$idx:fieldIdx)
|
||||
| `($e |>.$idx:fieldIdx) =>
|
||||
elabFieldIdx e idx []
|
||||
| `($(e).$idx:fieldIdx.{$us,*})
|
||||
| `($e |>.$idx:fieldIdx.{$us,*}) =>
|
||||
let us ← elabExplicitUnivs us
|
||||
elabFieldIdx e idx us
|
||||
| `($(e).$field:ident)
|
||||
| `($e |>.$field:ident) =>
|
||||
elabFieldName e field []
|
||||
| `($(e).$field:ident.{$us,*})
|
||||
| `($e |>.$field:ident.{$us,*}) =>
|
||||
let us ← elabExplicitUnivs us
|
||||
elabFieldName e field us
|
||||
| `($_:ident@$_:term) =>
|
||||
throwError m!"Expected a function, but found the named pattern{indentD f}"
|
||||
++ .note m!"Named patterns `<identifier>@<term>` can only be used when pattern-matching"
|
||||
@@ -1942,12 +1959,15 @@ private partial def elabAppFn (f : Syntax) (lvals : List LVal) (namedArgs : Arra
|
||||
| `($id:ident.{$us,*}) => do
|
||||
let us ← elabExplicitUnivs us
|
||||
elabAppFnId id us lvals namedArgs args expectedType? explicit ellipsis overloaded acc
|
||||
| `(.$id:ident) => elabDottedIdent id [] explicit
|
||||
| `(.$id:ident) => elabDottedIdent id []
|
||||
| `(.$id:ident.{$us,*}) =>
|
||||
let us ← elabExplicitUnivs us
|
||||
elabDottedIdent id us explicit
|
||||
elabDottedIdent id us
|
||||
| `(@$_:ident)
|
||||
| `(@$_:ident.{$_us,*})
|
||||
| `(@$(_).$_:fieldIdx)
|
||||
| `(@$(_).$_:ident)
|
||||
| `(@$(_).$_:ident.{$_us,*})
|
||||
| `(@.$_:ident)
|
||||
| `(@.$_:ident.{$_us,*}) =>
|
||||
elabAppFn (f.getArg 1) lvals namedArgs args expectedType? (explicit := true) ellipsis overloaded acc
|
||||
@@ -2084,10 +2104,10 @@ private def elabAtom : TermElab := fun stx expectedType? => do
|
||||
@[builtin_term_elab dotIdent] def elabDotIdent : TermElab := elabAtom
|
||||
@[builtin_term_elab explicitUniv] def elabExplicitUniv : TermElab := elabAtom
|
||||
@[builtin_term_elab pipeProj] def elabPipeProj : TermElab
|
||||
| `($e |>.%$tk$f $args*), expectedType? =>
|
||||
| `($e |>.%$tk$f$[.{$us?,*}]? $args*), expectedType? =>
|
||||
universeConstraintsCheckpoint do
|
||||
let (namedArgs, args, ellipsis) ← expandArgs args
|
||||
let mut stx ← `($e |>.%$tk$f)
|
||||
let mut stx ← `($e |>.%$tk$f$[.{$us?,*}]?)
|
||||
if let (some startPos, some stopPos) := (e.raw.getPos?, f.raw.getTailPos?) then
|
||||
stx := ⟨stx.raw.setInfo <| .synthetic (canonical := true) startPos stopPos⟩
|
||||
elabAppAux stx namedArgs args (ellipsis := ellipsis) expectedType?
|
||||
@@ -2095,15 +2115,16 @@ private def elabAtom : TermElab := fun stx expectedType? => do
|
||||
|
||||
@[builtin_term_elab explicit] def elabExplicit : TermElab := fun stx expectedType? =>
|
||||
match stx with
|
||||
| `(@$_:ident) => elabAtom stx expectedType? -- Recall that `elabApp` also has support for `@`
|
||||
| `(@$_:ident.{$_us,*}) => elabAtom stx expectedType?
|
||||
| `(@$(_).$_:fieldIdx) => elabAtom stx expectedType?
|
||||
| `(@$(_).$_:ident) => elabAtom stx expectedType?
|
||||
| `(@.$_:ident) => elabAtom stx expectedType?
|
||||
| `(@.$_:ident.{$_us,*}) => elabAtom stx expectedType?
|
||||
| `(@($t)) => elabTerm t expectedType? (implicitLambda := false) -- `@` is being used just to disable implicit lambdas
|
||||
| `(@$t) => elabTerm t expectedType? (implicitLambda := false) -- `@` is being used just to disable implicit lambdas
|
||||
| _ => throwUnsupportedSyntax
|
||||
| `(@$_:ident) => elabAtom stx expectedType? -- Recall that `elabApp` also has support for `@`
|
||||
| `(@$_:ident.{$_us,*}) => elabAtom stx expectedType?
|
||||
| `(@$(_).$_:fieldIdx) => elabAtom stx expectedType?
|
||||
| `(@$(_).$_:ident) => elabAtom stx expectedType?
|
||||
| `(@$(_).$_:ident.{$_us,*}) => elabAtom stx expectedType?
|
||||
| `(@.$_:ident) => elabAtom stx expectedType?
|
||||
| `(@.$_:ident.{$_us,*}) => elabAtom stx expectedType?
|
||||
| `(@($t)) => elabTerm t expectedType? (implicitLambda := false) -- `@` is being used just to disable implicit lambdas
|
||||
| `(@$t) => elabTerm t expectedType? (implicitLambda := false) -- `@` is being used just to disable implicit lambdas
|
||||
| _ => throwUnsupportedSyntax
|
||||
|
||||
@[builtin_term_elab choice] def elabChoice : TermElab := elabAtom
|
||||
@[builtin_term_elab proj] def elabProj : TermElab := elabAtom
|
||||
|
||||
@@ -74,7 +74,7 @@ def isValidAutoBoundLevelName (n : Name) (relaxed : Bool) : Bool :=
|
||||
/--
|
||||
Tracks extra context needed within the scope of `Lean.Elab.Term.withAutoBoundImplicit`
|
||||
-/
|
||||
public structure AutoBoundImplicitContext where
|
||||
structure AutoBoundImplicitContext where
|
||||
/--
|
||||
This always matches the `autoImplicit` option; it is duplicated here in
|
||||
order to support the behavior of the deprecated `Lean.Elab.Term.Context.autoImplicit`
|
||||
@@ -95,7 +95,7 @@ instance : EmptyCollection AutoBoundImplicitContext where
|
||||
Pushes a new variable onto the autoImplicit context, indicating that it needs
|
||||
to be bound as an implicit parameter.
|
||||
-/
|
||||
public def AutoBoundImplicitContext.push (ctx : AutoBoundImplicitContext) (x : Expr) :=
|
||||
def AutoBoundImplicitContext.push (ctx : AutoBoundImplicitContext) (x : Expr) :=
|
||||
{ ctx with boundVariables := ctx.boundVariables.push x }
|
||||
|
||||
end Lean.Elab
|
||||
|
||||
@@ -116,8 +116,9 @@ private def checkEndHeader : Name → List Scope → Option Name
|
||||
addScope (isNewNamespace := false) (isNoncomputable := ncTk.isSome) (isPublic := publicTk.isSome) (isMeta := metaTk.isSome) (attrs := attrs) "" (← getCurrNamespace)
|
||||
| _ => throwUnsupportedSyntax
|
||||
|
||||
@[builtin_command_elab InternalSyntax.end_local_scope] def elabEndLocalScope : CommandElab := fun _ => do
|
||||
setDelimitsLocal
|
||||
@[builtin_command_elab InternalSyntax.end_local_scope] def elabEndLocalScope : CommandElab := fun stx => do
|
||||
let depth := stx[1].toNat
|
||||
setDelimitsLocal depth
|
||||
|
||||
/--
|
||||
Produces a `Name` composed of the names of at most the innermost `n` scopes in `ss`, truncating if an
|
||||
@@ -528,7 +529,7 @@ open Lean.Parser.Command.InternalSyntax in
|
||||
@[builtin_macro Lean.Parser.Command.«in»] def expandInCmd : Macro
|
||||
| `($cmd₁ in%$tk $cmd₂) =>
|
||||
-- Limit ref variability for incrementality; see Note [Incremental Macros]
|
||||
withRef tk `(section $cmd₁:command $endLocalScopeSyntax:command $cmd₂ end)
|
||||
withRef tk `(section $cmd₁:command $(endLocalScopeSyntax 1):command $cmd₂ end)
|
||||
| _ => Macro.throwUnsupported
|
||||
|
||||
@[builtin_command_elab Parser.Command.addDocString] def elabAddDeclDoc : CommandElab := fun stx => do
|
||||
|
||||
@@ -111,8 +111,14 @@ open Lean.Meta
|
||||
for x in loopMutVars do
|
||||
let defn ← getLocalDeclFromUserName x.getId
|
||||
Term.addTermInfo' x defn.toExpr
|
||||
-- ForIn forces all mut vars into the same universe: that of the do block result type.
|
||||
discard <| Term.ensureHasType (mkSort (mi.u.succ)) defn.type
|
||||
-- ForIn forces the mut tuple into the universe mi.u: that of the do block result type.
|
||||
-- If we don't do this, then we are stuck on solving constraints such as
|
||||
-- `max ?u.46 ?u.47 =?= max (max ?u.22 ?u.46) ?u.47`
|
||||
-- It's important we do this as a separate isLevelDefEq check on the decremented level because
|
||||
-- otherwise (`ensureHasType (mkSort mi.u.succ)`) we are stuck on constraints like
|
||||
-- `max (?u+1) (?v+1) =?= ?u+1`
|
||||
let u ← getDecLevel defn.type
|
||||
discard <| isLevelDefEq u mi.u
|
||||
defs := defs.push defn.toExpr
|
||||
if info.returnsEarly && loopMutVars.isEmpty then
|
||||
defs := defs.push (mkConst ``Unit.unit)
|
||||
|
||||
@@ -314,6 +314,23 @@ private def mkSilentAnnotationIfHole (e : Expr) : TermElabM Expr := do
|
||||
return val
|
||||
| _ => panic! "resolveId? returned an unexpected expression"
|
||||
|
||||
/--
|
||||
Rebuild a type application with fresh synthetic metavariables for instance-implicit arguments.
|
||||
Non-instance-implicit arguments are assigned from the original application's arguments.
|
||||
If the function is over-applied, extra arguments are preserved.
|
||||
-/
|
||||
private def resynthInstImplicitArgs (type : Expr) : TermElabM Expr := do
|
||||
let fn := type.getAppFn
|
||||
let args := type.getAppArgs
|
||||
let (mvars, bis, _) ← forallMetaTelescope (← inferType fn)
|
||||
for i in [:mvars.size] do
|
||||
if bis[i]!.isInstImplicit then
|
||||
mvars[i]!.mvarId!.assign (← mkInstMVar (← inferType mvars[i]!))
|
||||
else
|
||||
mvars[i]!.mvarId!.assign args[i]!
|
||||
let args := mvars ++ args.drop mvars.size
|
||||
instantiateMVars (mkAppN fn args)
|
||||
|
||||
@[builtin_term_elab Lean.Parser.Term.inferInstanceAs] def elabInferInstanceAs : TermElab := fun stx expectedType? => do
|
||||
-- The type argument is the last child (works for both `inferInstanceAs T` and `inferInstanceAs <| T`)
|
||||
let typeStx := stx[stx.getNumArgs - 1]!
|
||||
@@ -325,19 +342,21 @@ private def mkSilentAnnotationIfHole (e : Expr) : TermElabM Expr := do
|
||||
.note "`inferInstanceAs` requires full knowledge of the expected (\"target\") type to do its \
|
||||
instance translation. If you do not intend to transport instances between two types, \
|
||||
consider using `inferInstance` or `(inferInstance : expectedType)` instead.")
|
||||
let type ← withSynthesize (postpone := .yes) <| elabType typeStx
|
||||
-- Unify with expected type to resolve metavariables (e.g., `_` placeholders)
|
||||
discard <| isDefEq type expectedType
|
||||
let type ← withSynthesize do
|
||||
let type ← elabType typeStx
|
||||
-- Unify with expected type to resolve metavariables (e.g., `_` placeholders)
|
||||
discard <| isDefEq type expectedType
|
||||
return type
|
||||
-- Re-infer instance-implicit args, so that synthesis is not influenced by the expected type's
|
||||
-- instance choices.
|
||||
let type ← withSynthesize <| resynthInstImplicitArgs type
|
||||
let type ← instantiateMVars type
|
||||
-- Rebuild type with fresh synthetic mvars for instance-implicit args, so that
|
||||
-- synthesis is not influenced by the expected type's instance choices.
|
||||
let type ← abstractInstImplicitArgs type
|
||||
let inst ← synthInstance type
|
||||
let inst ← if backward.inferInstanceAs.wrap.get (← getOptions) then
|
||||
-- Wrap instance so its type matches the expected type exactly.
|
||||
let logCompileErrors := !(← read).isNoncomputableSection && !(← read).declName?.any (Lean.isNoncomputable (← getEnv))
|
||||
let isMeta := (← read).declName?.any (isMarkedMeta (← getEnv))
|
||||
withNewMCtxDepth <| wrapInstance inst expectedType (logCompileErrors := logCompileErrors) (isMeta := isMeta)
|
||||
wrapInstance inst expectedType (logCompileErrors := logCompileErrors) (isMeta := isMeta)
|
||||
else
|
||||
pure inst
|
||||
ensureHasType expectedType? inst
|
||||
|
||||
@@ -7,11 +7,19 @@ module
|
||||
|
||||
prelude
|
||||
public import Lean.DocString.Add
|
||||
public import Lean.Linter.Basic
|
||||
meta import Lean.Parser.Command
|
||||
|
||||
public section
|
||||
|
||||
namespace Lean.Elab
|
||||
namespace Lean
|
||||
|
||||
register_builtin_option linter.redundantVisibility : Bool := {
|
||||
defValue := false
|
||||
descr := "warn on redundant `private`/`public` visibility modifiers"
|
||||
}
|
||||
|
||||
namespace Elab
|
||||
|
||||
/--
|
||||
Ensure the environment does not contain a declaration with name `declName`.
|
||||
@@ -65,9 +73,44 @@ def Visibility.isPublic : Visibility → Bool
|
||||
| .public => true
|
||||
| _ => false
|
||||
|
||||
/--
|
||||
Returns whether the given visibility modifier should be interpreted as `public` in the current
|
||||
environment.
|
||||
|
||||
NOTE: `Environment.isExporting` defaults to `false` when command elaborators are invoked for
|
||||
backward compatibility. It needs to be initialized apropriately first before calling this function
|
||||
as e.g. done in `elabDeclaration`.
|
||||
-/
|
||||
def Visibility.isInferredPublic (env : Environment) (v : Visibility) : Bool :=
|
||||
if env.isExporting || !env.header.isModule then !v.isPrivate else v.isPublic
|
||||
|
||||
/-- Converts optional visibility syntax to a `Visibility` value. -/
|
||||
def elabVisibility [Monad m] [MonadError m] [MonadEnv m] [MonadOptions m] [MonadLog m]
|
||||
[AddMessageContext m]
|
||||
(vis? : Option (TSyntax ``Parser.Command.visibility)) :
|
||||
m Visibility := do
|
||||
let env ← getEnv
|
||||
match vis? with
|
||||
| none => pure .regular
|
||||
| some v =>
|
||||
match v with
|
||||
| `(Parser.Command.visibility| private) =>
|
||||
if v.raw.getHeadInfo matches .original .. then -- skip macro output
|
||||
if env.header.isModule && !env.isExporting then
|
||||
Linter.logLintIf linter.redundantVisibility v
|
||||
m!"`private` has no effect in a `module` file outside `public section`; \
|
||||
declarations are already `private` by default"
|
||||
pure .private
|
||||
| `(Parser.Command.visibility| public) =>
|
||||
if v.raw.getHeadInfo matches .original .. then -- skip macro output
|
||||
if env.isExporting || !env.header.isModule then
|
||||
Linter.logLintIf linter.redundantVisibility v
|
||||
m!"`public` is the default visibility{
|
||||
if env.header.isModule then " inside a `public section`" else ""
|
||||
}; the modifier has no effect"
|
||||
pure .public
|
||||
| _ => throwErrorAt v "unexpected visibility modifier"
|
||||
|
||||
/-- Whether a declaration is default, partial or nonrec. -/
|
||||
inductive RecKind where
|
||||
| «partial» | «nonrec» | default
|
||||
@@ -183,13 +226,7 @@ def elabModifiers (stx : TSyntax ``Parser.Command.declModifiers) : m Modifiers :
|
||||
else
|
||||
RecKind.nonrec
|
||||
let docString? := docCommentStx.getOptional?.map (TSyntax.mk ·, doc.verso.get (← getOptions))
|
||||
let visibility ← match visibilityStx.getOptional? with
|
||||
| none => pure .regular
|
||||
| some v =>
|
||||
match v with
|
||||
| `(Parser.Command.visibility| private) => pure .private
|
||||
| `(Parser.Command.visibility| public) => pure .public
|
||||
| _ => throwErrorAt v "unexpected visibility modifier"
|
||||
let visibility ← elabVisibility (visibilityStx.getOptional?.map (⟨·⟩))
|
||||
let isProtected := !protectedStx.isNone
|
||||
let attrs ← match attrsStx.getOptional? with
|
||||
| none => pure #[]
|
||||
|
||||
@@ -152,8 +152,9 @@ def expandNamespacedDeclaration : Macro := fun stx => do
|
||||
| some (ns, newStx) => do
|
||||
-- Limit ref variability for incrementality; see Note [Incremental Macros]
|
||||
let declTk := stx[1][0]
|
||||
let depth := ns.getNumParts
|
||||
let ns := mkIdentFrom declTk ns
|
||||
withRef declTk `(namespace $ns $endLocalScopeSyntax:command $(⟨newStx⟩) end $ns)
|
||||
withRef declTk `(namespace $ns $(endLocalScopeSyntax depth):command $(⟨newStx⟩) end $ns)
|
||||
| none => Macro.throwUnsupported
|
||||
|
||||
@[builtin_command_elab declaration, builtin_incremental]
|
||||
@@ -340,31 +341,29 @@ def elabMutual : CommandElab := fun stx => do
|
||||
|
||||
@[builtin_command_elab Lean.Parser.Command.«initialize»] def elabInitialize : CommandElab
|
||||
| stx@`($declModifiers:declModifiers $kw:initializeKeyword $[$id? : $type? ←]? $doSeq) => do
|
||||
withExporting (isExporting := (← getScope).isPublic) do
|
||||
let attrId := mkIdentFrom stx <| if kw.raw[0].isToken "initialize" then `init else `builtin_init
|
||||
if let (some id, some type) := (id?, type?) then
|
||||
let `(Parser.Command.declModifiersT| $[$doc?:docComment]? $[@[$attrs?,*]]? $(vis?)? $[meta%$meta?]? $[unsafe%$unsafe?]?) := stx[0]
|
||||
| throwErrorAt declModifiers "invalid initialization command, unexpected modifiers"
|
||||
let defStx ← `($[$doc?:docComment]? @[$attrId:ident initFn, $(attrs?.getD ∅),*] $(vis?)? $[meta%$meta?]? opaque $id : $type)
|
||||
let mut fullId := (← getCurrNamespace) ++ id.getId
|
||||
if vis?.any (·.raw.isOfKind ``Parser.Command.private) then
|
||||
let visibility ← elabVisibility vis?
|
||||
if !visibility.isInferredPublic (← getEnv) then
|
||||
fullId := mkPrivateName (← getEnv) fullId
|
||||
-- We need to add `id`'s ranges *before* elaborating `initFn` (and then `id` itself) as
|
||||
-- otherwise the info context created by `with_decl_name` will be incomplete and break the
|
||||
-- call hierarchy
|
||||
addDeclarationRangesForBuiltin fullId ⟨defStx.raw[0]⟩ defStx.raw[1]
|
||||
let vis := Parser.Command.visibility.ofBool (!isPrivateName fullId)
|
||||
elabCommand (← `(
|
||||
$vis:visibility $[meta%$meta?]? $[unsafe%$unsafe?]? def initFn : IO $type := with_decl_name% $(mkIdent fullId) do $doSeq
|
||||
@[no_expose] private $[meta%$meta?]? $[unsafe%$unsafe?]? def initFn : IO $type := with_decl_name% $(mkIdent fullId) do $doSeq
|
||||
$defStx:command))
|
||||
else
|
||||
let `(Parser.Command.declModifiersT| $[$doc?:docComment]? $[@[$attrs?,*]]? $(_)? $[meta%$meta?]? $[unsafe%$unsafe?]?) := declModifiers
|
||||
| throwErrorAt declModifiers "invalid initialization command, unexpected modifiers"
|
||||
let attrs := (attrs?.map (·.getElems)).getD #[]
|
||||
let attrs := attrs.push (← `(Lean.Parser.Term.attrInstance| $attrId:ident))
|
||||
-- `[builtin_init]` can be private as it is used for local codegen only but `[init]` must be
|
||||
-- available for the interpreter.
|
||||
let vis := Parser.Command.visibility.ofBool (attrId.getId == `init)
|
||||
elabCommand (← `($[$doc?:docComment]? @[$[$attrs],*] $vis:visibility $[meta%$meta?]? $[unsafe%$unsafe?]? def initFn : IO Unit := do $doSeq))
|
||||
elabCommand (← `($[$doc?:docComment]? @[no_expose, $[$attrs],*] private $[meta%$meta?]? $[unsafe%$unsafe?]? def initFn : IO Unit := do $doSeq))
|
||||
| _ => throwUnsupportedSyntax
|
||||
|
||||
builtin_initialize
|
||||
|
||||
@@ -172,7 +172,7 @@ def mkMatchNew (header : Header) (indVal : InductiveVal) (auxFunName : Name) : T
|
||||
if indVal.numCtors == 1 then
|
||||
`( $(mkCIdent casesOnSameCtorName) $x1:term $x2:term rfl $alts:term* )
|
||||
else
|
||||
`( match decEq ($(mkCIdent ctorIdxName) $x1:ident) ($(mkCIdent ctorIdxName) $x2:ident) with
|
||||
`( match Nat.decEq ($(mkCIdent ctorIdxName) $x1:ident) ($(mkCIdent ctorIdxName) $x2:ident) with
|
||||
| .isTrue h => $(mkCIdent casesOnSameCtorName) $x1:term $x2:term h $alts:term*
|
||||
| .isFalse _ => false)
|
||||
|
||||
|
||||
@@ -25,25 +25,23 @@ private def mkInhabitedInstanceUsing (inductiveTypeName : Name) (ctorName : Name
|
||||
| none =>
|
||||
return false
|
||||
where
|
||||
addLocalInstancesForParamsAux {α} (k : LocalInst2Index → TermElabM α) : List Expr → Nat → LocalInst2Index → TermElabM α
|
||||
| [], _, map => k map
|
||||
| x::xs, i, map =>
|
||||
addLocalInstancesForParamsAux {α} (k : Array Expr → LocalInst2Index → TermElabM α) : List Expr → Nat → Array Expr → LocalInst2Index → TermElabM α
|
||||
| [], _, insts, map => k insts map
|
||||
| x::xs, i, insts, map =>
|
||||
try
|
||||
let instType ← mkAppM `Inhabited #[x]
|
||||
if (← isTypeCorrect instType) then
|
||||
withLocalDeclD (← mkFreshUserName `inst) instType fun inst => do
|
||||
trace[Elab.Deriving.inhabited] "adding local instance {instType}"
|
||||
addLocalInstancesForParamsAux k xs (i+1) (map.insert inst.fvarId! i)
|
||||
else
|
||||
addLocalInstancesForParamsAux k xs (i+1) map
|
||||
check instType
|
||||
withLocalDecl (← mkFreshUserName `inst) .instImplicit instType fun inst => do
|
||||
trace[Elab.Deriving.inhabited] "adding local instance {instType}"
|
||||
addLocalInstancesForParamsAux k xs (i+1) (insts.push inst) (map.insert inst.fvarId! i)
|
||||
catch _ =>
|
||||
addLocalInstancesForParamsAux k xs (i+1) map
|
||||
addLocalInstancesForParamsAux k xs (i+1) insts map
|
||||
|
||||
addLocalInstancesForParams {α} (xs : Array Expr) (k : LocalInst2Index → TermElabM α) : TermElabM α := do
|
||||
addLocalInstancesForParams {α} (xs : Array Expr) (k : Array Expr → LocalInst2Index → TermElabM α) : TermElabM α := do
|
||||
if addHypotheses then
|
||||
addLocalInstancesForParamsAux k xs.toList 0 {}
|
||||
addLocalInstancesForParamsAux k xs.toList 0 #[] {}
|
||||
else
|
||||
k {}
|
||||
k #[] {}
|
||||
|
||||
collectUsedLocalsInsts (usedInstIdxs : IndexSet) (localInst2Index : LocalInst2Index) (e : Expr) : IndexSet :=
|
||||
if localInst2Index.isEmpty then
|
||||
@@ -58,58 +56,88 @@ where
|
||||
runST (fun _ => visit |>.run usedInstIdxs) |>.2
|
||||
|
||||
/-- Create an `instance` command using the constructor `ctorName` with a hypothesis `Inhabited α` when `α` is one of the inductive type parameters
|
||||
at position `i` and `i ∈ assumingParamIdxs`. -/
|
||||
mkInstanceCmdWith (assumingParamIdxs : IndexSet) : TermElabM Syntax := do
|
||||
let ctx ← Deriving.mkContext ``Inhabited "inhabited" inductiveTypeName
|
||||
at position `i` and `i ∈ usedInstIdxs`. -/
|
||||
mkInstanceCmdWith (instId : Ident) (usedInstIdxs : IndexSet) (auxFunId : Ident) : TermElabM Syntax := do
|
||||
let indVal ← getConstInfoInduct inductiveTypeName
|
||||
let ctorVal ← getConstInfoCtor ctorName
|
||||
let mut indArgs := #[]
|
||||
let mut binders := #[]
|
||||
for i in *...indVal.numParams + indVal.numIndices do
|
||||
let arg := mkIdent (← mkFreshUserName `a)
|
||||
indArgs := indArgs.push arg
|
||||
let binder ← `(bracketedBinderF| { $arg:ident })
|
||||
binders := binders.push binder
|
||||
if assumingParamIdxs.contains i then
|
||||
let binder ← `(bracketedBinderF| [Inhabited $arg:ident ])
|
||||
binders := binders.push binder
|
||||
binders := binders.push <| ← `(bracketedBinderF| { $arg:ident })
|
||||
if usedInstIdxs.contains i then
|
||||
binders := binders.push <| ← `(bracketedBinderF| [Inhabited $arg:ident ])
|
||||
let type ← `(@$(mkCIdent inductiveTypeName):ident $indArgs:ident*)
|
||||
let mut ctorArgs := #[]
|
||||
for _ in *...ctorVal.numParams do
|
||||
ctorArgs := ctorArgs.push (← `(_))
|
||||
for _ in *...ctorVal.numFields do
|
||||
ctorArgs := ctorArgs.push (← ``(Inhabited.default))
|
||||
let val ← `(@$(mkIdent ctorName):ident $ctorArgs*)
|
||||
let ctx ← mkContext ``Inhabited "default" inductiveTypeName
|
||||
let auxFunName := ctx.auxFunNames[0]!
|
||||
`(def $(mkIdent auxFunName):ident $binders:bracketedBinder* : $type := $val
|
||||
instance $(mkIdent ctx.instName):ident $binders:bracketedBinder* : Inhabited $type := ⟨$(mkIdent auxFunName)⟩)
|
||||
`(instance $instId:ident $binders:bracketedBinder* : Inhabited $type := ⟨$auxFunId⟩)
|
||||
|
||||
solveMVarsWithDefault (e : Expr) : TermElabM Unit := do
|
||||
let mvarIds ← getMVarsNoDelayed e
|
||||
mvarIds.forM fun mvarId => mvarId.withContext do
|
||||
unless ← mvarId.isAssigned do
|
||||
let type ← mvarId.getType
|
||||
withTraceNode `Elab.Deriving.inhabited (fun _ => return m!"synthesizing Inhabited instance for{inlineExprTrailing type}") do
|
||||
let val ← mkDefault type
|
||||
mvarId.assign val
|
||||
trace[Elab.Deriving.inhabited] "value:{inlineExprTrailing val}"
|
||||
|
||||
mkInstanceCmd? : TermElabM (Option Syntax) := do
|
||||
let ctorVal ← getConstInfoCtor ctorName
|
||||
forallTelescopeReducing ctorVal.type fun xs _ =>
|
||||
addLocalInstancesForParams xs[*...ctorVal.numParams] fun localInst2Index => do
|
||||
let mut usedInstIdxs := {}
|
||||
let mut ok := true
|
||||
for h : i in ctorVal.numParams...xs.size do
|
||||
let x := xs[i]
|
||||
let instType ← mkAppM `Inhabited #[(← inferType x)]
|
||||
trace[Elab.Deriving.inhabited] "checking {instType} for `{ctorName}`"
|
||||
match (← trySynthInstance instType) with
|
||||
| LOption.some e =>
|
||||
usedInstIdxs := collectUsedLocalsInsts usedInstIdxs localInst2Index e
|
||||
| _ =>
|
||||
trace[Elab.Deriving.inhabited] "failed to generate instance using `{ctorName}` {if addHypotheses then "(assuming parameters are inhabited)" else ""} because of field with type{indentExpr (← inferType x)}"
|
||||
ok := false
|
||||
break
|
||||
if !ok then
|
||||
return none
|
||||
mkDefaultValue (indVal : InductiveVal) : TermElabM (Expr × Expr × IndexSet) := do
|
||||
let us := indVal.levelParams.map Level.param
|
||||
forallTelescopeReducing indVal.type fun xs _ =>
|
||||
withImplicitBinderInfos xs do
|
||||
addLocalInstancesForParams xs[0...indVal.numParams] fun insts localInst2Index => do
|
||||
let type := mkAppN (.const inductiveTypeName us) xs
|
||||
let val ←
|
||||
if isStructure (← getEnv) inductiveTypeName then
|
||||
withTraceNode `Elab.Deriving.inhabited (fun _ => return m!"using structure instance elaborator") do
|
||||
let stx ← `(structInst| {..})
|
||||
withoutErrToSorry <| elabTermAndSynthesize stx type
|
||||
else
|
||||
trace[Elab.Deriving.inhabited] "inhabited instance using `{ctorName}` {if addHypotheses then "(assuming parameters are inhabited)" else ""} {usedInstIdxs.toList}"
|
||||
let cmd ← mkInstanceCmdWith usedInstIdxs
|
||||
trace[Elab.Deriving.inhabited] "\n{cmd}"
|
||||
return some cmd
|
||||
withTraceNode `Elab.Deriving.inhabited (fun _ => return m!"using constructor `{.ofConstName ctorName}`") do
|
||||
let val := mkAppN (.const ctorName us) xs[0...indVal.numParams]
|
||||
let (mvars, _, type') ← forallMetaTelescopeReducing (← inferType val)
|
||||
unless ← isDefEq type type' do
|
||||
throwError "cannot unify{indentExpr type}\nand type of constructor{indentExpr type'}"
|
||||
pure <| mkAppN val mvars
|
||||
solveMVarsWithDefault val
|
||||
let val ← instantiateMVars val
|
||||
if val.hasMVar then
|
||||
throwError "default value contains metavariables{inlineExprTrailing val}"
|
||||
let fvars := Lean.collectFVars {} val
|
||||
let insts' := insts.filter fvars.visitedExpr.contains
|
||||
let usedInstIdxs := collectUsedLocalsInsts {} localInst2Index val
|
||||
assert! insts'.size == usedInstIdxs.size
|
||||
trace[Elab.Deriving.inhabited] "inhabited instance using{inlineExpr val}{if insts'.isEmpty then m!"" else m!"(assuming parameters {insts'} are inhabited)"}"
|
||||
let xs' := xs ++ insts'
|
||||
let auxType ← mkForallFVars xs' type
|
||||
let auxVal ← mkLambdaFVars xs' val
|
||||
return (auxType, auxVal, usedInstIdxs)
|
||||
|
||||
mkInstanceCmd? : TermElabM (Option Syntax) :=
|
||||
withExporting (isExporting := !isPrivateName ctorName) do
|
||||
let ctx ← mkContext ``Inhabited "default" inductiveTypeName
|
||||
let auxFunName := (← getCurrNamespace) ++ ctx.auxFunNames[0]!
|
||||
let indVal ← getConstInfoInduct inductiveTypeName
|
||||
let (auxType, auxVal, usedInstIdxs) ←
|
||||
try
|
||||
withDeclName auxFunName do mkDefaultValue indVal
|
||||
catch e =>
|
||||
trace[Elab.Deriving.inhabited] "error: {e.toMessageData}"
|
||||
return none
|
||||
addDecl <| .defnDecl <| ← mkDefinitionValInferringUnsafe
|
||||
(name := auxFunName)
|
||||
(levelParams := indVal.levelParams)
|
||||
(type := auxType)
|
||||
(value := auxVal)
|
||||
(hints := ReducibilityHints.regular (getMaxHeight (← getEnv) auxVal + 1))
|
||||
if isMarkedMeta (← getEnv) inductiveTypeName then
|
||||
modifyEnv (markMeta · auxFunName)
|
||||
unless (← read).isNoncomputableSection do
|
||||
compileDecls #[auxFunName]
|
||||
enableRealizationsForConst auxFunName
|
||||
trace[Elab.Deriving.inhabited] "defined {.ofConstName auxFunName}"
|
||||
let cmd ← mkInstanceCmdWith (mkIdent ctx.instName) usedInstIdxs (mkCIdent auxFunName)
|
||||
trace[Elab.Deriving.inhabited] "\n{cmd}"
|
||||
return some cmd
|
||||
|
||||
private def mkInhabitedInstance (declName : Name) : CommandElabM Unit := do
|
||||
withoutExposeFromCtors declName do
|
||||
|
||||
@@ -1038,19 +1038,19 @@ builtin_initialize registerBuiltinAttribute {
|
||||
}
|
||||
end
|
||||
|
||||
private unsafe def codeSuggestionsUnsafe : TermElabM (Array (StrLit → DocM (Array CodeSuggestion))) := do
|
||||
unsafe def codeSuggestionsUnsafe : TermElabM (Array (StrLit → DocM (Array CodeSuggestion))) := do
|
||||
let names := (codeSuggestionExt.getState (← getEnv)) |>.toArray
|
||||
return (← names.mapM (evalConst _)) ++ (← builtinCodeSuggestions.get).map (·.2)
|
||||
|
||||
@[implemented_by codeSuggestionsUnsafe]
|
||||
private opaque codeSuggestions : TermElabM (Array (StrLit → DocM (Array CodeSuggestion)))
|
||||
opaque codeSuggestions : TermElabM (Array (StrLit → DocM (Array CodeSuggestion)))
|
||||
|
||||
private unsafe def codeBlockSuggestionsUnsafe : TermElabM (Array (StrLit → DocM (Array CodeBlockSuggestion))) := do
|
||||
unsafe def codeBlockSuggestionsUnsafe : TermElabM (Array (StrLit → DocM (Array CodeBlockSuggestion))) := do
|
||||
let names := (codeBlockSuggestionExt.getState (← getEnv)) |>.toArray
|
||||
return (← names.mapM (evalConst _)) ++ (← builtinCodeBlockSuggestions.get).map (·.2)
|
||||
|
||||
@[implemented_by codeBlockSuggestionsUnsafe]
|
||||
private opaque codeBlockSuggestions : TermElabM (Array (StrLit → DocM (Array CodeBlockSuggestion)))
|
||||
opaque codeBlockSuggestions : TermElabM (Array (StrLit → DocM (Array CodeBlockSuggestion)))
|
||||
|
||||
/--
|
||||
Resolves a name against `NameMap` that contains a list of builtin expanders, taking into account
|
||||
@@ -1060,7 +1060,7 @@ resolution (`realizeGlobalConstNoOverload`) won't find them.
|
||||
|
||||
This is called as a fallback when the identifier can't be resolved.
|
||||
-/
|
||||
private def resolveBuiltinDocName {α : Type} (builtins : NameMap α) (x : Name) : TermElabM (Option α) := do
|
||||
def resolveBuiltinDocName {α : Type} (builtins : NameMap α) (x : Name) : TermElabM (Option α) := do
|
||||
if let some v := builtins.get? x then return some v
|
||||
|
||||
-- Builtins shouldn't require a prefix, as they're part of the language.
|
||||
@@ -1089,7 +1089,7 @@ private def resolveBuiltinDocName {α : Type} (builtins : NameMap α) (x : Name)
|
||||
|
||||
return none
|
||||
|
||||
private unsafe def roleExpandersForUnsafe (roleName : Ident) :
|
||||
unsafe def roleExpandersForUnsafe (roleName : Ident) :
|
||||
TermElabM (Array (Name × (TSyntaxArray `inline → StateT (Array (TSyntax `doc_arg)) DocM (Inline ElabInline)))) := do
|
||||
let x? ←
|
||||
try some <$> realizeGlobalConstNoOverload roleName
|
||||
@@ -1105,10 +1105,10 @@ private unsafe def roleExpandersForUnsafe (roleName : Ident) :
|
||||
|
||||
|
||||
@[implemented_by roleExpandersForUnsafe]
|
||||
private opaque roleExpandersFor (roleName : Ident) :
|
||||
opaque roleExpandersFor (roleName : Ident) :
|
||||
TermElabM (Array (Name × (TSyntaxArray `inline → StateT (Array (TSyntax `doc_arg)) DocM (Inline ElabInline))))
|
||||
|
||||
private unsafe def codeBlockExpandersForUnsafe (codeBlockName : Ident) :
|
||||
unsafe def codeBlockExpandersForUnsafe (codeBlockName : Ident) :
|
||||
TermElabM (Array (Name × (StrLit → StateT (Array (TSyntax `doc_arg)) DocM (Block ElabInline ElabBlock)))) := do
|
||||
let x? ←
|
||||
try some <$> realizeGlobalConstNoOverload codeBlockName
|
||||
@@ -1124,10 +1124,10 @@ private unsafe def codeBlockExpandersForUnsafe (codeBlockName : Ident) :
|
||||
|
||||
|
||||
@[implemented_by codeBlockExpandersForUnsafe]
|
||||
private opaque codeBlockExpandersFor (codeBlockName : Ident) :
|
||||
opaque codeBlockExpandersFor (codeBlockName : Ident) :
|
||||
TermElabM (Array (Name × (StrLit → StateT (Array (TSyntax `doc_arg)) DocM (Block ElabInline ElabBlock))))
|
||||
|
||||
private unsafe def directiveExpandersForUnsafe (directiveName : Ident) :
|
||||
unsafe def directiveExpandersForUnsafe (directiveName : Ident) :
|
||||
TermElabM (Array (Name × (TSyntaxArray `block → StateT (Array (TSyntax `doc_arg)) DocM (Block ElabInline ElabBlock)))) := do
|
||||
let x? ←
|
||||
try some <$> realizeGlobalConstNoOverload directiveName
|
||||
@@ -1142,10 +1142,10 @@ private unsafe def directiveExpandersForUnsafe (directiveName : Ident) :
|
||||
return hasBuiltin.toArray.flatten
|
||||
|
||||
@[implemented_by directiveExpandersForUnsafe]
|
||||
private opaque directiveExpandersFor (directiveName : Ident) :
|
||||
opaque directiveExpandersFor (directiveName : Ident) :
|
||||
TermElabM (Array (Name × (TSyntaxArray `block → StateT (Array (TSyntax `doc_arg)) DocM (Block ElabInline ElabBlock))))
|
||||
|
||||
private unsafe def commandExpandersForUnsafe (commandName : Ident) :
|
||||
unsafe def commandExpandersForUnsafe (commandName : Ident) :
|
||||
TermElabM (Array (Name × StateT (Array (TSyntax `doc_arg)) DocM (Block ElabInline ElabBlock))) := do
|
||||
let x? ←
|
||||
try some <$> realizeGlobalConstNoOverload commandName
|
||||
@@ -1161,18 +1161,18 @@ private unsafe def commandExpandersForUnsafe (commandName : Ident) :
|
||||
return hasBuiltin.toArray.flatten
|
||||
|
||||
@[implemented_by commandExpandersForUnsafe]
|
||||
private opaque commandExpandersFor (commandName : Ident) :
|
||||
opaque commandExpandersFor (commandName : Ident) :
|
||||
TermElabM (Array (Name × StateT (Array (TSyntax `doc_arg)) DocM (Block ElabInline ElabBlock)))
|
||||
|
||||
|
||||
private def mkArgVal (arg : TSyntax `arg_val) : DocM Term :=
|
||||
def mkArgVal (arg : TSyntax `arg_val) : DocM Term :=
|
||||
match arg with
|
||||
| `(arg_val|$n:ident) => pure n
|
||||
| `(arg_val|$n:num) => pure n
|
||||
| `(arg_val|$s:str) => pure s
|
||||
| _ => throwErrorAt arg "Didn't understand as argument value"
|
||||
|
||||
private def mkArg (arg : TSyntax `doc_arg) : DocM (TSyntax ``Parser.Term.argument) := do
|
||||
def mkArg (arg : TSyntax `doc_arg) : DocM (TSyntax ``Parser.Term.argument) := do
|
||||
match arg with
|
||||
| `(doc_arg|$x:arg_val) =>
|
||||
let x ← mkArgVal x
|
||||
@@ -1190,7 +1190,7 @@ private def mkArg (arg : TSyntax `doc_arg) : DocM (TSyntax ``Parser.Term.argumen
|
||||
`(Parser.Term.argument| ($x := $v))
|
||||
| _ => throwErrorAt arg "Didn't understand as argument"
|
||||
|
||||
private def mkAppStx (name : Ident) (args : TSyntaxArray `doc_arg) : DocM Term := do
|
||||
def mkAppStx (name : Ident) (args : TSyntaxArray `doc_arg) : DocM Term := do
|
||||
return ⟨mkNode ``Parser.Term.app #[name, mkNullNode (← args.mapM mkArg)]⟩
|
||||
|
||||
/--
|
||||
@@ -1204,7 +1204,7 @@ register_builtin_option doc.verso.suggestions : Bool := {
|
||||
-- Normally, name suggestions should be provided relative to the current scope. But
|
||||
-- during bootstrapping, the names in question may not yet be defined, so builtin
|
||||
-- names need special handling.
|
||||
private def suggestionName (name : Name) : TermElabM Name := do
|
||||
def suggestionName (name : Name) : TermElabM Name := do
|
||||
let name' ←
|
||||
-- Builtin expander names never need namespacing
|
||||
if (← builtinDocRoles.get).contains name then pure (some name)
|
||||
@@ -1241,7 +1241,7 @@ private def suggestionName (name : Name) : TermElabM Name := do
|
||||
-- Fall back to doing nothing
|
||||
pure name
|
||||
|
||||
private def sortSuggestions (ss : Array Meta.Hint.Suggestion) : Array Meta.Hint.Suggestion :=
|
||||
def sortSuggestions (ss : Array Meta.Hint.Suggestion) : Array Meta.Hint.Suggestion :=
|
||||
let cmp : (x y : Meta.Tactic.TryThis.SuggestionText) → Bool
|
||||
| .string s1, .string s2 => s1 < s2
|
||||
| .string _, _ => true
|
||||
@@ -1250,7 +1250,7 @@ private def sortSuggestions (ss : Array Meta.Hint.Suggestion) : Array Meta.Hint.
|
||||
ss.qsort (cmp ·.suggestion ·.suggestion)
|
||||
|
||||
open Diff in
|
||||
private def mkSuggestion
|
||||
def mkSuggestion
|
||||
(ref : Syntax) (hintTitle : MessageData)
|
||||
(newStrings : Array (String × Option String × Option String)) :
|
||||
DocM MessageData := do
|
||||
@@ -1281,7 +1281,7 @@ def nameOrBuiltinName [Monad m] [MonadEnv m] (x : Name) : m Name := do
|
||||
Finds registered expander names that `x` is a suffix of, for use in error message hints when the
|
||||
name is shadowed. Returns display names suitable for `mkSuggestion`.
|
||||
-/
|
||||
private def findShadowedNames {α : Type}
|
||||
def findShadowedNames {α : Type}
|
||||
(nonBuiltIns : NameMap (Array Name)) (builtins : NameMap α) (x : Name) :
|
||||
TermElabM (Array Name) := do
|
||||
if x.isAnonymous then return #[]
|
||||
@@ -1303,7 +1303,7 @@ private def findShadowedNames {α : Type}
|
||||
/--
|
||||
Builds a hint for an "Unknown role/directive/..." error when the name might be shadowed.
|
||||
-/
|
||||
private def shadowedHint {α : Type}
|
||||
def shadowedHint {α : Type}
|
||||
(envEntries : NameMap (Array Name)) (builtins : NameMap α)
|
||||
(name : Ident) (kind : String) : DocM MessageData := do
|
||||
let candidates ← findShadowedNames envEntries builtins name.getId
|
||||
@@ -1316,7 +1316,7 @@ Throws an appropriate error for an unknown doc element (role/directive/code bloc
|
||||
Distinguishes "name resolves but isn't registered" from "name doesn't resolve at all",
|
||||
and includes shadowed-name suggestions when applicable.
|
||||
-/
|
||||
private def throwUnknownDocElem {α β : Type}
|
||||
def throwUnknownDocElem {α β : Type}
|
||||
(envEntries : NameMap (Array Name)) (builtins : NameMap α)
|
||||
(name : Ident) (kind : String) : DocM β := do
|
||||
let hint ← shadowedHint envEntries builtins name kind
|
||||
@@ -1545,12 +1545,12 @@ where
|
||||
withSpace (s : String) : String :=
|
||||
if s.endsWith " " then s else s ++ " "
|
||||
|
||||
private def takeFirst? (xs : Array α) : Option (α × Array α) :=
|
||||
def takeFirst? (xs : Array α) : Option (α × Array α) :=
|
||||
if h : xs.size > 0 then
|
||||
some (xs[0], xs.extract 1)
|
||||
else none
|
||||
|
||||
private partial def elabBlocks' (level : Nat) :
|
||||
partial def elabBlocks' (level : Nat) :
|
||||
StateT (TSyntaxArray `block) DocM (Array (Block ElabInline ElabBlock) × Array (Part ElabInline ElabBlock Empty)) := do
|
||||
let mut pre := #[]
|
||||
let mut sub := #[]
|
||||
@@ -1586,7 +1586,7 @@ private partial def elabBlocks' (level : Nat) :
|
||||
break
|
||||
return (pre, sub)
|
||||
|
||||
private def elabModSnippet'
|
||||
def elabModSnippet'
|
||||
(range : DeclarationRange) (level : Nat) (blocks : TSyntaxArray `block) :
|
||||
DocM VersoModuleDocs.Snippet := do
|
||||
let mut snippet : VersoModuleDocs.Snippet := {
|
||||
@@ -1616,7 +1616,7 @@ private def elabModSnippet'
|
||||
snippet := snippet.addBlock (← elabBlock b)
|
||||
return snippet
|
||||
|
||||
private partial def fixupInline (inl : Inline ElabInline) : DocM (Inline ElabInline) := do
|
||||
partial def fixupInline (inl : Inline ElabInline) : DocM (Inline ElabInline) := do
|
||||
match inl with
|
||||
| .concat xs => .concat <$> xs.mapM fixupInline
|
||||
| .emph xs => .emph <$> xs.mapM fixupInline
|
||||
@@ -1663,7 +1663,7 @@ private partial def fixupInline (inl : Inline ElabInline) : DocM (Inline ElabInl
|
||||
return .empty
|
||||
| _ => .other i <$> xs.mapM fixupInline
|
||||
|
||||
private partial def fixupBlock (block : Block ElabInline ElabBlock) : DocM (Block ElabInline ElabBlock) := do
|
||||
partial def fixupBlock (block : Block ElabInline ElabBlock) : DocM (Block ElabInline ElabBlock) := do
|
||||
match block with
|
||||
| .para xs => .para <$> xs.mapM fixupInline
|
||||
| .concat xs => .concat <$> xs.mapM fixupBlock
|
||||
@@ -1677,7 +1677,7 @@ private partial def fixupBlock (block : Block ElabInline ElabBlock) : DocM (Bloc
|
||||
| .code s => pure (.code s)
|
||||
| .other i xs => .other i <$> xs.mapM fixupBlock
|
||||
|
||||
private partial def fixupPart (part : Part ElabInline ElabBlock Empty) : DocM (Part ElabInline ElabBlock Empty) := do
|
||||
partial def fixupPart (part : Part ElabInline ElabBlock Empty) : DocM (Part ElabInline ElabBlock Empty) := do
|
||||
return { part with
|
||||
title := ← part.title.mapM fixupInline
|
||||
content := ← part.content.mapM fixupBlock,
|
||||
@@ -1685,13 +1685,13 @@ private partial def fixupPart (part : Part ElabInline ElabBlock Empty) : DocM (P
|
||||
}
|
||||
|
||||
|
||||
private partial def fixupBlocks : (Array (Block ElabInline ElabBlock) × Array (Part ElabInline ElabBlock Empty)) → DocM (Array (Block ElabInline ElabBlock) × Array (Part ElabInline ElabBlock Empty))
|
||||
partial def fixupBlocks : (Array (Block ElabInline ElabBlock) × Array (Part ElabInline ElabBlock Empty)) → DocM (Array (Block ElabInline ElabBlock) × Array (Part ElabInline ElabBlock Empty))
|
||||
| (bs, ps) => do
|
||||
let bs ← bs.mapM fixupBlock
|
||||
let ps ← ps.mapM fixupPart
|
||||
return (bs, ps)
|
||||
|
||||
private partial def fixupSnippet (snippet : VersoModuleDocs.Snippet) : DocM VersoModuleDocs.Snippet := do
|
||||
partial def fixupSnippet (snippet : VersoModuleDocs.Snippet) : DocM VersoModuleDocs.Snippet := do
|
||||
return {snippet with
|
||||
text := ← snippet.text.mapM fixupBlock,
|
||||
sections := ← snippet.sections.mapM fun (level, range, content) => do
|
||||
@@ -1700,7 +1700,7 @@ private partial def fixupSnippet (snippet : VersoModuleDocs.Snippet) : DocM Vers
|
||||
/--
|
||||
After fixing up the references, check to see which were not used and emit a suitable warning.
|
||||
-/
|
||||
private def warnUnusedRefs : DocM Unit := do
|
||||
def warnUnusedRefs : DocM Unit := do
|
||||
for (_, {location, seen, ..}) in (← getThe InternalState).urls do
|
||||
unless seen do
|
||||
logWarningAt location "Unused URL"
|
||||
|
||||
@@ -31,7 +31,7 @@ structure Data.Atom where
|
||||
deriving TypeName
|
||||
|
||||
|
||||
private def onlyCode [Monad m] [MonadError m] (xs : TSyntaxArray `inline) : m StrLit := do
|
||||
def onlyCode [Monad m] [MonadError m] (xs : TSyntaxArray `inline) : m StrLit := do
|
||||
if h : xs.size = 1 then
|
||||
match xs[0] with
|
||||
| `(inline|code($s)) => return s
|
||||
@@ -43,7 +43,7 @@ private def onlyCode [Monad m] [MonadError m] (xs : TSyntaxArray `inline) : m St
|
||||
/--
|
||||
Checks whether a syntax descriptor's value contains the given atom.
|
||||
-/
|
||||
private partial def containsAtom (e : Expr) (atom : String) : MetaM Bool := do
|
||||
partial def containsAtom (e : Expr) (atom : String) : MetaM Bool := do
|
||||
let rec attempt (p : Expr) (tryWhnf : Bool) : MetaM Bool := do
|
||||
match p.getAppFnArgs with
|
||||
| (``ParserDescr.node, #[_, _, p]) => containsAtom p atom
|
||||
@@ -67,7 +67,7 @@ private partial def containsAtom (e : Expr) (atom : String) : MetaM Bool := do
|
||||
Checks whether a syntax descriptor's value contains the given atom. If so, the residual value after
|
||||
the atom is returned.
|
||||
-/
|
||||
private partial def containsAtom' (e : Expr) (atom : String) : MetaM (Option Expr) := do
|
||||
partial def containsAtom' (e : Expr) (atom : String) : MetaM (Option Expr) := do
|
||||
let rec attempt (p : Expr) (tryWhnf : Bool) : MetaM (Option Expr) := do
|
||||
match p.getAppFnArgs with
|
||||
| (``ParserDescr.node, #[_, _, p]) => containsAtom' p atom
|
||||
@@ -92,7 +92,7 @@ private partial def containsAtom' (e : Expr) (atom : String) : MetaM (Option Exp
|
||||
| _ => if tryWhnf then attempt (← Meta.whnf p) false else pure none
|
||||
attempt e true
|
||||
|
||||
private partial def canEpsilon (e : Expr) : MetaM Bool := do
|
||||
partial def canEpsilon (e : Expr) : MetaM Bool := do
|
||||
let rec attempt (p : Expr) (tryWhnf : Bool) : MetaM Bool := do
|
||||
match p.getAppFnArgs with
|
||||
| (``ParserDescr.node, #[_, _, p]) => canEpsilon p
|
||||
@@ -118,7 +118,7 @@ private partial def canEpsilon (e : Expr) : MetaM Bool := do
|
||||
Checks whether a syntax descriptor's value begins with the given atom. If so, the residual value
|
||||
after the atom is returned.
|
||||
-/
|
||||
private partial def startsWithAtom? (e : Expr) (atom : String) : MetaM (Option Expr) := do
|
||||
partial def startsWithAtom? (e : Expr) (atom : String) : MetaM (Option Expr) := do
|
||||
let rec attempt (p : Expr) (tryWhnf : Bool) : MetaM (Option Expr) := do
|
||||
match p.getAppFnArgs with
|
||||
| (``ParserDescr.node, #[_, _, p]) => startsWithAtom? p atom
|
||||
@@ -149,7 +149,7 @@ private partial def startsWithAtom? (e : Expr) (atom : String) : MetaM (Option E
|
||||
Checks whether a syntax descriptor's value begins with the given atoms. If so, the residual value
|
||||
after the atoms is returned.
|
||||
-/
|
||||
private partial def startsWithAtoms? (e : Expr) (atoms : List String) : MetaM (Option Expr) := do
|
||||
partial def startsWithAtoms? (e : Expr) (atoms : List String) : MetaM (Option Expr) := do
|
||||
match atoms with
|
||||
| [] => pure e
|
||||
| a :: as =>
|
||||
@@ -157,7 +157,7 @@ private partial def startsWithAtoms? (e : Expr) (atoms : List String) : MetaM (O
|
||||
startsWithAtoms? e' as
|
||||
else pure none
|
||||
|
||||
private partial def exprContainsAtoms (e : Expr) (atoms : List String) : MetaM Bool := do
|
||||
partial def exprContainsAtoms (e : Expr) (atoms : List String) : MetaM Bool := do
|
||||
match atoms with
|
||||
| [] => pure true
|
||||
| a :: as =>
|
||||
@@ -165,7 +165,7 @@ private partial def exprContainsAtoms (e : Expr) (atoms : List String) : MetaM B
|
||||
(startsWithAtoms? e' as <&> Option.isSome) <||> exprContainsAtoms e' (a :: as)
|
||||
else pure false
|
||||
|
||||
private def withAtom (cat : Name) (atom : String) : DocM (Array Name) := do
|
||||
def withAtom (cat : Name) (atom : String) : DocM (Array Name) := do
|
||||
let env ← getEnv
|
||||
let some catContents := (Lean.Parser.parserExtension.getState env).categories.find? cat
|
||||
| return #[]
|
||||
@@ -177,7 +177,7 @@ private def withAtom (cat : Name) (atom : String) : DocM (Array Name) := do
|
||||
found := found.push k
|
||||
return found
|
||||
|
||||
private partial def isAtoms (atoms : List String) (stx : Syntax) : Bool :=
|
||||
partial def isAtoms (atoms : List String) (stx : Syntax) : Bool :=
|
||||
StateT.run (go [stx]) atoms |>.fst
|
||||
where
|
||||
go (stxs : List Syntax) : StateM (List String) Bool := do
|
||||
@@ -196,7 +196,7 @@ where
|
||||
| .node _ _ args :: ss =>
|
||||
go (args.toList ++ ss)
|
||||
|
||||
private def parserHasAtomPrefix (atoms : List String) (p : Parser) : TermElabM Bool := do
|
||||
def parserHasAtomPrefix (atoms : List String) (p : Parser) : TermElabM Bool := do
|
||||
let str := " ".intercalate atoms
|
||||
let env ← getEnv
|
||||
let options ← getOptions
|
||||
@@ -206,16 +206,16 @@ private def parserHasAtomPrefix (atoms : List String) (p : Parser) : TermElabM B
|
||||
let s := p.fn.run {inputString := str, fileName := "", fileMap := FileMap.ofString str} {env, options} (getTokenTable env) s
|
||||
return isAtoms atoms (mkNullNode (s.stxStack.extract 1 s.stxStack.size))
|
||||
|
||||
private unsafe def namedParserHasAtomPrefixUnsafe (atoms : List String) (parserName : Name) : TermElabM Bool := do
|
||||
unsafe def namedParserHasAtomPrefixUnsafe (atoms : List String) (parserName : Name) : TermElabM Bool := do
|
||||
try
|
||||
let p ← evalConstCheck Parser ``Parser parserName
|
||||
parserHasAtomPrefix atoms p
|
||||
catch | _ => pure false
|
||||
|
||||
@[implemented_by namedParserHasAtomPrefixUnsafe]
|
||||
private opaque namedParserHasAtomPrefix (atoms : List String) (parserName : Name) : TermElabM Bool
|
||||
opaque namedParserHasAtomPrefix (atoms : List String) (parserName : Name) : TermElabM Bool
|
||||
|
||||
private def parserDescrCanEps : ParserDescr → Bool
|
||||
def parserDescrCanEps : ParserDescr → Bool
|
||||
| .node _ _ p | .trailingNode _ _ _ p => parserDescrCanEps p
|
||||
| .binary ``Parser.andthen p1 p2 => parserDescrCanEps p1 && parserDescrCanEps p2
|
||||
| .binary ``Parser.orelse p1 p2 => parserDescrCanEps p1 || parserDescrCanEps p2
|
||||
@@ -227,7 +227,7 @@ private def parserDescrCanEps : ParserDescr → Bool
|
||||
| .const ``Parser.ppHardSpace => true
|
||||
| _ => false
|
||||
|
||||
private def parserDescrHasAtom (atom : String) (p : ParserDescr) : TermElabM (Option ParserDescr) := do
|
||||
def parserDescrHasAtom (atom : String) (p : ParserDescr) : TermElabM (Option ParserDescr) := do
|
||||
match p with
|
||||
| .node _ _ p | .trailingNode _ _ _ p | .unary _ p =>
|
||||
parserDescrHasAtom atom p
|
||||
@@ -249,7 +249,7 @@ private def parserDescrHasAtom (atom : String) (p : ParserDescr) : TermElabM (Op
|
||||
| none, none => pure none
|
||||
| _ => pure none
|
||||
|
||||
private def parserDescrStartsWithAtom (atom : String) (p : ParserDescr) : TermElabM (Option ParserDescr) := do
|
||||
def parserDescrStartsWithAtom (atom : String) (p : ParserDescr) : TermElabM (Option ParserDescr) := do
|
||||
match p with
|
||||
| .node _ _ p | .trailingNode _ _ _ p | .unary _ p =>
|
||||
parserDescrStartsWithAtom atom p
|
||||
@@ -272,7 +272,7 @@ private def parserDescrStartsWithAtom (atom : String) (p : ParserDescr) : TermEl
|
||||
| none, none => pure none
|
||||
| _ => pure none
|
||||
|
||||
private def parserDescrStartsWithAtoms (atoms : List String) (p : ParserDescr) : TermElabM Bool := do
|
||||
def parserDescrStartsWithAtoms (atoms : List String) (p : ParserDescr) : TermElabM Bool := do
|
||||
match atoms with
|
||||
| [] => pure true
|
||||
| a :: as =>
|
||||
@@ -280,7 +280,7 @@ private def parserDescrStartsWithAtoms (atoms : List String) (p : ParserDescr) :
|
||||
parserDescrStartsWithAtoms as p'
|
||||
else pure false
|
||||
|
||||
private partial def parserDescrHasAtoms (atoms : List String) (p : ParserDescr) : TermElabM Bool := do
|
||||
partial def parserDescrHasAtoms (atoms : List String) (p : ParserDescr) : TermElabM Bool := do
|
||||
match atoms with
|
||||
| [] => pure true
|
||||
| a :: as =>
|
||||
@@ -289,16 +289,16 @@ private partial def parserDescrHasAtoms (atoms : List String) (p : ParserDescr)
|
||||
else parserDescrHasAtoms (a :: as) p'
|
||||
else pure false
|
||||
|
||||
private unsafe def parserDescrNameHasAtomsUnsafe (atoms : List String) (p : Name) : TermElabM Bool := do
|
||||
unsafe def parserDescrNameHasAtomsUnsafe (atoms : List String) (p : Name) : TermElabM Bool := do
|
||||
try
|
||||
let p ← evalConstCheck ParserDescr ``ParserDescr p
|
||||
parserDescrHasAtoms atoms p
|
||||
catch | _ => pure false
|
||||
|
||||
@[implemented_by parserDescrNameHasAtomsUnsafe]
|
||||
private opaque parserDescrNameHasAtoms (atoms : List String) (p : Name) : TermElabM Bool
|
||||
opaque parserDescrNameHasAtoms (atoms : List String) (p : Name) : TermElabM Bool
|
||||
|
||||
private def kindHasAtoms (k : Name) (atoms : List String) : TermElabM Bool := do
|
||||
def kindHasAtoms (k : Name) (atoms : List String) : TermElabM Bool := do
|
||||
let env ← getEnv
|
||||
if let some ci := env.find? k then
|
||||
if let some d := ci.value? then
|
||||
@@ -312,7 +312,7 @@ private def kindHasAtoms (k : Name) (atoms : List String) : TermElabM Bool := do
|
||||
return true
|
||||
return false
|
||||
|
||||
private def withAtoms (cat : Name) (atoms : List String) : TermElabM (Array Name) := do
|
||||
def withAtoms (cat : Name) (atoms : List String) : TermElabM (Array Name) := do
|
||||
let env ← getEnv
|
||||
let some catContents := (Lean.Parser.parserExtension.getState env).categories.find? cat
|
||||
| return #[]
|
||||
@@ -323,7 +323,7 @@ private def withAtoms (cat : Name) (atoms : List String) : TermElabM (Array Name
|
||||
found := found.push k
|
||||
return found
|
||||
|
||||
private def kwImpl (cat : Ident := mkIdent .anonymous) (of : Ident := mkIdent .anonymous)
|
||||
def kwImpl (cat : Ident := mkIdent .anonymous) (of : Ident := mkIdent .anonymous)
|
||||
(suggest : Bool)
|
||||
(s : StrLit) : TermElabM (Inline ElabInline) := do
|
||||
let atoms := s.getString |>.split Char.isWhitespace |>.toStringList
|
||||
|
||||
@@ -10,6 +10,7 @@ public import Lean.Parser.Module
|
||||
meta import Lean.Parser.Module
|
||||
import Lean.Compiler.ModPkgExt
|
||||
public import Lean.DeprecatedModule
|
||||
import Init.Data.String.Modify
|
||||
|
||||
public section
|
||||
|
||||
@@ -28,7 +29,9 @@ def HeaderSyntax.isModule (header : HeaderSyntax) : Bool :=
|
||||
def HeaderSyntax.imports (stx : HeaderSyntax) (includeInit : Bool := true) : Array Import :=
|
||||
match stx with
|
||||
| `(Parser.Module.header| $[module%$moduleTk]? $[prelude%$preludeTk]? $importsStx*) =>
|
||||
let imports := if preludeTk.isNone && includeInit then #[{ module := `Init : Import }] else #[]
|
||||
let imports := if preludeTk.isNone && includeInit then
|
||||
#[{ module := `Init : Import }, { module := `Init, isMeta := true : Import }]
|
||||
else #[]
|
||||
imports ++ importsStx.map fun
|
||||
| `(Parser.Module.import| $[public%$publicTk]? $[meta%$metaTk]? import $[all%$allTk]? $n) =>
|
||||
{ module := n.getId, importAll := allTk.isSome
|
||||
@@ -95,6 +98,43 @@ def checkDeprecatedImports
|
||||
| none => messages
|
||||
| none => messages
|
||||
|
||||
private def osForbiddenChars : Array Char :=
|
||||
#['<', '>', '"', '|', '?', '*', '!']
|
||||
|
||||
private def osForbiddenNames : Array String :=
|
||||
#["CON", "PRN", "AUX", "NUL",
|
||||
"COM1", "COM2", "COM3", "COM4", "COM5", "COM6", "COM7", "COM8", "COM9",
|
||||
"COM¹", "COM²", "COM³",
|
||||
"LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6", "LPT7", "LPT8", "LPT9",
|
||||
"LPT¹", "LPT²", "LPT³"]
|
||||
|
||||
private def checkComponentPortability (comp : String) : Option String :=
|
||||
if osForbiddenNames.contains comp.toUpper then
|
||||
some s!"'{comp}' is a reserved file name on some operating systems"
|
||||
else if let some c := osForbiddenChars.find? (comp.contains ·) then
|
||||
some s!"contains character '{c}' which is forbidden on some operating systems"
|
||||
else
|
||||
none
|
||||
|
||||
def checkModuleNamePortability
|
||||
(mainModule : Name) (inputCtx : Parser.InputContext) (startPos : String.Pos.Raw)
|
||||
(messages : MessageLog) : MessageLog :=
|
||||
go mainModule messages
|
||||
where
|
||||
go : Name → MessageLog → MessageLog
|
||||
| .anonymous, messages => messages
|
||||
| .str parent s, messages =>
|
||||
let messages := match checkComponentPortability s with
|
||||
| some reason => messages.add {
|
||||
fileName := inputCtx.fileName
|
||||
pos := inputCtx.fileMap.toPosition startPos
|
||||
severity := .error
|
||||
data := s!"module name '{mainModule}' is not portable: {reason}"
|
||||
}
|
||||
| none => messages
|
||||
go parent messages
|
||||
| .num parent _, messages => go parent messages
|
||||
|
||||
def processHeaderCore
|
||||
(startPos : String.Pos.Raw) (imports : Array Import) (isModule : Bool)
|
||||
(opts : Options) (messages : MessageLog) (inputCtx : Parser.InputContext)
|
||||
@@ -122,6 +162,7 @@ def processHeaderCore
|
||||
pure (env, messages.add { fileName := inputCtx.fileName, data := toString e, pos := pos })
|
||||
let env := env.setMainModule mainModule |>.setModulePackage package?
|
||||
let messages := checkDeprecatedImports env imports opts inputCtx startPos messages headerStx? origHeaderStx?
|
||||
let messages := checkModuleNamePortability mainModule inputCtx startPos messages
|
||||
return (env, messages)
|
||||
|
||||
/--
|
||||
|
||||
@@ -233,7 +233,7 @@ def setImportAll : Parser := fun _ s =>
|
||||
|
||||
def main : Parser :=
|
||||
keywordCore "module" (setIsModule false) (setIsModule true) >>
|
||||
keywordCore "prelude" (fun _ s => s.pushImport `Init) skip >>
|
||||
keywordCore "prelude" (fun _ s => (s.pushImport `Init).pushImport { module := `Init, isMeta := true }) skip >>
|
||||
manyImports (atomic (keywordCore "public" skip setExported >>
|
||||
keywordCore "meta" skip setMeta >>
|
||||
keyword "import") >>
|
||||
|
||||
@@ -55,7 +55,7 @@ def unfoldLHS (declName : Name) (mvarId : MVarId) : MetaM MVarId := mvarId.withC
|
||||
-- Else use delta reduction
|
||||
deltaLHS mvarId
|
||||
|
||||
private partial def mkEqnProof (declName : Name) (type : Expr) : MetaM Expr := do
|
||||
partial def mkEqnProof (declName : Name) (type : Expr) : MetaM Expr := do
|
||||
withTraceNode `Elab.definition.eqns (fun _ => return m!"proving:{indentExpr type}") do
|
||||
withNewMCtxDepth do
|
||||
let main ← mkFreshExprSyntheticOpaqueMVar type
|
||||
@@ -102,7 +102,7 @@ private partial def mkEqnProof (declName : Name) (type : Expr) : MetaM Expr := d
|
||||
else
|
||||
throwError "failed to generate equational theorem for `{.ofConstName declName}`\n{MessageData.ofGoal mvarId}"
|
||||
|
||||
private def lhsDependsOn (type : Expr) (fvarId : FVarId) : MetaM Bool :=
|
||||
def lhsDependsOn (type : Expr) (fvarId : FVarId) : MetaM Bool :=
|
||||
forallTelescope type fun _ type => do
|
||||
if let some (_, lhs, _) ← matchEq? type then
|
||||
dependsOn lhs fvarId
|
||||
|
||||
@@ -113,7 +113,7 @@ private def isSectionVariable (e : Expr) : TermElabM Bool := do
|
||||
if (← read).quotLCtx.contains val then
|
||||
return
|
||||
let rs ← try resolveName stx val [] [] catch _ => pure []
|
||||
for (e, _) in rs do
|
||||
for (e, _, _) in rs do
|
||||
match e with
|
||||
| Expr.fvar _ .. =>
|
||||
if quotPrecheck.allowSectionVars.get (← getOptions) && (← isSectionVariable e) then
|
||||
|
||||
@@ -232,7 +232,10 @@ structure TacticFinishedSnapshot extends Language.Snapshot where
|
||||
state? : Option SavedState
|
||||
/-- Untyped snapshots from `logSnapshotTask`, saved at this level for cancellation. -/
|
||||
moreSnaps : Array (SnapshotTask SnapshotTree)
|
||||
deriving Inhabited
|
||||
|
||||
instance : Inhabited TacticFinishedSnapshot where
|
||||
default := { toSnapshot := default, state? := default, moreSnaps := default }
|
||||
|
||||
instance : ToSnapshotTree TacticFinishedSnapshot where
|
||||
toSnapshotTree s := ⟨s.toSnapshot, s.moreSnaps⟩
|
||||
|
||||
@@ -246,7 +249,10 @@ structure TacticParsedSnapshot extends Language.Snapshot where
|
||||
finished : SnapshotTask TacticFinishedSnapshot
|
||||
/-- Tasks for subsequent, potentially parallel, tactic steps. -/
|
||||
next : Array (SnapshotTask TacticParsedSnapshot) := #[]
|
||||
deriving Inhabited
|
||||
|
||||
instance : Inhabited TacticParsedSnapshot where
|
||||
default := { toSnapshot := default, stx := default, finished := default }
|
||||
|
||||
partial instance : ToSnapshotTree TacticParsedSnapshot where
|
||||
toSnapshotTree := go where
|
||||
go := fun s => ⟨s.toSnapshot,
|
||||
@@ -627,13 +633,13 @@ builtin_initialize termElabAttribute : KeyedDeclsAttribute TermElab ← mkTermEl
|
||||
`[LVal.fieldName "foo", LVal.fieldIdx 1]`.
|
||||
-/
|
||||
inductive LVal where
|
||||
| fieldIdx (ref : Syntax) (i : Nat)
|
||||
| fieldIdx (ref : Syntax) (i : Nat) (levels : List Level)
|
||||
/-- Field `suffix?` is for producing better error messages because `x.y` may be a field access or a hierarchical/composite name.
|
||||
`ref` is the syntax object representing the field. `fullRef` includes the LHS. -/
|
||||
| fieldName (ref : Syntax) (name : String) (suffix? : Option Name) (fullRef : Syntax)
|
||||
| fieldName (ref : Syntax) (name : String) (levels : List Level) (suffix? : Option Name) (fullRef : Syntax)
|
||||
|
||||
def LVal.getRef : LVal → Syntax
|
||||
| .fieldIdx ref _ => ref
|
||||
| .fieldIdx ref .. => ref
|
||||
| .fieldName ref .. => ref
|
||||
|
||||
def LVal.isFieldName : LVal → Bool
|
||||
@@ -642,8 +648,11 @@ def LVal.isFieldName : LVal → Bool
|
||||
|
||||
instance : ToString LVal where
|
||||
toString
|
||||
| .fieldIdx _ i => toString i
|
||||
| .fieldName _ n .. => n
|
||||
| .fieldIdx _ i levels .. => toString i ++ levelsToString levels
|
||||
| .fieldName _ n levels .. => n ++ levelsToString levels
|
||||
where
|
||||
levelsToString levels :=
|
||||
if levels.isEmpty then "" else ".{" ++ String.intercalate "," (levels.map toString) ++ "}"
|
||||
|
||||
/-- Return the name of the declaration being elaborated if available. -/
|
||||
def getDeclName? : TermElabM (Option Name) := return (← read).declName?
|
||||
@@ -2111,8 +2120,10 @@ def checkDeprecated (ref : Syntax) (e : Expr) : TermElabM Unit := do
|
||||
@[inline] def withoutCheckDeprecated [MonadWithReaderOf Context m] : m α → m α :=
|
||||
withTheReader Context (fun ctx => { ctx with checkDeprecated := false })
|
||||
|
||||
private def mkConsts (candidates : List (Name × List String)) (explicitLevels : List Level) : TermElabM (List (Expr × List String)) := do
|
||||
private def mkConsts (candidates : List (Name × List String)) (explicitLevels : List Level) : TermElabM (List (Expr × List String × List Level)) := do
|
||||
candidates.foldlM (init := []) fun result (declName, projs) => do
|
||||
-- levels apply to the last projection, not the constant
|
||||
let (constLevels, projLevels) := if projs.isEmpty then (explicitLevels, []) else ([], explicitLevels)
|
||||
-- TODO: better support for `mkConst` failure. We may want to cache the failures, and report them if all candidates fail.
|
||||
/-
|
||||
We disable `checkDeprecated` here because there may be many overloaded symbols.
|
||||
@@ -2121,25 +2132,38 @@ private def mkConsts (candidates : List (Name × List String)) (explicitLevels :
|
||||
At `elabAppFnId`, we perform the check when converting the list returned by `resolveName'` into a list of
|
||||
`TermElabResult`s.
|
||||
-/
|
||||
let const ← withoutCheckDeprecated <| mkConst declName explicitLevels
|
||||
return (const, projs) :: result
|
||||
let const ← withoutCheckDeprecated <| mkConst declName constLevels
|
||||
return (const, projs, projLevels) :: result
|
||||
|
||||
def throwInvalidExplicitUniversesForLocal {α} (e : Expr) : TermElabM α :=
|
||||
throwError "invalid use of explicit universe parameters, `{e}` is a local variable"
|
||||
|
||||
def resolveName (stx : Syntax) (n : Name) (preresolved : List Syntax.Preresolved) (explicitLevels : List Level) (expectedType? : Option Expr := none) : TermElabM (List (Expr × List String)) := do
|
||||
/--
|
||||
Gives all resolutions of the name `n`.
|
||||
|
||||
- `explicitLevels` provides a prefix of level parameters to the constant. For resolutions with a projection
|
||||
component, the levels are not used, since they must apply to the last projection, not the constant.
|
||||
In that case, the third component of the tuple is `explicitLevels`.
|
||||
-/
|
||||
def resolveName (stx : Syntax) (n : Name) (preresolved : List Syntax.Preresolved) (explicitLevels : List Level) (expectedType? : Option Expr := none) : TermElabM (List (Expr × List String × List Level)) := do
|
||||
addCompletionInfo <| CompletionInfo.id stx stx.getId (danglingDot := false) (← getLCtx) expectedType?
|
||||
let processLocal (e : Expr) (projs : List String) := do
|
||||
if projs.isEmpty then
|
||||
if explicitLevels.isEmpty then
|
||||
return [(e, [], [])]
|
||||
else
|
||||
throwInvalidExplicitUniversesForLocal e
|
||||
else
|
||||
return [(e, projs, explicitLevels)]
|
||||
if let some (e, projs) ← resolveLocalName n then
|
||||
unless explicitLevels.isEmpty do
|
||||
throwInvalidExplicitUniversesForLocal e
|
||||
return [(e, projs)]
|
||||
return ← processLocal e projs
|
||||
let preresolved := preresolved.filterMap fun
|
||||
| .decl n projs => some (n, projs)
|
||||
| _ => none
|
||||
-- check for section variable capture by a quotation
|
||||
let ctx ← read
|
||||
if let some (e, projs) := preresolved.findSome? fun (n, projs) => ctx.sectionFVars.find? n |>.map (·, projs) then
|
||||
return [(e, projs)] -- section variables should shadow global decls
|
||||
return ← processLocal e projs -- section variables should shadow global decls
|
||||
if preresolved.isEmpty then
|
||||
mkConsts (← realizeGlobalName n) explicitLevels
|
||||
else
|
||||
@@ -2148,14 +2172,17 @@ def resolveName (stx : Syntax) (n : Name) (preresolved : List Syntax.Preresolved
|
||||
/--
|
||||
Similar to `resolveName`, but creates identifiers for the main part and each projection with position information derived from `ident`.
|
||||
Example: Assume resolveName `v.head.bla.boo` produces `(v.head, ["bla", "boo"])`, then this method produces
|
||||
`(v.head, id, [f₁, f₂])` where `id` is an identifier for `v.head`, and `f₁` and `f₂` are identifiers for fields `"bla"` and `"boo"`. -/
|
||||
def resolveName' (ident : Syntax) (explicitLevels : List Level) (expectedType? : Option Expr := none) : TermElabM (Name × List (Expr × Syntax × List Syntax)) := do
|
||||
`(v.head, id, [f₁, f₂])` where `id` is an identifier for `v.head`, and `f₁` and `f₂` are identifiers for fields `"bla"` and `"boo"`.
|
||||
|
||||
See the comment there about `explicitLevels` and the meaning of the `List Level` component of the returned tuple.
|
||||
-/
|
||||
def resolveName' (ident : Syntax) (explicitLevels : List Level) (expectedType? : Option Expr := none) : TermElabM (Name × List (Expr × Syntax × List Syntax × List Level)) := do
|
||||
let .ident _ _ n preresolved := ident
|
||||
| throwError "identifier expected"
|
||||
let r ← resolveName ident n preresolved explicitLevels expectedType?
|
||||
let rc ← r.mapM fun (c, fields) => do
|
||||
let rc ← r.mapM fun (c, fields, levels) => do
|
||||
let ids := ident.identComponents (nFields? := fields.length)
|
||||
return (c, ids.head!, ids.tail!)
|
||||
return (c, ids.head!, ids.tail!, levels)
|
||||
return (n, rc)
|
||||
|
||||
|
||||
@@ -2163,7 +2190,7 @@ def resolveId? (stx : Syntax) (kind := "term") (withInfo := false) : TermElabM (
|
||||
match stx with
|
||||
| .ident _ _ val preresolved =>
|
||||
let rs ← try resolveName stx val preresolved [] catch _ => pure []
|
||||
let rs := rs.filter fun ⟨_, projs⟩ => projs.isEmpty
|
||||
let rs := rs.filter fun ⟨_, projs, _⟩ => projs.isEmpty
|
||||
let fs := rs.map fun (f, _) => f
|
||||
match fs with
|
||||
| [] => return none
|
||||
|
||||
@@ -616,7 +616,13 @@ structure Environment where
|
||||
/--
|
||||
Indicates whether the environment is being used in an exported context, i.e. whether it should
|
||||
provide access to only the data to be imported by other modules participating in the module
|
||||
system.
|
||||
system. Apart from controlling access, some operations such as `mkAuxDeclName` may also change
|
||||
their output based on this flag.
|
||||
|
||||
By default, `isExporting` is set to false when command elaborators are invoked such that they have
|
||||
access to the full local environment. Use `with(out)Exporting` to modify based on context. For
|
||||
example, `elabDeclaration` sets it based on `(← getScope).isPublic` on the top level, then
|
||||
`elabMutualDef` may switch from public to private when e.g. entering the proof of a theorem.
|
||||
-/
|
||||
isExporting : Bool := false
|
||||
deriving Nonempty
|
||||
|
||||
@@ -73,19 +73,19 @@ def hasErrorExplanation [Monad m] [MonadEnv m] (name : Name) : m Bool :=
|
||||
return errorExplanationExt.getState (← getEnv) |>.contains name
|
||||
|
||||
/-- Returns all error explanations with their names, sorted by name. -/
|
||||
public def getErrorExplanations [Monad m] [MonadEnv m] : m (Array (Name × ErrorExplanation)) := do
|
||||
def getErrorExplanations [Monad m] [MonadEnv m] : m (Array (Name × ErrorExplanation)) := do
|
||||
return errorExplanationExt.getState (← getEnv)
|
||||
|>.toArray
|
||||
|>.qsort fun e e' => e.1.toString < e'.1.toString
|
||||
|
||||
@[deprecated getErrorExplanations (since := "2026-12-20")]
|
||||
public def getErrorExplanationsRaw (env : Environment) : Array (Name × ErrorExplanation) :=
|
||||
def getErrorExplanationsRaw (env : Environment) : Array (Name × ErrorExplanation) :=
|
||||
errorExplanationExt.getState env
|
||||
|>.toArray
|
||||
|>.qsort fun e e' => e.1.toString < e'.1.toString
|
||||
|
||||
@[deprecated getErrorExplanations (since := "2026-12-20")]
|
||||
public def getErrorExplanationsSorted [Monad m] [MonadEnv m] : m (Array (Name × ErrorExplanation)) := do
|
||||
def getErrorExplanationsSorted [Monad m] [MonadEnv m] : m (Array (Name × ErrorExplanation)) := do
|
||||
getErrorExplanations
|
||||
|
||||
end Lean
|
||||
|
||||
@@ -67,7 +67,9 @@ structure Snapshot where
|
||||
`diagnostics`) occurred that prevents processing of the remainder of the file.
|
||||
-/
|
||||
isFatal := false
|
||||
deriving Inhabited
|
||||
|
||||
instance : Inhabited Snapshot where
|
||||
default := { desc := "", diagnostics := default }
|
||||
|
||||
/-- Range that is marked as being processed by the server while a task is running. -/
|
||||
inductive SnapshotTask.ReportingRange where
|
||||
@@ -236,7 +238,10 @@ partial def SnapshotTask.cancelRec [ToSnapshotTree α] (t : SnapshotTask α) : B
|
||||
|
||||
/-- Snapshot type without child nodes. -/
|
||||
structure SnapshotLeaf extends Snapshot
|
||||
deriving Inhabited, TypeName
|
||||
deriving TypeName
|
||||
|
||||
instance : Inhabited SnapshotLeaf where
|
||||
default := { toSnapshot := default }
|
||||
|
||||
instance : ToSnapshotTree SnapshotLeaf where
|
||||
toSnapshotTree s := SnapshotTree.mk s.toSnapshot #[]
|
||||
|
||||
@@ -19,3 +19,4 @@ public import Lean.Linter.Sets
|
||||
public import Lean.Linter.UnusedSimpArgs
|
||||
public import Lean.Linter.Coe
|
||||
public import Lean.Linter.GlobalAttributeIn
|
||||
public import Lean.Linter.EnvLinter
|
||||
|
||||
10
src/Lean/Linter/EnvLinter.lean
Normal file
10
src/Lean/Linter/EnvLinter.lean
Normal file
@@ -0,0 +1,10 @@
|
||||
/-
|
||||
Copyright (c) 2026 Lean FRO, LLC. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Wojciech Różowski
|
||||
-/
|
||||
module
|
||||
|
||||
prelude
|
||||
public import Lean.Linter.EnvLinter.Basic
|
||||
public import Lean.Linter.EnvLinter.Frontend
|
||||
163
src/Lean/Linter/EnvLinter/Basic.lean
Normal file
163
src/Lean/Linter/EnvLinter/Basic.lean
Normal file
@@ -0,0 +1,163 @@
|
||||
/-
|
||||
Copyright (c) 2026 Lean FRO, LLC. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Wojciech Różowski
|
||||
|
||||
Copyright (c) 2020 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn, Robert Y. Lewis, Gabriel Ebner
|
||||
-/
|
||||
module
|
||||
|
||||
prelude
|
||||
public import Lean.Structure
|
||||
public import Lean.Elab.InfoTree.Main
|
||||
import Lean.ExtraModUses
|
||||
|
||||
public section
|
||||
|
||||
open Lean Meta
|
||||
|
||||
namespace Lean.Linter.EnvLinter
|
||||
|
||||
/-!
|
||||
# Basic environment linter types and attributes
|
||||
|
||||
This file defines the basic types and attributes used by the environment
|
||||
linting framework. An environment linter consists of a function
|
||||
`(declaration : Name) → MetaM (Option MessageData)`, this function together with some
|
||||
metadata is stored in the `EnvLinter` structure. We define two attributes:
|
||||
|
||||
* `@[builtin_env_linter]` applies to a declaration of type `EnvLinter`
|
||||
and adds it to the default linter set.
|
||||
|
||||
* `@[builtin_nolint linterName]` omits the tagged declaration from being checked by
|
||||
the linter with name `linterName`.
|
||||
-/
|
||||
|
||||
/--
|
||||
Returns true if `decl` is an automatically generated declaration.
|
||||
|
||||
Also returns true if `decl` is an internal name or created during macro
|
||||
expansion.
|
||||
-/
|
||||
def isAutoDecl (decl : Name) : CoreM Bool := do
|
||||
if decl.hasMacroScopes then return true
|
||||
if decl.isInternal then return true
|
||||
let env ← getEnv
|
||||
if isReservedName env decl then return true
|
||||
if let Name.str n s := decl then
|
||||
if (← isAutoDecl n) then return true
|
||||
if s.startsWith "proof_"
|
||||
|| s.startsWith "match_"
|
||||
|| s.startsWith "unsafe_"
|
||||
|| s.startsWith "grind_"
|
||||
then return true
|
||||
if env.isConstructor n && s ∈ ["injEq", "inj", "sizeOf_spec", "elim", "noConfusion"] then
|
||||
return true
|
||||
if let ConstantInfo.inductInfo _ := env.find? n then
|
||||
if s.startsWith "brecOn_" || s.startsWith "below_" then return true
|
||||
if s ∈ [casesOnSuffix, recOnSuffix, brecOnSuffix, belowSuffix,
|
||||
"ndrec", "ndrecOn", "noConfusionType", "noConfusion", "ofNat", "toCtorIdx", "ctorIdx",
|
||||
"ctorElim", "ctorElimType"] then
|
||||
return true
|
||||
if let some _ := isSubobjectField? env n (.mkSimple s) then
|
||||
return true
|
||||
-- Coinductive/inductive lattice-theoretic predicates:
|
||||
if let ConstantInfo.inductInfo _ := env.find? (Name.str n "_functor") then
|
||||
if s == "functor_unfold" || s == casesOnSuffix || s == "mutual" then return true
|
||||
if env.isConstructor (Name.str (Name.str n "_functor") s) then return true
|
||||
pure false
|
||||
|
||||
/-- An environment linting test for the `lake builtin-lint` command. -/
|
||||
structure EnvLinter where
|
||||
/-- `test` defines a test to perform on every declaration. It should never fail. Returning `none`
|
||||
signifies a passing test. Returning `some msg` reports a failing test with error `msg`. -/
|
||||
test : Name → MetaM (Option MessageData)
|
||||
/-- `noErrorsFound` is the message printed when all tests are negative -/
|
||||
noErrorsFound : MessageData
|
||||
/-- `errorsFound` is printed when at least one test is positive -/
|
||||
errorsFound : MessageData
|
||||
/-- If `isDefault` is false, this linter is only run when `--clippy` is passed. -/
|
||||
isDefault := true
|
||||
|
||||
/-- A `NamedEnvLinter` is an environment linter associated to a particular declaration. -/
|
||||
structure NamedEnvLinter extends EnvLinter where
|
||||
/-- The name of the named linter. This is just the declaration name without the namespace. -/
|
||||
name : Name
|
||||
/-- The linter declaration name -/
|
||||
declName : Name
|
||||
|
||||
/-- Gets an environment linter by declaration name. -/
|
||||
def getEnvLinter (name declName : Name) : CoreM NamedEnvLinter := unsafe
|
||||
return { ← evalConstCheck EnvLinter ``EnvLinter declName with name, declName }
|
||||
|
||||
/-- Defines the `envLinterExt` extension for adding an environment linter to the default set. -/
|
||||
builtin_initialize envLinterExt :
|
||||
SimplePersistentEnvExtension (Name × Bool) (NameMap (Name × Bool)) ←
|
||||
let addEntryFn := fun m (n, b) => m.insert (n.updatePrefix .anonymous) (n, b)
|
||||
registerSimplePersistentEnvExtension {
|
||||
addImportedFn := fun nss =>
|
||||
nss.foldl (init := {}) fun m ns => ns.foldl (init := m) addEntryFn
|
||||
addEntryFn
|
||||
}
|
||||
|
||||
/--
|
||||
Defines the `@[builtin_env_linter]` attribute for adding a linter to the default set.
|
||||
The form `@[builtin_env_linter clippy]` will not add the linter to the default set,
|
||||
but it can be selected by `lake builtin-lint --clippy`.
|
||||
|
||||
Linters are named using their declaration names, without the namespace. These must be distinct.
|
||||
-/
|
||||
syntax (name := builtin_env_linter) "builtin_env_linter" &" clippy"? : attr
|
||||
|
||||
builtin_initialize registerBuiltinAttribute {
|
||||
name := `builtin_env_linter
|
||||
descr := "Use this declaration as a linting test in `lake builtin-lint`"
|
||||
add := fun decl stx kind => do
|
||||
let dflt := stx[1].isNone
|
||||
unless kind == .global do throwError "invalid attribute `builtin_env_linter`, must be global"
|
||||
let shortName := decl.updatePrefix .anonymous
|
||||
if let some (declName, _) := (envLinterExt.getState (← getEnv)).find? shortName then
|
||||
Elab.addConstInfo stx declName
|
||||
throwError
|
||||
"invalid attribute `builtin_env_linter`, linter `{shortName}` has already been declared"
|
||||
let isPublic := !isPrivateName decl; let isMeta := isMarkedMeta (← getEnv) decl
|
||||
unless isPublic && isMeta do
|
||||
throwError "invalid attribute `builtin_env_linter`, \
|
||||
declaration `{.ofConstName decl}` must be marked as `public` and `meta`\
|
||||
{if isPublic then " but is only marked `public`" else ""}\
|
||||
{if isMeta then " but is only marked `meta`" else ""}"
|
||||
let constInfo ← getConstInfo decl
|
||||
unless ← (isDefEq constInfo.type (mkConst ``EnvLinter)).run' do
|
||||
throwError "`{.ofConstName decl}` must have type `{.ofConstName ``EnvLinter}`, got \
|
||||
`{constInfo.type}`"
|
||||
modifyEnv fun env => envLinterExt.addEntry env (decl, dflt)
|
||||
}
|
||||
|
||||
/-- `@[builtin_nolint linterName]` omits the tagged declaration from being checked by
|
||||
the linter with name `linterName`. -/
|
||||
syntax (name := builtin_nolint) "builtin_nolint" (ppSpace ident)+ : attr
|
||||
|
||||
/-- Defines the user attribute `builtin_nolint` for skipping environment linters. -/
|
||||
builtin_initialize builtinNolintAttr : ParametricAttribute (Array Name) ←
|
||||
registerParametricAttribute {
|
||||
name := `builtin_nolint
|
||||
descr := "Do not report this declaration in any of the tests of `lake builtin-lint`"
|
||||
getParam := fun _ => fun
|
||||
| `(attr| builtin_nolint $[$ids]*) => ids.mapM fun id => withRef id <| do
|
||||
let shortName := id.getId.eraseMacroScopes
|
||||
let some (declName, _) := (envLinterExt.getState (← getEnv)).find? shortName
|
||||
| throwError "linter '{shortName}' not found"
|
||||
Elab.addConstInfo id declName
|
||||
recordExtraModUseFromDecl (isMeta := false) declName
|
||||
pure shortName
|
||||
| _ => Elab.throwUnsupportedSyntax
|
||||
}
|
||||
|
||||
/-- Returns true if `decl` should be checked
|
||||
using `linter`, i.e., if there is no `builtin_nolint` attribute. -/
|
||||
def shouldBeLinted [Monad m] [MonadEnv m] (linter : Name) (decl : Name) : m Bool :=
|
||||
return !((builtinNolintAttr.getParam? (← getEnv) decl).getD #[]).contains linter
|
||||
|
||||
end Lean.Linter.EnvLinter
|
||||
180
src/Lean/Linter/EnvLinter/Frontend.lean
Normal file
180
src/Lean/Linter/EnvLinter/Frontend.lean
Normal file
@@ -0,0 +1,180 @@
|
||||
/-
|
||||
Copyright (c) 2026 Lean FRO, LLC. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Wojciech Różowski
|
||||
|
||||
Copyright (c) 2020 Floris van Doorn. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Floris van Doorn, Robert Y. Lewis, Gabriel Ebner
|
||||
-/
|
||||
module
|
||||
|
||||
prelude
|
||||
public import Lean.Linter.EnvLinter.Basic
|
||||
import Lean.DeclarationRange
|
||||
import Lean.Util.Path
|
||||
import Lean.CoreM
|
||||
import Lean.Elab.Command
|
||||
|
||||
public section
|
||||
|
||||
open Lean Meta
|
||||
|
||||
namespace Lean.Linter.EnvLinter
|
||||
|
||||
/-- Verbosity for the linter output. -/
|
||||
inductive LintVerbosity
|
||||
/-- `low`: only print failing checks, print nothing on success. -/
|
||||
| low
|
||||
/-- `medium`: only print failing checks, print confirmation on success. -/
|
||||
| medium
|
||||
/-- `high`: print output of every check. -/
|
||||
| high
|
||||
deriving Inhabited, DecidableEq, Repr
|
||||
|
||||
/-- `getChecks clippy runOnly` produces a list of linters.
|
||||
`runOnly` is an optional list of names that should resolve to declarations with type
|
||||
`NamedEnvLinter`. If populated, only these linters are run (regardless of the default
|
||||
configuration). Otherwise, it uses all enabled linters in the environment tagged with
|
||||
`@[builtin_env_linter]`. If `clippy` is false, it only uses linters with `isDefault = true`. -/
|
||||
def getChecks (clippy : Bool) (runOnly : Option (List Name)) :
|
||||
CoreM (Array NamedEnvLinter) := do
|
||||
let mut result := #[]
|
||||
for (name, declName, isDefault) in envLinterExt.getState (← getEnv) do
|
||||
let shouldRun := match runOnly with
|
||||
| some only => only.contains name
|
||||
| none => clippy || isDefault
|
||||
if shouldRun then
|
||||
let linter ← getEnvLinter name declName
|
||||
result := result.binInsert (·.name.lt ·.name) linter
|
||||
pure result
|
||||
|
||||
|
||||
/--
|
||||
Runs all the specified linters on all the specified declarations in parallel,
|
||||
producing a list of results.
|
||||
-/
|
||||
def lintCore (decls : Array Name) (linters : Array NamedEnvLinter) :
|
||||
CoreM (Array (NamedEnvLinter × Std.HashMap Name MessageData)) := do
|
||||
let tasks : Array (NamedEnvLinter × Array (Name × Task (Except Exception <| Option MessageData))) ←
|
||||
linters.mapM fun linter => do
|
||||
let decls ← decls.filterM (shouldBeLinted linter.name)
|
||||
(linter, ·) <$> decls.mapM fun decl => (decl, ·) <$> do
|
||||
let act : MetaM (Option MessageData) := do
|
||||
linter.test decl
|
||||
EIO.asTask <| (← Core.wrapAsync (fun _ =>
|
||||
act |>.run' Elab.Command.mkMetaContext
|
||||
) (cancelTk? := none)) ()
|
||||
|
||||
let result ← tasks.mapM fun (linter, decls) => do
|
||||
let mut msgs : Std.HashMap Name MessageData := {}
|
||||
for (declName, msgTask) in decls do
|
||||
let msg? ← match msgTask.get with
|
||||
| Except.ok msg? => pure msg?
|
||||
| Except.error err => pure m!"LINTER FAILED:\n{err.toMessageData}"
|
||||
if let .some msg := msg? then
|
||||
msgs := msgs.insert declName msg
|
||||
pure (linter, msgs)
|
||||
return result
|
||||
|
||||
/-- Sorts a map with declaration keys as names by line number. -/
|
||||
def sortResults (results : Std.HashMap Name α) : CoreM <| Array (Name × α) := do
|
||||
let mut key : Std.HashMap Name Nat := {}
|
||||
for (n, _) in results.toArray do
|
||||
if let some range ← findDeclarationRanges? n then
|
||||
key := key.insert n <| range.range.pos.line
|
||||
pure $ results.toArray.qsort fun (a, _) (b, _) => key.getD a 0 < key.getD b 0
|
||||
|
||||
/-- Formats a linter warning as `#check` command with comment. -/
|
||||
def printWarning (declName : Name) (warning : MessageData) (useErrorFormat : Bool := false)
|
||||
(filePath : System.FilePath := default) : CoreM MessageData := do
|
||||
if useErrorFormat then
|
||||
if let some range ← findDeclarationRanges? declName then
|
||||
let msg ← addMessageContextPartial
|
||||
m!"{filePath}:{range.range.pos.line}:{range.range.pos.column + 1}: error: {
|
||||
← mkConstWithLevelParams declName} {warning}"
|
||||
return msg
|
||||
addMessageContextPartial m!"#check {← mkConstWithLevelParams declName} /- {warning} -/"
|
||||
|
||||
/-- Formats a map of linter warnings using `printWarning`, sorted by line number. -/
|
||||
def printWarnings (results : Std.HashMap Name MessageData) (filePath : System.FilePath := default)
|
||||
(useErrorFormat : Bool := false) : CoreM MessageData := do
|
||||
(MessageData.joinSep ·.toList Format.line) <$>
|
||||
(← sortResults results).mapM fun (declName, warning) =>
|
||||
printWarning declName warning (useErrorFormat := useErrorFormat) (filePath := filePath)
|
||||
|
||||
/--
|
||||
Formats a map of linter warnings grouped by filename with `-- filename` comments.
|
||||
-/
|
||||
def groupedByFilename (results : Std.HashMap Name MessageData) (useErrorFormat : Bool := false) :
|
||||
CoreM MessageData := do
|
||||
let sp ← if useErrorFormat then getSrcSearchPath else pure {}
|
||||
let grouped : Std.HashMap Name (System.FilePath × Std.HashMap Name MessageData) ←
|
||||
results.foldM (init := {}) fun grouped declName msg => do
|
||||
let mod ← findModuleOf? declName
|
||||
let mod := mod.getD (← getEnv).mainModule
|
||||
grouped.insert mod <$>
|
||||
match grouped[mod]? with
|
||||
| some (fp, msgs) => pure (fp, msgs.insert declName msg)
|
||||
| none => do
|
||||
let fp ← if useErrorFormat then
|
||||
pure <| (← sp.findWithExt "lean" mod).getD (modToFilePath "." mod "lean")
|
||||
else pure default
|
||||
pure (fp, .insert {} declName msg)
|
||||
let grouped' := grouped.toArray.qsort fun (a, _) (b, _) => toString a < toString b
|
||||
(MessageData.joinSep · (Format.line ++ Format.line)) <$>
|
||||
grouped'.toList.mapM fun (mod, fp, msgs) => do
|
||||
pure m!"-- {mod}\n{← printWarnings msgs (filePath := fp) (useErrorFormat := useErrorFormat)}"
|
||||
|
||||
/--
|
||||
Formats the linter results as Lean code with comments and `#check` commands.
|
||||
-/
|
||||
def formatLinterResults
|
||||
(results : Array (NamedEnvLinter × Std.HashMap Name MessageData))
|
||||
(decls : Array Name)
|
||||
(groupByFilename : Bool)
|
||||
(whereDesc : String) (runClippyLinters : Bool)
|
||||
(verbose : LintVerbosity) (numLinters : Nat) (useErrorFormat : Bool := false) :
|
||||
CoreM MessageData := do
|
||||
let formattedResults ← results.filterMapM fun (linter, results) => do
|
||||
if !results.isEmpty then
|
||||
let warnings ←
|
||||
if groupByFilename || useErrorFormat then
|
||||
groupedByFilename results (useErrorFormat := useErrorFormat)
|
||||
else
|
||||
printWarnings results
|
||||
pure $ some m!"/- The `{linter.name}` linter reports:\n{linter.errorsFound} -/\n{warnings}\n"
|
||||
else if verbose = LintVerbosity.high then
|
||||
pure $ some m!"/- OK: {linter.noErrorsFound} -/"
|
||||
else
|
||||
pure none
|
||||
let mut s := MessageData.joinSep formattedResults.toList Format.line
|
||||
let numAutoDecls := (← decls.filterM isAutoDecl).size
|
||||
let failed := results.map (·.2.size) |>.foldl (·+·) 0
|
||||
unless verbose matches LintVerbosity.low do
|
||||
s := m!"-- Found {failed} error{if failed == 1 then "" else "s"
|
||||
} in {decls.size - numAutoDecls} declarations (plus {
|
||||
numAutoDecls} automatically generated ones) {whereDesc
|
||||
} with {numLinters} linters\n\n{s}"
|
||||
unless runClippyLinters do s := m!"{s}-- (non-clippy linters skipped)\n"
|
||||
pure s
|
||||
|
||||
/-- Get the list of declarations in the current module. -/
|
||||
def getDeclsInCurrModule : CoreM (Array Name) := do
|
||||
pure $ (← getEnv).constants.map₂.foldl (init := #[]) fun r k _ => r.push k
|
||||
|
||||
/-- Get the list of all declarations in the environment. -/
|
||||
def getAllDecls : CoreM (Array Name) := do
|
||||
pure $ (← getEnv).constants.map₁.fold (init := ← getDeclsInCurrModule) fun r k _ => r.push k
|
||||
|
||||
/-- Get the list of all declarations in the specified package. -/
|
||||
def getDeclsInPackage (pkg : Name) : CoreM (Array Name) := do
|
||||
let env ← getEnv
|
||||
let mut decls ← getDeclsInCurrModule
|
||||
let modules := env.header.moduleNames.map (pkg.isPrefixOf ·)
|
||||
return env.constants.map₁.fold (init := decls) fun decls declName _ =>
|
||||
if modules[env.const2ModIdx[declName]?.get!]! then
|
||||
decls.push declName
|
||||
else decls
|
||||
|
||||
end Lean.Linter.EnvLinter
|
||||
@@ -30,7 +30,7 @@ of type
|
||||
α → List α → Sort (max 1 u_1) → Sort (max 1 u_1)
|
||||
```
|
||||
-/
|
||||
private def buildBelowMinorPremise (rlvl : Level) (motives : Array Expr) (minorType : Expr) : MetaM Expr :=
|
||||
def buildBelowMinorPremise (rlvl : Level) (motives : Array Expr) (minorType : Expr) : MetaM Expr :=
|
||||
forallTelescope minorType fun minor_args _ => do go #[] minor_args.toList
|
||||
where
|
||||
go (prods : Array Expr) : List Expr → MetaM Expr
|
||||
@@ -56,7 +56,7 @@ For example for the `List` type, it constructs,
|
||||
fun {a} {motive} t => List.rec PUnit (fun a_1 a a_ih => motive a ×' a_ih) t
|
||||
```
|
||||
-/
|
||||
private def mkBelowFromRec (recName : Name) (nParams : Nat)
|
||||
def mkBelowFromRec (recName : Name) (nParams : Nat)
|
||||
(belowName : Name) : MetaM Unit := do
|
||||
-- The construction follows the type of `ind.rec`
|
||||
let .recInfo recVal ← getConstInfo recName
|
||||
@@ -146,7 +146,7 @@ of type
|
||||
PProd (motive (head :: tail)) (PProd (PProd (motive tail) (List.below tail)) PUnit)
|
||||
```
|
||||
-/
|
||||
private def buildBRecOnMinorPremise (rlvl : Level) (motives : Array Expr)
|
||||
def buildBRecOnMinorPremise (rlvl : Level) (motives : Array Expr)
|
||||
(belows : Array Expr) (fs : Array Expr) (minorType : Expr) : MetaM Expr :=
|
||||
forallTelescope minorType fun minor_args minor_type => do
|
||||
let rec go (prods : Array Expr) : List Expr → MetaM Expr
|
||||
@@ -188,7 +188,7 @@ protected theorem List.brecOn.eq.{u} : ∀ {a : Type} {motive : List a → Sort
|
||||
(F_1 : (t : List a) → List.below t → motive t), List.brecOn t F_1 = F_1 t (List.brecOn.go t F_1).2
|
||||
```
|
||||
-/
|
||||
private def mkBRecOnFromRec (recName : Name) (nParams : Nat)
|
||||
def mkBRecOnFromRec (recName : Name) (nParams : Nat)
|
||||
(all : Array Name) (brecOnName : Name) : MetaM Unit := do
|
||||
let brecOnGoName := brecOnName.str "go"
|
||||
let brecOnEqName := brecOnName.str "eq"
|
||||
|
||||
@@ -15,7 +15,7 @@ import Lean.Meta.Transform
|
||||
namespace Lean.Meta
|
||||
|
||||
|
||||
private structure SparseCasesOnKey where
|
||||
structure SparseCasesOnKey where
|
||||
indName : Name
|
||||
ctors : Array Name
|
||||
-- When this is created in a private context and thus may contain private references, we must
|
||||
@@ -23,7 +23,7 @@ private structure SparseCasesOnKey where
|
||||
isPrivate : Bool
|
||||
deriving BEq, Hashable
|
||||
|
||||
private builtin_initialize sparseCasesOnCacheExt : EnvExtension (PHashMap SparseCasesOnKey Name) ←
|
||||
builtin_initialize sparseCasesOnCacheExt : EnvExtension (PHashMap SparseCasesOnKey Name) ←
|
||||
registerEnvExtension (pure {}) (asyncMode := .local) -- mere cache, keep it local
|
||||
|
||||
/-- Information necessary to recognize and split on sparse casesOn (in particular in MatchEqs) -/
|
||||
@@ -34,7 +34,7 @@ public structure SparseCasesOnInfo where
|
||||
insterestingCtors : Array Name
|
||||
deriving Inhabited
|
||||
|
||||
private builtin_initialize sparseCasesOnInfoExt : MapDeclarationExtension SparseCasesOnInfo ←
|
||||
builtin_initialize sparseCasesOnInfoExt : MapDeclarationExtension SparseCasesOnInfo ←
|
||||
mkMapDeclarationExtension (exportEntriesFn := fun env s =>
|
||||
let all := s.toArray
|
||||
-- Do not export for non-exposed defs at exported/server levels
|
||||
|
||||
@@ -83,7 +83,7 @@ where
|
||||
value := val
|
||||
})
|
||||
|
||||
private def isName (env : Environment) (n : Name) : Bool :=
|
||||
def isName (env : Environment) (n : Name) : Bool :=
|
||||
if let .str p "else_eq" := n then
|
||||
(getSparseCasesOnInfoCore env p).isSome
|
||||
else
|
||||
|
||||
@@ -16,7 +16,7 @@ def hinjSuffix := "hinj"
|
||||
public def mkCtorIdxHInjTheoremNameFor (indName : Name) : Name :=
|
||||
(mkCtorIdxName indName).str hinjSuffix
|
||||
|
||||
private partial def mkHInjectiveTheorem? (thmName : Name) (indVal : InductiveVal) : MetaM TheoremVal := do
|
||||
partial def mkHInjectiveTheorem? (thmName : Name) (indVal : InductiveVal) : MetaM TheoremVal := do
|
||||
let us := indVal.levelParams.map mkLevelParam
|
||||
let thmType ←
|
||||
forallBoundedTelescope indVal.type (indVal.numParams + indVal.numIndices) fun xs1 _ => do
|
||||
|
||||
@@ -40,7 +40,7 @@ namespace Lean.Meta.Match
|
||||
|
||||
This can be used to use the alternative of a match expression in its splitter.
|
||||
-/
|
||||
public partial def forallAltVarsTelescope (altType : Expr) (altInfo : AltParamInfo)
|
||||
partial def forallAltVarsTelescope (altType : Expr) (altInfo : AltParamInfo)
|
||||
(k : (patVars : Array Expr) → (args : Array Expr) → (mask : Array Bool) → (type : Expr) → MetaM α) : MetaM α := do
|
||||
assert! altInfo.numOverlaps = 0
|
||||
if altInfo.hasUnitThunk then
|
||||
@@ -104,7 +104,7 @@ where
|
||||
|
||||
This can be used to use the alternative of a match expression in its splitter.
|
||||
-/
|
||||
public partial def forallAltTelescope (altType : Expr) (altInfo : AltParamInfo) (numDiscrEqs : Nat)
|
||||
partial def forallAltTelescope (altType : Expr) (altInfo : AltParamInfo) (numDiscrEqs : Nat)
|
||||
(k : (ys : Array Expr) → (eqs : Array Expr) → (args : Array Expr) → (mask : Array Bool) → (type : Expr) → MetaM α)
|
||||
: MetaM α := do
|
||||
forallAltVarsTelescope altType altInfo fun ys args mask altType => do
|
||||
|
||||
@@ -21,7 +21,7 @@ We will eventually have to write more efficient proof automation for this module
|
||||
The new proof automation should exploit the structure of the generated goals and avoid general purpose tactics
|
||||
such as `contradiction`.
|
||||
-/
|
||||
private def _root_.Lean.MVarId.contradictionQuick (mvarId : MVarId) : MetaM Bool := do
|
||||
def _root_.Lean.MVarId.contradictionQuick (mvarId : MVarId) : MetaM Bool := do
|
||||
mvarId.withContext do
|
||||
let mut posMap : Std.HashMap Expr FVarId := {}
|
||||
let mut negMap : Std.HashMap Expr FVarId := {}
|
||||
|
||||
@@ -149,17 +149,15 @@ partial def mkSizeOfFn (recName : Name) (declName : Name): MetaM Unit := do
|
||||
trace[Meta.sizeOf] "declName: {declName}"
|
||||
trace[Meta.sizeOf] "type: {sizeOfType}"
|
||||
trace[Meta.sizeOf] "val: {sizeOfValue}"
|
||||
-- We expose the `sizeOf` functions so that the `spec` theorems can be publicly `defeq`
|
||||
withExporting do
|
||||
addDecl <| Declaration.defnDecl {
|
||||
name := declName
|
||||
levelParams := levelParams
|
||||
type := sizeOfType
|
||||
value := sizeOfValue
|
||||
safety := DefinitionSafety.safe
|
||||
hints := ReducibilityHints.abbrev
|
||||
}
|
||||
enableRealizationsForConst declName
|
||||
addDecl <| Declaration.defnDecl {
|
||||
name := declName
|
||||
levelParams := levelParams
|
||||
type := sizeOfType
|
||||
value := sizeOfValue
|
||||
safety := DefinitionSafety.safe
|
||||
hints := ReducibilityHints.abbrev
|
||||
}
|
||||
enableRealizationsForConst declName
|
||||
|
||||
/--
|
||||
Create `sizeOf` functions for all inductive datatypes in the mutual inductive declaration containing `typeName`
|
||||
@@ -453,23 +451,24 @@ private def mkSizeOfSpecTheorem (indInfo : InductiveVal) (sizeOfFns : Array Name
|
||||
let thmType ← mkForallFVars thmParams target
|
||||
trace[Meta.sizeOf] "sizeOf spec theorem name: {thmName}"
|
||||
trace[Meta.sizeOf] "sizeOf spec theorem type: {thmType}"
|
||||
let thmValue ← if indInfo.isNested then
|
||||
SizeOfSpecNested.main lhs rhs |>.run {
|
||||
indInfo, sizeOfFns, ctorName, params, localInsts, recMap
|
||||
}
|
||||
else
|
||||
mkEqRefl rhs
|
||||
let thmValue ← mkLambdaFVars thmParams thmValue
|
||||
trace[Meta.sizeOf] "sizeOf spec theorem value: {thmValue}"
|
||||
unless (← isDefEq (← inferType thmValue) thmType) do
|
||||
throwError "type mismatch"
|
||||
let thmValue ← withoutExporting do
|
||||
let thmValue ← if indInfo.isNested then
|
||||
SizeOfSpecNested.main lhs rhs |>.run {
|
||||
indInfo, sizeOfFns, ctorName, params, localInsts, recMap
|
||||
}
|
||||
else
|
||||
mkEqRefl rhs
|
||||
let thmValue ← mkLambdaFVars thmParams thmValue
|
||||
trace[Meta.sizeOf] "sizeOf spec theorem value: {thmValue}"
|
||||
unless (← isDefEq (← inferType thmValue) thmType) do
|
||||
throwError "type mismatch"
|
||||
pure thmValue
|
||||
addDecl <| Declaration.thmDecl {
|
||||
name := thmName
|
||||
levelParams := ctorInfo.levelParams
|
||||
type := thmType
|
||||
value := thmValue
|
||||
}
|
||||
inferDefEqAttr thmName
|
||||
simpAttr.add thmName default .global
|
||||
grindAttr.add thmName grindAttrStx .global
|
||||
|
||||
|
||||
@@ -16,7 +16,7 @@ import Lean.Meta.Tactic.Replace
|
||||
|
||||
namespace Lean.Meta
|
||||
|
||||
private def rewriteGoalUsingEq (goal : MVarId) (eq : Expr) (symm : Bool := false) : MetaM MVarId := do
|
||||
def rewriteGoalUsingEq (goal : MVarId) (eq : Expr) (symm : Bool := false) : MetaM MVarId := do
|
||||
let rewriteResult ← goal.rewrite (←goal.getType) eq symm
|
||||
goal.replaceTargetEq rewriteResult.eNew rewriteResult.eqProof
|
||||
|
||||
|
||||
@@ -383,7 +383,7 @@ When equal, uses `eq_self` (no kernel evaluation needed). When different, uses
|
||||
`mkStringLitNeProof` which finds the first differing character position and proves
|
||||
inequality via `congrArg (List.get?Internal · i)`.
|
||||
-/
|
||||
private def evalStringEq (a b : Expr) : SimpM Result := do
|
||||
def evalStringEq (a b : Expr) : SimpM Result := do
|
||||
let some va := getStringValue? a | return .rfl
|
||||
let some vb := getStringValue? b | return .rfl
|
||||
if va = vb then
|
||||
|
||||
@@ -172,7 +172,7 @@ inductive Result where
|
||||
Pre-computed `.rfl` results to avoid dynamic memory allocation.
|
||||
Each combination of `done` and `contextDependent` maps to a compile-time constant.
|
||||
-/
|
||||
public def mkRflResult (done : Bool := false) (contextDependent : Bool := false) : Result :=
|
||||
def mkRflResult (done : Bool := false) (contextDependent : Bool := false) : Result :=
|
||||
match done, contextDependent with
|
||||
| false, false => .rfl
|
||||
| false, true => .rfl false true
|
||||
@@ -180,15 +180,15 @@ public def mkRflResult (done : Bool := false) (contextDependent : Bool := false)
|
||||
| true, true => .rfl true true
|
||||
|
||||
/-- Like `mkRflResult` with `done := false`. -/
|
||||
public def mkRflResultCD (contextDependent : Bool) : Result :=
|
||||
def mkRflResultCD (contextDependent : Bool) : Result :=
|
||||
if contextDependent then .rfl false true else .rfl
|
||||
|
||||
/-- Returns `true` if this result depends on the local context (e.g., hypotheses). -/
|
||||
public abbrev Result.isContextDependent : Result → Bool
|
||||
abbrev Result.isContextDependent : Result → Bool
|
||||
| .rfl _ cd | .step _ _ _ cd => cd
|
||||
|
||||
/-- Marks a result as context-dependent. -/
|
||||
public def Result.withContextDependent : Result → Result
|
||||
def Result.withContextDependent : Result → Result
|
||||
| .rfl done _ => .rfl done true
|
||||
| .step e h done _ => .step e h done true
|
||||
|
||||
|
||||
@@ -66,7 +66,7 @@ This is used during pattern matching and structural definitional equality tests
|
||||
to identify arguments that can be skipped or handled specially
|
||||
(e.g., instance arguments can be synthesized, proof arguments can be inferred).
|
||||
-/
|
||||
public structure ProofInstArgInfo where
|
||||
structure ProofInstArgInfo where
|
||||
/-- `true` if this argument is a proof (its type is a `Prop`). -/
|
||||
isProof : Bool
|
||||
/-- `true` if this argument is a type class instance. -/
|
||||
@@ -78,7 +78,7 @@ Information about a function symbol. It stores which argument positions are proo
|
||||
enabling optimizations during pattern matching and structural definitional equality tests
|
||||
such as skipping proof arguments or deferring instance synthesis.
|
||||
-/
|
||||
public structure ProofInstInfo where
|
||||
structure ProofInstInfo where
|
||||
/-- Information about each argument position. -/
|
||||
argsInfo : Array ProofInstArgInfo
|
||||
deriving Inhabited
|
||||
|
||||
@@ -17,7 +17,7 @@ import Init.GetElem
|
||||
namespace Lean.Meta.Tactic.Cbv
|
||||
|
||||
/-- Extract elements from an array literal (`Array.mk` applied to a list literal). -/
|
||||
private def getArrayLitElems? (e : Expr) : Option <| Array Expr :=
|
||||
def getArrayLitElems? (e : Expr) : Option <| Array Expr :=
|
||||
match_expr e with
|
||||
| Array.mk _ as => getListLitElems as
|
||||
| _ => none
|
||||
|
||||
@@ -12,7 +12,7 @@ import Lean.Meta.Tactic.Util
|
||||
|
||||
namespace Lean.Meta
|
||||
|
||||
private partial def cleanupCore (mvarId : MVarId) (toPreserve : Array FVarId) (indirectProps : Bool) : MetaM MVarId := do
|
||||
partial def cleanupCore (mvarId : MVarId) (toPreserve : Array FVarId) (indirectProps : Bool) : MetaM MVarId := do
|
||||
mvarId.withContext do
|
||||
mvarId.checkNotAssigned `cleanup
|
||||
let used ← collectUsed |>.run' (false, {})
|
||||
|
||||
@@ -112,6 +112,25 @@ private def processInv (e inst a : Expr) : RingM Unit := do
|
||||
return ()
|
||||
pushNewFact <| mkApp3 (mkConst ``Grind.CommRing.inv_split [ring.u]) ring.type fieldInst a
|
||||
|
||||
/--
|
||||
For each new variable `x` in a ring with `PowIdentity α p`,
|
||||
push the equation `x ^ p = x` as a new fact into grind.
|
||||
-/
|
||||
private def processPowIdentityVars : RingM Unit := do
|
||||
let ring ← getCommRing
|
||||
let some (powIdentityInst, csInst, p) := ring.powIdentityInst? | return ()
|
||||
let startIdx := ring.powIdentityVarCount
|
||||
let vars := ring.toRing.vars
|
||||
if startIdx >= vars.size then return ()
|
||||
for i in [startIdx:vars.size] do
|
||||
let x := vars[i]!
|
||||
trace_goal[grind.ring] "PowIdentity: pushing x^{p} = x for {x}"
|
||||
-- Construct proof: @PowIdentity.pow_eq α csInst p powIdentityInst x
|
||||
let proof := mkApp5 (mkConst ``Grind.PowIdentity.pow_eq [ring.u])
|
||||
ring.type csInst (mkNatLit p) powIdentityInst x
|
||||
pushNewFact proof
|
||||
modifyCommRing fun s => { s with powIdentityVarCount := vars.size }
|
||||
|
||||
/-- Returns `true` if `e` is a term `a⁻¹`. -/
|
||||
private def internalizeInv (e : Expr) : GoalM Bool := do
|
||||
match_expr e with
|
||||
@@ -138,6 +157,7 @@ def internalize (e : Expr) (parent? : Option Expr) : GoalM Unit := do
|
||||
denote := s.denote.insert { expr := e } re
|
||||
denoteEntries := s.denoteEntries.push (e, re)
|
||||
}
|
||||
processPowIdentityVars
|
||||
else if let some semiringId ← getCommSemiringId? type then SemiringM.run semiringId do
|
||||
let some re ← sreify? e | return ()
|
||||
trace_goal[grind.ring.internalize] "semiring [{semiringId}]: {e}"
|
||||
|
||||
@@ -38,11 +38,13 @@ where
|
||||
let noZeroDivInst? ← getNoZeroDivInst? u type
|
||||
trace_goal[grind.ring] "NoNatZeroDivisors available: {noZeroDivInst?.isSome}"
|
||||
let fieldInst? ← synthInstance? <| mkApp (mkConst ``Grind.Field [u]) type
|
||||
let powIdentityInst? ← getPowIdentityInst? u type
|
||||
trace_goal[grind.ring] "PowIdentity available: {powIdentityInst?.isSome}"
|
||||
let semiringId? := none
|
||||
let id := (← get').rings.size
|
||||
let ring : CommRing := {
|
||||
id, semiringId?, type, u, semiringInst, ringInst, commSemiringInst,
|
||||
commRingInst, charInst?, noZeroDivInst?, fieldInst?,
|
||||
commRingInst, charInst?, noZeroDivInst?, fieldInst?, powIdentityInst?,
|
||||
}
|
||||
modify' fun s => { s with rings := s.rings.push ring }
|
||||
return some id
|
||||
|
||||
@@ -214,6 +214,8 @@ structure CommRing extends Ring where
|
||||
noZeroDivInst? : Option Expr
|
||||
/-- `Field` instance for `type` if available. -/
|
||||
fieldInst? : Option Expr
|
||||
/-- `PowIdentity` instance, the synthesized `CommSemiring` instance, and exponent `p` if available. -/
|
||||
powIdentityInst? : Option (Expr × Expr × Nat) := none
|
||||
/-- `denoteEntries` is `denote` as a `PArray` for deterministic traversal. -/
|
||||
denoteEntries : PArray (Expr × RingExpr) := {}
|
||||
/-- Next unique id for `EqCnstr`s. -/
|
||||
@@ -238,6 +240,8 @@ structure CommRing extends Ring where
|
||||
recheck : Bool := false
|
||||
/-- Inverse theorems that have been already asserted. -/
|
||||
invSet : PHashSet Expr := {}
|
||||
/-- Number of variables for which `PowIdentity` equations have been pushed. -/
|
||||
powIdentityVarCount : Nat := 0
|
||||
/--
|
||||
An equality of the form `c = 0`. It is used to simplify polynomial coefficients.
|
||||
-/
|
||||
|
||||
@@ -19,6 +19,20 @@ def getIsCharInst? (u : Level) (type : Expr) (semiringInst : Expr) : GoalM (Opti
|
||||
let some n ← evalNat? n | return none
|
||||
return some (charInst, n)
|
||||
|
||||
def getPowIdentityInst? (u : Level) (type : Expr) : GoalM (Option (Expr × Expr × Nat)) := do withNewMCtxDepth do
|
||||
-- We use a fresh metavar for `CommSemiring` (unlike `getIsCharInst?` which pins the semiring)
|
||||
-- because `PowIdentity` instances may be declared against a canonical `CommSemiring` instance
|
||||
-- that is not definitionally equal to `CommRing.toCommSemiring`. The synthesized `csInst` is
|
||||
-- stored and used in proof terms to ensure type-correctness.
|
||||
let csInst ← mkFreshExprMVar (mkApp (mkConst ``Grind.CommSemiring [u]) type)
|
||||
let p ← mkFreshExprMVar (mkConst ``Nat)
|
||||
let powIdentityType := mkApp3 (mkConst ``Grind.PowIdentity [u]) type csInst p
|
||||
let some inst ← synthInstance? powIdentityType | return none
|
||||
let csInst ← instantiateMVars csInst
|
||||
let p ← instantiateMVars p
|
||||
let some pVal ← evalNat? p | return none
|
||||
return some (inst, csInst, pVal)
|
||||
|
||||
def getNoZeroDivInst? (u : Level) (type : Expr) : GoalM (Option Expr) := do
|
||||
let natModuleType := mkApp (mkConst ``Grind.NatModule [u]) type
|
||||
let some natModuleInst ← synthInstance? natModuleType | return none
|
||||
|
||||
@@ -50,6 +50,18 @@ register_builtin_option debug.tactic.simp.checkDefEqAttr : Bool := {
|
||||
of the `defeq` attribute, and warn if it was. Note that this is a costly check."
|
||||
}
|
||||
|
||||
register_builtin_option warning.simp.varHead : Bool := {
|
||||
defValue := false
|
||||
descr := "If true, warns when the head symbol of the left-hand side of a `@[simp]` theorem \
|
||||
is a variable. Such lemmas are tried on every simp step, which can be slow."
|
||||
}
|
||||
|
||||
register_builtin_option warning.simp.otherHead : Bool := {
|
||||
defValue := true
|
||||
descr := "If true, warns when the left-hand side of a `@[simp]` theorem is headed by a \
|
||||
`.other` key in the discrimination tree (e.g. a lambda expression). Such lemmas can cause slowdowns."
|
||||
}
|
||||
|
||||
/--
|
||||
An `Origin` is an identifier for simp theorems which indicates roughly
|
||||
what action the user took which lead to this theorem existing in the simp set.
|
||||
@@ -359,12 +371,27 @@ private def checkTypeIsProp (type : Expr) : MetaM Unit :=
|
||||
unless (← isProp type) do
|
||||
throwError "Invalid simp theorem: Expected a proposition, but found{indentExpr type}"
|
||||
|
||||
private def mkSimpTheoremKeys (type : Expr) (noIndexAtArgs : Bool) : MetaM (Array SimpTheoremKey × Bool) := do
|
||||
private def mkSimpTheoremKeys (type : Expr) (noIndexAtArgs : Bool) (checkLhs : Bool := false) : MetaM (Array SimpTheoremKey × Bool) := do
|
||||
withNewMCtxDepth do
|
||||
let (_, _, type) ← forallMetaTelescopeReducing type
|
||||
let type ← whnfR type
|
||||
match type.eq? with
|
||||
| some (_, lhs, rhs) => pure (← DiscrTree.mkPath lhs noIndexAtArgs, ← isPerm lhs rhs)
|
||||
| some (_, lhs, rhs) =>
|
||||
let keys ← DiscrTree.mkPath lhs noIndexAtArgs
|
||||
if checkLhs then
|
||||
if warning.simp.varHead.get (← getOptions) && keys[0]? == some .star then
|
||||
logWarning m!"Left-hand side of simp theorem has a variable as head symbol. \
|
||||
This means the theorem will be tried on every simp step, which can be expensive. \
|
||||
This may be acceptable for `local` or `scoped` simp lemmas.\n\
|
||||
Use `set_option warning.simp.varHead false` to disable this warning."
|
||||
if warning.simp.otherHead.get (← getOptions) && keys[0]? == some .other then
|
||||
logWarning m!"Left-hand side of simp theorem is headed by a `.other` key in the \
|
||||
discrimination tree (e.g. because it is a lambda expression). \
|
||||
This theorem will be tried against all expressions that also have a `.other` key as head, \
|
||||
which can cause slowdowns. \
|
||||
This may be acceptable for `local` or `scoped` simp lemmas.\n\
|
||||
Use `set_option warning.simp.otherHead false` to disable this warning."
|
||||
pure (keys, ← isPerm lhs rhs)
|
||||
| none => throwError "Unexpected kind of simp theorem{indentExpr type}"
|
||||
|
||||
register_builtin_option simp.rfl.checkTransparency: Bool := {
|
||||
@@ -373,19 +400,19 @@ register_builtin_option simp.rfl.checkTransparency: Bool := {
|
||||
}
|
||||
|
||||
private def mkSimpTheoremCore (origin : Origin) (e : Expr) (levelParams : Array Name) (proof : Expr)
|
||||
(post : Bool) (prio : Nat) (noIndexAtArgs : Bool) : MetaM SimpTheorem := do
|
||||
(post : Bool) (prio : Nat) (noIndexAtArgs : Bool) (checkLhs : Bool := false): MetaM SimpTheorem := do
|
||||
assert! origin != .fvar ⟨.anonymous⟩
|
||||
let type ← instantiateMVars (← inferType e)
|
||||
let (keys, perm) ← mkSimpTheoremKeys type noIndexAtArgs
|
||||
let (keys, perm) ← mkSimpTheoremKeys type noIndexAtArgs checkLhs
|
||||
let rfl ← isRflProof proof
|
||||
if rfl && simp.rfl.checkTransparency.get (← getOptions) then
|
||||
forallTelescopeReducing type fun _ type => do
|
||||
let checkDefEq (lhs rhs : Expr) := do
|
||||
unless (← withTransparency .instances <| isDefEq lhs rhs) do
|
||||
logWarning m!"`{origin.key}` is a `rfl` simp theorem, but its left-hand side{indentExpr lhs}\n\
|
||||
logWarning m!"`{origin.key}` is a `[defeq]` simp theorem, but its left-hand side{indentExpr lhs}\n\
|
||||
is not definitionally equal to the right-hand side{indentExpr rhs}\n\
|
||||
at `.instances` transparency. Possible solutions:\n\
|
||||
1- use `id rfl` as the proof\n\
|
||||
1- use `(rfl)` as the proof\n\
|
||||
2- mark constants occurring in the lhs and rhs as `[implicit_reducible]`"
|
||||
match_expr type with
|
||||
| Eq _ lhs rhs => checkDefEq lhs rhs
|
||||
@@ -399,7 +426,7 @@ Creates a `SimpTheorem` from a global theorem.
|
||||
Because some theorems lead to multiple `SimpTheorems` (in particular conjunctions), returns an array.
|
||||
-/
|
||||
def mkSimpTheoremFromConst (declName : Name) (post := true) (inv := false)
|
||||
(prio : Nat := eval_prio default) : MetaM (Array SimpTheorem) := do
|
||||
(prio : Nat := eval_prio default) (checkLhs : Bool := false) : MetaM (Array SimpTheorem) := do
|
||||
let cinfo ← getConstVal declName
|
||||
let us := cinfo.levelParams.map mkLevelParam
|
||||
let origin := .decl declName post inv
|
||||
@@ -413,10 +440,10 @@ def mkSimpTheoremFromConst (declName : Name) (post := true) (inv := false)
|
||||
let auxName ← mkAuxLemma (kind? := `_simp) cinfo.levelParams type val (inferRfl := true)
|
||||
(forceExpose := true) -- These kinds of theorems are small and `to_additive` may need to
|
||||
-- unfold them.
|
||||
r := r.push <| (← do mkSimpTheoremCore origin (mkConst auxName us) #[] (mkConst auxName) post prio (noIndexAtArgs := false))
|
||||
r := r.push <| (← do mkSimpTheoremCore origin (mkConst auxName us) #[] (mkConst auxName) post prio (noIndexAtArgs := false) (checkLhs := checkLhs))
|
||||
return r
|
||||
else
|
||||
return #[← withoutExporting do mkSimpTheoremCore origin (mkConst declName us) #[] (mkConst declName) post prio (noIndexAtArgs := false)]
|
||||
return #[← withoutExporting do mkSimpTheoremCore origin (mkConst declName us) #[] (mkConst declName) post prio (noIndexAtArgs := false) (checkLhs := checkLhs)]
|
||||
|
||||
def SimpTheorem.getValue (simpThm : SimpTheorem) : MetaM Expr := do
|
||||
if simpThm.proof.isConst && simpThm.levelParams.isEmpty then
|
||||
@@ -670,7 +697,7 @@ def SimpExtension.getTheorems (ext : SimpExtension) : CoreM SimpTheorems :=
|
||||
Adds a simp theorem to a simp extension
|
||||
-/
|
||||
def addSimpTheorem (ext : SimpExtension) (declName : Name) (post : Bool) (inv : Bool) (attrKind : AttributeKind) (prio : Nat) : MetaM Unit := do
|
||||
let simpThms ← withExporting (isExporting := attrKind != .local && !isPrivateName declName) do mkSimpTheoremFromConst declName post inv prio
|
||||
let simpThms ← withExporting (isExporting := attrKind != .local && !isPrivateName declName) do mkSimpTheoremFromConst declName post inv prio (checkLhs := true)
|
||||
for simpThm in simpThms do
|
||||
ext.add (SimpEntry.thm simpThm) attrKind
|
||||
|
||||
|
||||
@@ -9,8 +9,8 @@ prelude
|
||||
public import Lean.Meta.Closure
|
||||
public import Lean.Meta.SynthInstance
|
||||
public import Lean.Meta.CtorRecognizer
|
||||
|
||||
public section
|
||||
public import Lean.Meta.AppBuilder
|
||||
import Lean.Structure
|
||||
|
||||
/-!
|
||||
# Instance Wrapping
|
||||
@@ -25,22 +25,30 @@ Given an instance `i : I` and expected type `I'` (where `I'` must be mvar-free),
|
||||
`wrapInstance` constructs a result instance as follows, executing all steps at
|
||||
`instances` transparency:
|
||||
|
||||
1. If `I'` is not a class, return `i` unchanged.
|
||||
1. If `I'` is not a class application, return `i` unchanged.
|
||||
2. If `I'` is a proposition, wrap `i` in an auxiliary theorem of type `I'` and return it
|
||||
(controlled by `backward.inferInstanceAs.wrap.instances`).
|
||||
3. Reduce `i` to whnf.
|
||||
4. If `i` is not a constructor application: if the type of `i` is already defeq to `I'`,
|
||||
4. If `i` is not a constructor application: if `I` is already defeq to `I'`,
|
||||
return `i`; otherwise wrap it in an auxiliary definition of type `I'` and return it
|
||||
(controlled by `backward.inferInstanceAs.wrap.instances`).
|
||||
5. Otherwise, for `i = ctor a₁ ... aₙ` with `ctor : C ?p₁ ... ?pₙ`:
|
||||
- Unify `C ?p₁ ... ?pₙ` with `I'`.
|
||||
- Return a new application `ctor a₁' ... aₙ' : I'` where each `aᵢ'` is constructed as:
|
||||
5. Otherwise, if `i` is an application of `ctor` of class `C`:
|
||||
- Unify the conclusion of the type of `ctor` with `I'` to obtain adjusted field type `Fᵢ'` for
|
||||
each field.
|
||||
- Return a new application `ctor ... : I'` where the fields are adjusted as follows:
|
||||
- If the field type is a proposition: assign directly if types are defeq, otherwise
|
||||
wrap in an auxiliary theorem.
|
||||
- If the field type is a class: first try to reuse an existing synthesized instance
|
||||
for the target type (controlled by `backward.inferInstanceAs.wrap.reuseSubInstances`);
|
||||
if that fails, recurse with source instance `aᵢ` and expected type `?pᵢ`.
|
||||
- Otherwise (data field): assign directly if types are defeq, otherwise wrap in an
|
||||
- If the field is a parent field (subobject) `p : P`: first try to reuse an existing
|
||||
instance that can be synthesized for `P` (controlled by
|
||||
`backward.inferInstanceAs.wrap.reuseSubInstances`) in order to preserve defeqs; if that
|
||||
fails, recurse.
|
||||
- If it is a field of a flattened parent class `C'` and
|
||||
`backward.inferInstanceAs.wrap.reuseSubInstances` is true, try synthesizing an instance of
|
||||
`C'` for `I'` and if successful, use the corresponding projection of the found instance in
|
||||
order to preserve defeqs; otherwise, continue.
|
||||
- Specifically, construct the chain of base projections from `C` to `C'` applied to `_ : I'`
|
||||
and infer its type to obtain an appropriate application of `C'` for the instance search.
|
||||
- Otherwise (non-inherited data field): assign directly if types are defeq, otherwise wrap in an
|
||||
auxiliary definition to fix the type (controlled by `backward.inferInstanceAs.wrap.data`).
|
||||
|
||||
## Options
|
||||
@@ -56,48 +64,62 @@ Given an instance `i : I` and expected type `I'` (where `I'` must be mvar-free),
|
||||
|
||||
namespace Lean.Meta
|
||||
|
||||
register_builtin_option backward.inferInstanceAs.wrap : Bool := {
|
||||
public register_builtin_option backward.inferInstanceAs.wrap : Bool := {
|
||||
defValue := true
|
||||
descr := "wrap instance bodies in `inferInstanceAs` and the default `deriving` handler"
|
||||
}
|
||||
|
||||
register_builtin_option backward.inferInstanceAs.wrap.reuseSubInstances : Bool := {
|
||||
public register_builtin_option backward.inferInstanceAs.wrap.reuseSubInstances : Bool := {
|
||||
defValue := true
|
||||
descr := "when recursing into sub-instances, reuse existing instances for the target type instead of re-wrapping them, which can be important to avoid non-defeq instance diamonds"
|
||||
}
|
||||
|
||||
register_builtin_option backward.inferInstanceAs.wrap.instances : Bool := {
|
||||
public register_builtin_option backward.inferInstanceAs.wrap.instances : Bool := {
|
||||
defValue := true
|
||||
descr := "wrap non-reducible instances in auxiliary definitions to fix their types"
|
||||
}
|
||||
|
||||
register_builtin_option backward.inferInstanceAs.wrap.data : Bool := {
|
||||
public register_builtin_option backward.inferInstanceAs.wrap.data : Bool := {
|
||||
defValue := true
|
||||
descr := "wrap data fields in auxiliary definitions to fix their types"
|
||||
}
|
||||
|
||||
builtin_initialize registerTraceClass `Meta.wrapInstance
|
||||
|
||||
/--
|
||||
Rebuild a type application with fresh synthetic metavariables for instance-implicit arguments.
|
||||
Non-instance-implicit arguments are assigned from the original application's arguments.
|
||||
If the function is over-applied, extra arguments are preserved.
|
||||
-/
|
||||
def abstractInstImplicitArgs (type : Expr) : MetaM Expr := do
|
||||
let fn := type.getAppFn
|
||||
let args := type.getAppArgs
|
||||
let (mvars, bis, _) ← forallMetaTelescope (← inferType fn)
|
||||
for i in [:mvars.size] do
|
||||
unless bis[i]!.isInstImplicit do
|
||||
mvars[i]!.mvarId!.assign args[i]!
|
||||
let args := mvars ++ args.drop mvars.size
|
||||
instantiateMVars (mkAppN fn args)
|
||||
open Meta
|
||||
|
||||
partial def getFieldOrigin (structName field : Name) : MetaM (Name × StructureFieldInfo) := 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 (structName, fi)
|
||||
|
||||
/-- Projects application of a structure type to corresponding application of a parent structure. -/
|
||||
def getParentStructType? (structName parentStructName : Name) (structType : Expr) : MetaM (Option Expr) := OptionT.run do
|
||||
let env ← getEnv
|
||||
let some path := getPathToBaseStructure? env parentStructName structName | failure
|
||||
withLocalDeclD `self structType fun self => do
|
||||
let proj ← path.foldlM (init := self) fun e projFn => do
|
||||
let ty ← whnf (← inferType e)
|
||||
let .const _ us := ty.getAppFn
|
||||
| trace[Meta.wrapInstance] "could not reduce type `{ty}`"
|
||||
failure
|
||||
let params := ty.getAppArgs
|
||||
pure <| mkApp (mkAppN (.const projFn us) params) e
|
||||
let projTy ← whnf <| ← inferType proj
|
||||
if projTy.containsFVar self.fvarId! then
|
||||
trace[Meta.wrapInstance] "parent type depends on instance fields{indentExpr projTy}"
|
||||
failure
|
||||
return projTy
|
||||
|
||||
/--
|
||||
Wrap an instance value so its type matches the expected type exactly.
|
||||
See the module docstring for the full algorithm specification.
|
||||
-/
|
||||
partial def wrapInstance (inst expectedType : Expr) (compile : Bool := true)
|
||||
public partial def wrapInstance (inst expectedType : Expr) (compile : Bool := true)
|
||||
(logCompileErrors : Bool := true) (isMeta : Bool := false) : MetaM Expr := withTransparency .instances do
|
||||
withTraceNode `Meta.wrapInstance
|
||||
(fun _ => return m!"type: {expectedType}") do
|
||||
@@ -112,8 +134,7 @@ partial def wrapInstance (inst expectedType : Expr) (compile : Bool := true)
|
||||
return inst
|
||||
|
||||
-- Try to reduce it to a constructor.
|
||||
let inst ← whnf inst
|
||||
inst.withApp fun f args => do
|
||||
(← whnf inst).withApp fun f args => do
|
||||
let some (.ctorInfo ci) ← f.constName?.mapM getConstInfo
|
||||
| do
|
||||
trace[Meta.wrapInstance] "did not reduce to constructor application, returning/wrapping as is: {inst}"
|
||||
@@ -156,8 +177,10 @@ partial def wrapInstance (inst expectedType : Expr) (compile : Bool := true)
|
||||
else
|
||||
trace[Meta.wrapInstance] "proof field {i} does not have expected type {argExpectedType} but {argType}, wrapping in auxiliary theorem: {arg}"
|
||||
mvarId.assign (← mkAuxTheorem argExpectedType arg (zetaDelta := true))
|
||||
continue
|
||||
|
||||
-- Recurse into instance arguments of the constructor
|
||||
else if (← isClass? argExpectedType).isSome then
|
||||
if (← isClass? argExpectedType).isSome then
|
||||
if backward.inferInstanceAs.wrap.reuseSubInstances.get (← getOptions) then
|
||||
-- Reuse existing instance for the target type if any. This is especially important when recursing
|
||||
-- as it guarantees subinstances of overlapping instances are defeq under more than just
|
||||
@@ -171,22 +194,35 @@ partial def wrapInstance (inst expectedType : Expr) (compile : Bool := true)
|
||||
|
||||
mvarId.assign (← wrapInstance arg argExpectedType (compile := compile)
|
||||
(logCompileErrors := logCompileErrors) (isMeta := isMeta))
|
||||
else
|
||||
-- For data fields, assign directly or wrap in aux def to fix types.
|
||||
if backward.inferInstanceAs.wrap.data.get (← getOptions) then
|
||||
let argType ← inferType arg
|
||||
if ← isDefEq argExpectedType argType then
|
||||
mvarId.assign arg
|
||||
else
|
||||
let name ← mkAuxDeclName
|
||||
mvarId.assign (← mkAuxDefinition name argExpectedType arg (compile := false))
|
||||
setInlineAttribute name
|
||||
if isMeta then modifyEnv (markMeta · name)
|
||||
if compile then
|
||||
compileDecls (logErrors := logCompileErrors) #[name]
|
||||
enableRealizationsForConst name
|
||||
else
|
||||
mvarId.assign arg
|
||||
return mkAppN f (← mvars.mapM instantiateMVars)
|
||||
continue
|
||||
|
||||
end Lean.Meta
|
||||
if backward.inferInstanceAs.wrap.reuseSubInstances.get (← getOptions) then
|
||||
let (baseClassName, fieldInfo) ← getFieldOrigin className mvarDecl.userName
|
||||
if baseClassName != className then
|
||||
trace[Meta.wrapInstance] "found inherited field `{mvarDecl.userName}` from parent `{baseClassName}`"
|
||||
if let some baseClassType ← getParentStructType? className baseClassName expectedType then
|
||||
try
|
||||
if let .some existingBaseClassInst ← trySynthInstance baseClassType then
|
||||
trace[Meta.wrapInstance] "using projection of existing instance `{existingBaseClassInst}`"
|
||||
mvarId.assign (← mkProjection existingBaseClassInst fieldInfo.fieldName)
|
||||
continue
|
||||
trace[Meta.wrapInstance] "did not find existing instance for `{baseClassName}`"
|
||||
catch e =>
|
||||
trace[Meta.wrapInstance] "error when attempting to reuse existing instance for `{baseClassName}`: {e.toMessageData}"
|
||||
|
||||
-- For data fields, assign directly or wrap in aux def to fix types.
|
||||
if backward.inferInstanceAs.wrap.data.get (← getOptions) then
|
||||
let argType ← inferType arg
|
||||
if ← isDefEq argExpectedType argType then
|
||||
mvarId.assign arg
|
||||
else
|
||||
let name ← mkAuxDeclName
|
||||
mvarId.assign (← mkAuxDefinition name argExpectedType arg (compile := false))
|
||||
setInlineAttribute name
|
||||
if isMeta then modifyEnv (markMeta · name)
|
||||
if compile then
|
||||
compileDecls (logErrors := logCompileErrors) #[name]
|
||||
enableRealizationsForConst name
|
||||
else
|
||||
mvarId.assign arg
|
||||
return mkAppN f (← mvars.mapM instantiateMVars)
|
||||
|
||||
@@ -1115,11 +1115,6 @@ def symbolNoAntiquot (sym : String) : Parser :=
|
||||
{ info := symbolInfo sym
|
||||
fn := symbolFn sym }
|
||||
|
||||
def checkTailNoWs (prev : Syntax) : Bool :=
|
||||
match prev.getTailInfo with
|
||||
| .original _ _ trailing _ => trailing.stopPos == trailing.startPos
|
||||
| _ => false
|
||||
|
||||
/-- Check if the following token is the symbol _or_ identifier `sym`. Useful for
|
||||
parsing local tokens that have not been added to the token table (but may have
|
||||
been so by some unrelated code).
|
||||
@@ -1168,13 +1163,18 @@ partial def strAux (sym : String) (errorMsg : String) (j : String.Pos.Raw) :Pars
|
||||
else parse (j.next' sym h₁) c (s.next' c i h₂)
|
||||
parse j
|
||||
|
||||
private def pickNonNone (stack : SyntaxStack) : Syntax :=
|
||||
match stack.toSubarray.findRev? fun stx => !stx.isNone with
|
||||
| none => Syntax.missing
|
||||
| some stx => stx
|
||||
|
||||
def checkTailWs (prev : Syntax) : Bool :=
|
||||
match prev.getTailInfo with
|
||||
| .original _ _ trailing _ => trailing.stopPos > trailing.startPos
|
||||
| _ => false
|
||||
|
||||
def checkWsBeforeFn (errorMsg : String) : ParserFn := fun _ s =>
|
||||
let prev := s.stxStack.back
|
||||
let prev := pickNonNone s.stxStack
|
||||
if checkTailWs prev then s else s.mkError errorMsg
|
||||
|
||||
/-- The `ws` parser requires that there is some whitespace at this location.
|
||||
@@ -1202,10 +1202,10 @@ This parser has arity 0 - it does not capture anything. -/
|
||||
info := epsilonInfo
|
||||
fn := checkLinebreakBeforeFn errorMsg
|
||||
|
||||
private def pickNonNone (stack : SyntaxStack) : Syntax :=
|
||||
match stack.toSubarray.findRev? fun stx => !stx.isNone with
|
||||
| none => Syntax.missing
|
||||
| some stx => stx
|
||||
def checkTailNoWs (prev : Syntax) : Bool :=
|
||||
match prev.getTailInfo with
|
||||
| .original _ _ trailing _ => trailing.stopPos == trailing.startPos
|
||||
| _ => false
|
||||
|
||||
def checkNoWsBeforeFn (errorMsg : String) : ParserFn := fun _ s =>
|
||||
let prev := pickNonNone s.stxStack
|
||||
|
||||
@@ -122,7 +122,9 @@ def declModifiers (inline : Bool) := leading_parser
|
||||
/-- `declId` matches `foo` or `foo.{u,v}`: an identifier possibly followed by a list of universe names -/
|
||||
-- @[builtin_doc] -- FIXME: suppress the hover
|
||||
def declId := leading_parser
|
||||
ident >> optional (".{" >> sepBy1 (recover ident (skipUntil (fun c => c.isWhitespace || c ∈ [',', '}']))) ", " >> "}")
|
||||
ident >>
|
||||
optional (checkNoWsBefore "no space before '.{'" >> ".{" >>
|
||||
sepBy1 (recover ident (skipUntil (fun c => c.isWhitespace || c ∈ [',', '}']))) ", " >> "}")
|
||||
/-- `declSig` matches the signature of a declaration with required type: a list of binders and then `: type` -/
|
||||
-- @[builtin_doc] -- FIXME: suppress the hover
|
||||
def declSig := leading_parser
|
||||
@@ -340,10 +342,11 @@ namespace InternalSyntax
|
||||
This command is for internal use only. It is intended for macros that implicitly introduce new
|
||||
scopes, such as `expandInCmd` and `expandNamespacedDeclaration`. It allows local attributes to remain
|
||||
accessible beyond those implicit scopes, even though they would normally be hidden from the user.
|
||||
The numeric argument specifies how many scope levels to mark as non-delimiting.
|
||||
-/
|
||||
scoped syntax (name := end_local_scope) "end_local_scope" : command
|
||||
scoped syntax (name := end_local_scope) "end_local_scope" num : command
|
||||
|
||||
def endLocalScopeSyntax : Command := Unhygienic.run `(end_local_scope)
|
||||
def endLocalScopeSyntax (depth : Nat) : Command := Unhygienic.run `(end_local_scope $(Syntax.mkNumLit (toString depth)))
|
||||
end InternalSyntax
|
||||
|
||||
/-- Declares one or more typed variables, or modifies whether already-declared variables are
|
||||
|
||||
@@ -127,7 +127,10 @@ private def consumeInput (inputCtx : InputContext) (pmctx : ParserModuleContext)
|
||||
| none => s.pos
|
||||
|
||||
def topLevelCommandParserFn : ParserFn :=
|
||||
commandParser.fn
|
||||
-- set position to enforce appropriate indentation of applications etc.
|
||||
-- We don't do it for nested commands such as in quotations where
|
||||
-- formatting might be less rigid.
|
||||
(withPosition commandParser).fn
|
||||
|
||||
partial def parseCommand (inputCtx : InputContext) (pmctx : ParserModuleContext) (mps : ModuleParserState) (messages : MessageLog) : Syntax × ModuleParserState × MessageLog := Id.run do
|
||||
let mut pos := mps.pos
|
||||
|
||||
@@ -50,17 +50,17 @@ def versoCommentBodyFn : ParserFn := fun c s =>
|
||||
rawFn (Doc.Parser.ignoreFn <| chFn '-' >> chFn '/') (trailingWs := true) c s
|
||||
else s
|
||||
|
||||
public def versoCommentBody : Parser where
|
||||
def versoCommentBody : Parser where
|
||||
fn := fun c s => nodeFn `Lean.Parser.Command.versoCommentBody versoCommentBodyFn c s
|
||||
|
||||
|
||||
@[combinator_parenthesizer versoCommentBody, expose]
|
||||
public def versoCommentBody.parenthesizer := PrettyPrinter.Parenthesizer.visitToken
|
||||
def versoCommentBody.parenthesizer := PrettyPrinter.Parenthesizer.visitToken
|
||||
|
||||
open PrettyPrinter Formatter in
|
||||
open Syntax.MonadTraverser in
|
||||
@[combinator_formatter versoCommentBody, expose]
|
||||
public def versoCommentBody.formatter : PrettyPrinter.Formatter := do
|
||||
def versoCommentBody.formatter : PrettyPrinter.Formatter := do
|
||||
visitArgs $ do
|
||||
visitAtom `«-/»
|
||||
goLeft
|
||||
@@ -889,14 +889,21 @@ def isIdent (stx : Syntax) : Bool :=
|
||||
-- antiquotations should also be allowed where an identifier is expected
|
||||
stx.isAntiquot || stx.isIdent
|
||||
|
||||
def isIdentOrDotIdent (stx : Syntax) : Bool :=
|
||||
isIdent stx || stx.isOfKind ``dotIdent
|
||||
/-- Predicate for what `explicitUniv` can follow. It is only meant to be used on an identifier
|
||||
that becomes the head constant of an application. -/
|
||||
def isIdentOrDotIdentOrProj (stx : Syntax) : Bool :=
|
||||
isIdent stx || stx.isOfKind ``dotIdent || stx.isOfKind ``proj
|
||||
|
||||
/-- `x.{u, ...}` explicitly specifies the universes `u, ...` of the constant `x`. -/
|
||||
@[builtin_term_parser] def explicitUniv : TrailingParser := trailing_parser
|
||||
checkStackTop isIdentOrDotIdent "expected preceding identifier" >>
|
||||
/-- Syntax for `.{u, ...}` itself. Generally the `explicitUniv` trailing parser suffices.
|
||||
However, for `e |>.x.{u} a1 a2 a3` notation we need to be able to express explicit universes in the
|
||||
middle of the syntax. -/
|
||||
def explicitUnivSuffix : Parser :=
|
||||
checkNoWsBefore "no space before '.{'" >> ".{" >>
|
||||
sepBy1 levelParser ", " >> "}"
|
||||
/-- `x.{u, ...}` explicitly specifies the universes `u, ...` of the constant `x`. -/
|
||||
@[builtin_term_parser] def explicitUniv : TrailingParser := trailing_parser
|
||||
checkStackTop isIdentOrDotIdentOrProj "expected preceding identifier" >>
|
||||
explicitUnivSuffix
|
||||
/-- `x@e` or `x@h:e` matches the pattern `e` and binds its value to the identifier `x`.
|
||||
If present, the identifier `h` is bound to a proof of `x = e`. -/
|
||||
@[builtin_term_parser] def namedPattern : TrailingParser := trailing_parser
|
||||
@@ -909,7 +916,7 @@ If present, the identifier `h` is bound to a proof of `x = e`. -/
|
||||
It is especially useful for avoiding parentheses with repeated applications.
|
||||
-/
|
||||
@[builtin_term_parser] def pipeProj := trailing_parser:minPrec
|
||||
" |>." >> checkNoWsBefore >> (fieldIdx <|> rawIdent) >> many argument
|
||||
" |>." >> checkNoWsBefore >> (fieldIdx <|> rawIdent) >> optional explicitUnivSuffix >> many argument
|
||||
@[builtin_term_parser] def pipeCompletion := trailing_parser:minPrec
|
||||
" |>."
|
||||
|
||||
|
||||
@@ -84,11 +84,12 @@ Delimiter-free indentation is determined by the *first* tactic of the sequence.
|
||||
tacticSeqBracketed <|> tacticSeq1Indented
|
||||
|
||||
/-- Same as [`tacticSeq`] but requires delimiter-free tactic sequence to have strict indentation.
|
||||
The strict indentation requirement only apply to *nested* `by`s, as top-level `by`s do not have a
|
||||
position set. -/
|
||||
Falls back to an empty tactic sequence when no appropriately indented content follows, producing
|
||||
an elaboration error (unsolved goals) rather than a parse error. -/
|
||||
@[builtin_doc, run_builtin_parser_attribute_hooks]
|
||||
def tacticSeqIndentGt := withAntiquot (mkAntiquot "tacticSeq" ``tacticSeq) <| node ``tacticSeq <|
|
||||
tacticSeqBracketed <|> (checkColGt "indented tactic sequence" >> tacticSeq1Indented)
|
||||
tacticSeqBracketed <|> (checkColGt "indented tactic sequence" >> tacticSeq1Indented) <|>
|
||||
node ``tacticSeq1Indented pushNone
|
||||
|
||||
/- Raw sequence for quotation and grouping -/
|
||||
@[run_builtin_parser_attribute_hooks]
|
||||
|
||||
@@ -110,9 +110,7 @@ partial def compileParserExpr (e : Expr) : MetaM Expr := do
|
||||
}
|
||||
-- usually `meta` is inferred during compilation for auxiliary definitions, but as
|
||||
-- `ctx.combinatorAttr` may enforce correct use of the modifier, infer now.
|
||||
if isMarkedMeta (← getEnv) c then
|
||||
modifyEnv (markMeta · c')
|
||||
addAndCompile decl
|
||||
addAndCompile decl (markMeta := isMarkedMeta (← getEnv) c)
|
||||
modifyEnv (ctx.combinatorAttr.setDeclFor · c c')
|
||||
if cinfo.type.isConst then
|
||||
if let some kind ← parserNodeKind? cinfo.value! then
|
||||
|
||||
@@ -144,13 +144,18 @@ def ScopedEnvExtension.popScope (ext : ScopedEnvExtension α β σ) (env : Envir
|
||||
| _ :: state₂ :: stack => { s with stateStack := state₂ :: stack }
|
||||
| _ => s
|
||||
|
||||
/-- Modifies `delimitsLocal` flag to `false` to turn off delimiting of local entries.
|
||||
/-- Modifies `delimitsLocal` flag to `false` on the top `depth` entries of the state stack,
|
||||
to turn off delimiting of local entries across multiple implicit scope levels
|
||||
(e.g. those introduced by compound `namespace A.B.C` expansions).
|
||||
-/
|
||||
def ScopedEnvExtension.setDelimitsLocal (ext : ScopedEnvExtension α β σ) (env : Environment) : Environment :=
|
||||
def ScopedEnvExtension.setDelimitsLocal (ext : ScopedEnvExtension α β σ) (env : Environment) (depth : Nat) : Environment :=
|
||||
ext.ext.modifyState (asyncMode := .local) env fun s =>
|
||||
match s.stateStack with
|
||||
| [] => s
|
||||
| state :: stack => {s with stateStack := {state with delimitsLocal := false} :: stack}
|
||||
{s with stateStack := go depth s.stateStack}
|
||||
where
|
||||
go : Nat → List (State σ) → List (State σ)
|
||||
| 0, stack => stack
|
||||
| _, [] => []
|
||||
| n + 1, state :: stack => {state with delimitsLocal := false} :: go n stack
|
||||
|
||||
def ScopedEnvExtension.addEntry (ext : ScopedEnvExtension α β σ) (env : Environment) (b : β) : Environment :=
|
||||
ext.ext.addEntry env (Entry.global b)
|
||||
@@ -226,11 +231,12 @@ def popScope [Monad m] [MonadEnv m] [MonadLiftT (ST IO.RealWorld) m] : m Unit :=
|
||||
for ext in (← scopedEnvExtensionsRef.get) do
|
||||
modifyEnv ext.popScope
|
||||
|
||||
/-- Used to implement `end_local_scope` command, that disables delimiting local entries of ScopedEnvExtension in a current scope.
|
||||
/-- Used to implement `end_local_scope` command, that disables delimiting local entries of ScopedEnvExtension
|
||||
across `depth` scope levels.
|
||||
-/
|
||||
def setDelimitsLocal [Monad m] [MonadEnv m] [MonadLiftT (ST IO.RealWorld) m] : m Unit := do
|
||||
def setDelimitsLocal [Monad m] [MonadEnv m] [MonadLiftT (ST IO.RealWorld) m] (depth : Nat) : m Unit := do
|
||||
for ext in (← scopedEnvExtensionsRef.get) do
|
||||
modifyEnv (ext.setDelimitsLocal ·)
|
||||
modifyEnv (ext.setDelimitsLocal · depth)
|
||||
|
||||
def activateScoped [Monad m] [MonadEnv m] [MonadLiftT (ST IO.RealWorld) m] (namespaceName : Name) : m Unit := do
|
||||
for ext in (← scopedEnvExtensionsRef.get) do
|
||||
|
||||
@@ -461,8 +461,7 @@ partial def InfoTree.goalsAt? (text : FileMap) (t : InfoTree) (hoverPos : String
|
||||
ctxInfo := ctx
|
||||
tacticInfo := ti
|
||||
useAfter := hoverPos > pos && !cs.any (hasNestedTactic pos tailPos)
|
||||
-- consider every position unindented after an empty `by` to support "hanging" `by` uses
|
||||
indented := (text.toPosition pos).column > (text.toPosition hoverPos).column && !isEmptyBy ti.stx
|
||||
indented := (text.toPosition pos).column > (text.toPosition hoverPos).column
|
||||
-- use goals just before cursor as fall-back only
|
||||
-- thus for `(by foo)`, placing the cursor after `foo` shows its state as long
|
||||
-- as there is no state on `)`
|
||||
@@ -485,9 +484,6 @@ where
|
||||
| InfoTree.node (Info.ofMacroExpansionInfo _) cs =>
|
||||
cs.any (hasNestedTactic pos tailPos)
|
||||
| _ => false
|
||||
isEmptyBy (stx : Syntax) : Bool :=
|
||||
-- there are multiple `by` kinds with the same structure
|
||||
stx.getNumArgs == 2 && stx[0].isToken "by" && stx[1].getNumArgs == 1 && stx[1][0].isMissing
|
||||
|
||||
|
||||
partial def InfoTree.termGoalAt? (t : InfoTree) (hoverPos : String.Pos.Raw) : Option InfoWithCtx :=
|
||||
|
||||
@@ -35,7 +35,7 @@ structure Import where
|
||||
|
||||
-- TODO: move further up into `Init` by using simpler representation for `imports`
|
||||
@[extern "lean_idbg_client_loop"]
|
||||
public opaque Idbg.idbgClientLoop {α : Type} [Nonempty α]
|
||||
opaque Idbg.idbgClientLoop {α : Type} [Nonempty α]
|
||||
(siteId : String) (imports : Array Import) (apply : α → String) : IO Unit
|
||||
|
||||
instance : Coe Name Import := ⟨({module := ·})⟩
|
||||
@@ -130,7 +130,7 @@ The type of module package identifiers.
|
||||
This is a {name}`String` that is used to disambiguate native symbol prefixes between
|
||||
different packages (and different versions of the same package).
|
||||
-/
|
||||
public abbrev PkgId := String
|
||||
abbrev PkgId := String
|
||||
|
||||
/-- A module's setup information as described by a JSON file. -/
|
||||
structure ModuleSetup where
|
||||
|
||||
@@ -22,7 +22,7 @@ open Server Std Lean SubExpr
|
||||
|
||||
NOTE: in the future we may add other tags.
|
||||
-/
|
||||
private inductive ExprDiffTag where
|
||||
inductive ExprDiffTag where
|
||||
| change
|
||||
| delete
|
||||
| insert
|
||||
|
||||
@@ -7,3 +7,4 @@ module
|
||||
|
||||
prelude
|
||||
public import Std.Internal.Http.Data
|
||||
public import Std.Internal.Http.Protocol.H1
|
||||
|
||||
@@ -6,6 +6,7 @@ Authors: Sofia Rodrigues
|
||||
module
|
||||
|
||||
prelude
|
||||
public import Std.Internal.Http.Data.URI
|
||||
public import Std.Internal.Http.Data.Headers.Name
|
||||
public import Std.Internal.Http.Data.Headers.Value
|
||||
public import Std.Internal.Parsec.Basic
|
||||
@@ -215,4 +216,89 @@ def serialize (connection : Connection) : Header.Name × Header.Value :=
|
||||
|
||||
instance : Header Connection := ⟨parse, serialize⟩
|
||||
|
||||
end Std.Http.Header.Connection
|
||||
end Connection
|
||||
|
||||
/--
|
||||
The `Host` header.
|
||||
|
||||
Represents the authority component of a URI:
|
||||
host [ ":" port ]
|
||||
|
||||
Reference: https://www.rfc-editor.org/rfc/rfc9110.html#name-host-and-authority
|
||||
-/
|
||||
structure Host where
|
||||
/--
|
||||
Host name (reg-name, IPv4, or IPv6 literal).
|
||||
-/
|
||||
host : URI.Host
|
||||
|
||||
/--
|
||||
Optional port.
|
||||
-/
|
||||
port : URI.Port
|
||||
deriving Repr, BEq
|
||||
|
||||
namespace Host
|
||||
|
||||
/--
|
||||
Parses a `Host` header value.
|
||||
-/
|
||||
def parse (v : Value) : Option Host :=
|
||||
let parsed := (Std.Http.URI.Parser.parseHostHeader <* Std.Internal.Parsec.eof).run v.value.toUTF8
|
||||
match parsed with
|
||||
| .ok ⟨host, port⟩ => some ⟨host, port⟩
|
||||
| .error _ => none
|
||||
|
||||
/--
|
||||
Serializes a `Host` header back to a name and a value.
|
||||
-/
|
||||
def serialize (host : Host) : Header.Name × Header.Value :=
|
||||
let value := match host.port with
|
||||
| .value port => Header.Value.ofString! s!"{host.host}:{port}"
|
||||
| .empty => Header.Value.ofString! s!"{host.host}:"
|
||||
| .omitted => Header.Value.ofString! <| toString host.host
|
||||
|
||||
(.mk "host", value)
|
||||
|
||||
instance : Header Host := ⟨parse, serialize⟩
|
||||
|
||||
end Host
|
||||
|
||||
/--
|
||||
The `Expect` header.
|
||||
|
||||
Represents an expectation token.
|
||||
The only standardized expectation is `100-continue`.
|
||||
|
||||
Reference: https://www.rfc-editor.org/rfc/rfc9110.html#name-expect
|
||||
-/
|
||||
structure Expect where
|
||||
deriving Repr, BEq
|
||||
|
||||
namespace Expect
|
||||
|
||||
/--
|
||||
Parses an `Expect` header.
|
||||
|
||||
Succeeds only if the value is exactly `100-continue`
|
||||
(case-insensitive, trimmed).
|
||||
-/
|
||||
def parse (v : Value) : Option Expect :=
|
||||
let normalized := v.value.trimAscii.toString.toLower
|
||||
|
||||
if normalized == "100-continue" then
|
||||
some ⟨⟩
|
||||
else
|
||||
none
|
||||
|
||||
/--
|
||||
Serializes an `Expect` header.
|
||||
-/
|
||||
def serialize (_ : Expect) : Header.Name × Header.Value :=
|
||||
(Header.Name.expect, Value.ofString! "100-continue")
|
||||
|
||||
instance : Header Expect := ⟨parse, serialize⟩
|
||||
|
||||
end Expect
|
||||
|
||||
end Std.Http.Header
|
||||
|
||||
@@ -52,13 +52,13 @@ private def parseScheme (config : URI.Config) : Parser URI.Scheme := do
|
||||
if config.maxSchemeLength = 0 then
|
||||
fail "scheme length limit is 0 (no scheme allowed)"
|
||||
|
||||
let first ← takeWhileUpTo1 isAlphaByte 1
|
||||
let rest ← takeWhileUpTo
|
||||
let first : UInt8 ← satisfy isAlphaByte
|
||||
let rest ← takeWhileAtMost
|
||||
(fun c =>
|
||||
isAlphaNum c ∨
|
||||
c = '+'.toUInt8 ∨ c = '-'.toUInt8 ∨ c = '.'.toUInt8)
|
||||
(config.maxSchemeLength - 1)
|
||||
let schemeBytes := first.toByteArray ++ rest.toByteArray
|
||||
let schemeBytes := ByteArray.empty.push first ++ rest.toByteArray
|
||||
let str := String.fromUTF8! schemeBytes |>.toLower
|
||||
|
||||
if h : URI.IsValidScheme str then
|
||||
@@ -68,7 +68,7 @@ private def parseScheme (config : URI.Config) : Parser URI.Scheme := do
|
||||
|
||||
-- port = 1*DIGIT
|
||||
private def parsePortNumber : Parser UInt16 := do
|
||||
let portBytes ← takeWhileUpTo1 isDigitByte 5
|
||||
let portBytes ← takeWhileAtMost isDigitByte 5
|
||||
|
||||
let portStr := String.fromUTF8! portBytes.toByteArray
|
||||
|
||||
@@ -82,7 +82,7 @@ private def parsePortNumber : Parser UInt16 := do
|
||||
|
||||
-- userinfo = *( unreserved / pct-encoded / sub-delims / ":" )
|
||||
private def parseUserInfo (config : URI.Config) : Parser URI.UserInfo := do
|
||||
let userBytesName ← takeWhileUpTo
|
||||
let userBytesName ← takeWhileAtMost
|
||||
(fun x =>
|
||||
x ≠ ':'.toUInt8 ∧
|
||||
(isUserInfoChar x ∨ x = '%'.toUInt8))
|
||||
@@ -94,7 +94,7 @@ private def parseUserInfo (config : URI.Config) : Parser URI.UserInfo := do
|
||||
let userPassEncoded ← if ← peekIs (· == ':'.toUInt8) then
|
||||
skip
|
||||
|
||||
let userBytesPass ← takeWhileUpTo
|
||||
let userBytesPass ← takeWhileAtMost
|
||||
(fun x => isUserInfoChar x ∨ x = '%'.toUInt8)
|
||||
config.maxUserInfoLength
|
||||
|
||||
@@ -113,7 +113,7 @@ private def parseUserInfo (config : URI.Config) : Parser URI.UserInfo := do
|
||||
private def parseIPv6 : Parser Net.IPv6Addr := do
|
||||
skipByte '['.toUInt8
|
||||
|
||||
let result ← takeWhileUpTo1
|
||||
let result ← takeWhile1AtMost
|
||||
(fun x => x = ':'.toUInt8 ∨ x = '.'.toUInt8 ∨ isHexDigitByte x)
|
||||
256
|
||||
|
||||
@@ -127,7 +127,7 @@ private def parseIPv6 : Parser Net.IPv6Addr := do
|
||||
|
||||
-- IPv4address = dec-octet "." dec-octet "." dec-octet "." dec-octet
|
||||
private def parseIPv4 : Parser Net.IPv4Addr := do
|
||||
let result ← takeWhileUpTo1
|
||||
let result ← takeWhile1AtMost
|
||||
(fun x => x = '.'.toUInt8 ∨ isDigitByte x)
|
||||
256
|
||||
|
||||
@@ -148,8 +148,8 @@ private def parseHost (config : URI.Config) : Parser URI.Host := do
|
||||
if let some ipv4 ← tryOpt parseIPv4 then
|
||||
return .ipv4 ipv4
|
||||
|
||||
-- We intentionally parse DNS names here (not full RFC 3986 reg-name).
|
||||
let some str := String.fromUTF8? (← takeWhileUpTo1
|
||||
-- It needs to be a legal DNS label, so it differs from reg-name.
|
||||
let some str := String.fromUTF8? (← takeWhile1AtMost
|
||||
(fun x => isAlphaNum x ∨ x = '-'.toUInt8 ∨ x = '.'.toUInt8)
|
||||
config.maxHostLength).toByteArray
|
||||
| fail s!"invalid host"
|
||||
@@ -187,7 +187,7 @@ private def parseAuthority (config : URI.Config) : Parser URI.Authority := do
|
||||
|
||||
-- segment = *pchar
|
||||
private def parseSegment (config : URI.Config) : Parser ByteSlice := do
|
||||
takeWhileUpTo (fun c => isPChar c ∨ c = '%'.toUInt8) config.maxSegmentLength
|
||||
takeWhileAtMost (fun c => isPChar c ∨ c = '%'.toUInt8) config.maxSegmentLength
|
||||
|
||||
/-
|
||||
path = path-abempty ; begins with "/" or is empty
|
||||
@@ -272,7 +272,7 @@ def parsePath (config : URI.Config) (forceAbsolute : Bool) (allowEmpty : Bool) :
|
||||
-- query = *( pchar / "/" / "?" )
|
||||
private def parseQuery (config : URI.Config) : Parser URI.Query := do
|
||||
let queryBytes ←
|
||||
takeWhileUpTo (fun c => isQueryChar c ∨ c = '%'.toUInt8) config.maxQueryLength
|
||||
takeWhileAtMost (fun c => isQueryChar c ∨ c = '%'.toUInt8) config.maxQueryLength
|
||||
|
||||
let some queryStr := String.fromUTF8? queryBytes.toByteArray
|
||||
| fail "invalid query string"
|
||||
@@ -304,7 +304,7 @@ private def parseQuery (config : URI.Config) : Parser URI.Query := do
|
||||
-- fragment = *( pchar / "/" / "?" )
|
||||
private def parseFragment (config : URI.Config) : Parser URI.EncodedFragment := do
|
||||
let fragmentBytes ←
|
||||
takeWhileUpTo (fun c => isFragmentChar c ∨ c = '%'.toUInt8) config.maxFragmentLength
|
||||
takeWhileAtMost (fun c => isFragmentChar c ∨ c = '%'.toUInt8) config.maxFragmentLength
|
||||
|
||||
let some fragmentStr := URI.EncodedFragment.ofByteArray? fragmentBytes.toByteArray
|
||||
| fail "invalid percent encoding in fragment"
|
||||
@@ -328,7 +328,7 @@ Parses a URI (Uniform Resource Identifier).
|
||||
URI = scheme ":" hier-part [ "?" query ] [ "#" fragment ]
|
||||
hier-part = "//" authority path-abempty / path-absolute / path-rootless / path-empty
|
||||
-/
|
||||
public def parseURI (config : URI.Config := {}) : Parser URI := do
|
||||
def parseURI (config : URI.Config := {}) : Parser URI := do
|
||||
let scheme ← parseScheme config
|
||||
skipByte ':'.toUInt8
|
||||
|
||||
@@ -347,7 +347,7 @@ public def parseURI (config : URI.Config := {}) : Parser URI := do
|
||||
/--
|
||||
Parses a request target with combined parsing and validation.
|
||||
-/
|
||||
public def parseRequestTarget (config : URI.Config := {}) : Parser RequestTarget :=
|
||||
def parseRequestTarget (config : URI.Config := {}) : Parser RequestTarget :=
|
||||
asterisk <|> origin <|> absoluteHttp <|> authority <|> absolute
|
||||
where
|
||||
-- The asterisk form
|
||||
@@ -406,7 +406,7 @@ where
|
||||
/--
|
||||
Parses an HTTP `Host` header value.
|
||||
-/
|
||||
public def parseHostHeader (config : URI.Config := {}) : Parser (URI.Host × URI.Port) := do
|
||||
def parseHostHeader (config : URI.Config := {}) : Parser (URI.Host × URI.Port) := do
|
||||
let host ← parseHost config
|
||||
|
||||
let port : URI.Port ←
|
||||
|
||||
1622
src/Std/Internal/Http/Protocol/H1.lean
Normal file
1622
src/Std/Internal/Http/Protocol/H1.lean
Normal file
File diff suppressed because it is too large
Load Diff
134
src/Std/Internal/Http/Protocol/H1/Config.lean
Normal file
134
src/Std/Internal/Http/Protocol/H1/Config.lean
Normal file
@@ -0,0 +1,134 @@
|
||||
/-
|
||||
Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Sofia Rodrigues
|
||||
-/
|
||||
module
|
||||
|
||||
prelude
|
||||
public import Std.Internal.Http.Data
|
||||
public import Std.Internal.Http.Internal
|
||||
|
||||
public section
|
||||
|
||||
/-!
|
||||
# HTTP/1.1 Configuration
|
||||
|
||||
This module defines the configuration options for HTTP/1.1 protocol processing,
|
||||
including connection limits, header constraints, and various size limits.
|
||||
-/
|
||||
|
||||
namespace Std.Http.Protocol.H1
|
||||
|
||||
set_option linter.all true
|
||||
|
||||
open Std Internal Parsec ByteArray
|
||||
open Internal
|
||||
|
||||
/--
|
||||
Connection limits and parser bounds configuration.
|
||||
-/
|
||||
structure Config where
|
||||
/--
|
||||
Maximum number of requests (server) or responses (client) per connection.
|
||||
-/
|
||||
maxMessages : Nat := 100
|
||||
|
||||
/--
|
||||
Maximum number of headers allowed per message.
|
||||
-/
|
||||
maxHeaders : Nat := 100
|
||||
|
||||
/--
|
||||
Maximum aggregate byte size of all header field lines in a single message
|
||||
(name + value bytes plus 4 bytes per line for `: ` and `\r\n`). Default: 64 KiB.
|
||||
-/
|
||||
maxHeaderBytes : Nat := 65536
|
||||
|
||||
/--
|
||||
Whether to enable keep-alive connections by default.
|
||||
-/
|
||||
enableKeepAlive : Bool := true
|
||||
|
||||
/--
|
||||
The `Server` header value injected into outgoing responses (receiving mode) or the
|
||||
`User-Agent` header value injected into outgoing requests (sending mode).
|
||||
`none` suppresses the header entirely.
|
||||
-/
|
||||
agentName : Option Header.Value := none
|
||||
|
||||
/--
|
||||
Maximum length of request URI (default: 8192 bytes).
|
||||
-/
|
||||
maxUriLength : Nat := 8192
|
||||
|
||||
/--
|
||||
Maximum number of bytes consumed while parsing request/status start-lines (default: 8192 bytes).
|
||||
-/
|
||||
maxStartLineLength : Nat := 8192
|
||||
|
||||
/--
|
||||
Maximum length of header field name (default: 256 bytes).
|
||||
-/
|
||||
maxHeaderNameLength : Nat := 256
|
||||
|
||||
/--
|
||||
Maximum length of header field value (default: 8192 bytes).
|
||||
-/
|
||||
maxHeaderValueLength : Nat := 8192
|
||||
|
||||
/--
|
||||
Maximum number of spaces in delimiter sequences (default: 16).
|
||||
-/
|
||||
maxSpaceSequence : Nat := 16
|
||||
|
||||
/--
|
||||
Maximum number of leading empty lines (bare CRLF) to skip before a request-line
|
||||
(RFC 9112 §2.2 robustness). Default: 8.
|
||||
-/
|
||||
maxLeadingEmptyLines : Nat := 8
|
||||
|
||||
/--
|
||||
Maximum number of extensions on a single chunk-size line (default: 16).
|
||||
-/
|
||||
maxChunkExtensions : Nat := 16
|
||||
|
||||
/--
|
||||
Maximum length of chunk extension name (default: 256 bytes).
|
||||
-/
|
||||
maxChunkExtNameLength : Nat := 256
|
||||
|
||||
/--
|
||||
Maximum length of chunk extension value (default: 256 bytes).
|
||||
-/
|
||||
maxChunkExtValueLength : Nat := 256
|
||||
|
||||
/--
|
||||
Maximum number of bytes consumed while parsing one chunk-size line with extensions (default: 8192 bytes).
|
||||
-/
|
||||
maxChunkLineLength : Nat := 8192
|
||||
|
||||
/--
|
||||
Maximum allowed chunk payload size in bytes (default: 8 MiB).
|
||||
-/
|
||||
maxChunkSize : Nat := 8 * 1024 * 1024
|
||||
|
||||
/--
|
||||
Maximum allowed total body size per message in bytes (default: 64 MiB).
|
||||
This limit applies across all body framing modes. For chunked transfer encoding,
|
||||
chunk-size lines (including extensions) and the trailer section also count toward
|
||||
this limit, so the total wire bytes consumed by the body cannot exceed this value.
|
||||
-/
|
||||
maxBodySize : Nat := 64 * 1024 * 1024
|
||||
|
||||
/--
|
||||
Maximum length of reason phrase (default: 512 bytes).
|
||||
-/
|
||||
maxReasonPhraseLength : Nat := 512
|
||||
|
||||
/--
|
||||
Maximum number of trailer headers (default: 20).
|
||||
-/
|
||||
maxTrailerHeaders : Nat := 20
|
||||
|
||||
end Std.Http.Protocol.H1
|
||||
110
src/Std/Internal/Http/Protocol/H1/Error.lean
Normal file
110
src/Std/Internal/Http/Protocol/H1/Error.lean
Normal file
@@ -0,0 +1,110 @@
|
||||
/-
|
||||
Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Sofia Rodrigues
|
||||
-/
|
||||
module
|
||||
|
||||
prelude
|
||||
public import Std.Time
|
||||
public import Std.Internal.Http.Data
|
||||
public import Std.Internal.Http.Internal
|
||||
public import Std.Internal.Http.Protocol.H1.Parser
|
||||
public import Std.Internal.Http.Protocol.H1.Config
|
||||
public import Std.Internal.Http.Protocol.H1.Message
|
||||
|
||||
public section
|
||||
|
||||
/-!
|
||||
# HTTP/1.1 Errors
|
||||
|
||||
This module defines the error types for HTTP/1.1 protocol processing,
|
||||
including parsing errors, timeout errors, and connection errors.
|
||||
-/
|
||||
|
||||
namespace Std.Http.Protocol.H1
|
||||
|
||||
set_option linter.all true
|
||||
|
||||
/--
|
||||
Specific HTTP processing errors with detailed information.
|
||||
-/
|
||||
inductive Error
|
||||
/--
|
||||
Malformed start line (request-line or status-line).
|
||||
-/
|
||||
| invalidStatusLine
|
||||
|
||||
/--
|
||||
Invalid or malformed header.
|
||||
-/
|
||||
| invalidHeader
|
||||
|
||||
/--
|
||||
Request timeout occurred.
|
||||
-/
|
||||
| timeout
|
||||
|
||||
/--
|
||||
Request entity too large.
|
||||
-/
|
||||
| entityTooLarge
|
||||
|
||||
/--
|
||||
Request URI is too long.
|
||||
-/
|
||||
| uriTooLong
|
||||
|
||||
/--
|
||||
Unsupported HTTP version.
|
||||
-/
|
||||
| unsupportedVersion
|
||||
|
||||
/--
|
||||
Invalid chunk encoding.
|
||||
-/
|
||||
| invalidChunk
|
||||
|
||||
/--
|
||||
Connection closed.
|
||||
-/
|
||||
| connectionClosed
|
||||
|
||||
/--
|
||||
Bad request or response message.
|
||||
-/
|
||||
| badMessage
|
||||
|
||||
/--
|
||||
The number of header fields in the message exceeds the configured limit.
|
||||
Maps to HTTP 431 Request Header Fields Too Large.
|
||||
-/
|
||||
| tooManyHeaders
|
||||
|
||||
/--
|
||||
The aggregate byte size of all header fields exceeds the configured limit.
|
||||
Maps to HTTP 431 Request Header Fields Too Large.
|
||||
-/
|
||||
| headersTooLarge
|
||||
|
||||
/--
|
||||
Generic error with message.
|
||||
-/
|
||||
| other (message : String)
|
||||
deriving Repr, BEq
|
||||
|
||||
instance : ToString Error where
|
||||
toString
|
||||
| .invalidStatusLine => "Invalid status line"
|
||||
| .invalidHeader => "Invalid header"
|
||||
| .timeout => "Timeout"
|
||||
| .entityTooLarge => "Entity too large"
|
||||
| .uriTooLong => "URI too long"
|
||||
| .unsupportedVersion => "Unsupported version"
|
||||
| .invalidChunk => "Invalid chunk"
|
||||
| .connectionClosed => "Connection closed"
|
||||
| .badMessage => "Bad message"
|
||||
| .tooManyHeaders => "Too many headers"
|
||||
| .headersTooLarge => "Headers too large"
|
||||
| .other msg => s!"Other error: {msg}"
|
||||
|
||||
73
src/Std/Internal/Http/Protocol/H1/Event.lean
Normal file
73
src/Std/Internal/Http/Protocol/H1/Event.lean
Normal file
@@ -0,0 +1,73 @@
|
||||
/-
|
||||
Copyright (c) 2025 Lean FRO, LLC. All rights reserved.
|
||||
Released under Apache 2.0 license as described in the file LICENSE.
|
||||
Authors: Sofia Rodrigues
|
||||
-/
|
||||
module
|
||||
|
||||
prelude
|
||||
public import Std.Time
|
||||
public import Std.Internal.Http.Data
|
||||
public import Std.Internal.Http.Internal
|
||||
public import Std.Internal.Http.Protocol.H1.Parser
|
||||
public import Std.Internal.Http.Protocol.H1.Config
|
||||
public import Std.Internal.Http.Protocol.H1.Message
|
||||
public import Std.Internal.Http.Protocol.H1.Error
|
||||
|
||||
public section
|
||||
|
||||
/-!
|
||||
# HTTP/1.1 Events
|
||||
|
||||
This module defines the events that can occur during HTTP/1.1 message processing,
|
||||
including header completion and control/error signals.
|
||||
-/
|
||||
|
||||
namespace Std.Http.Protocol.H1
|
||||
|
||||
set_option linter.all true
|
||||
|
||||
/--
|
||||
Events emitted during HTTP message processing.
|
||||
-/
|
||||
inductive Event (dir : Direction)
|
||||
/--
|
||||
Indicates that all headers have been successfully parsed.
|
||||
-/
|
||||
| endHeaders (head : Message.Head dir)
|
||||
|
||||
/--
|
||||
Signals that additional input data is required to continue processing.
|
||||
-/
|
||||
| needMoreData (size : Option Nat)
|
||||
|
||||
/--
|
||||
Indicates a failure during parsing or processing.
|
||||
-/
|
||||
| failed (err : Error)
|
||||
|
||||
/--
|
||||
Requests that the connection be closed.
|
||||
-/
|
||||
| close
|
||||
|
||||
/--
|
||||
The body should be closed.
|
||||
-/
|
||||
| closeBody
|
||||
|
||||
/--
|
||||
Indicates that a response is required.
|
||||
-/
|
||||
| needAnswer
|
||||
|
||||
/--
|
||||
Indicates readiness to process the next message.
|
||||
-/
|
||||
| next
|
||||
|
||||
/--
|
||||
Signals that an `Expect: 100-continue` decision is pending.
|
||||
-/
|
||||
| «continue»
|
||||
deriving Inhabited, Repr
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user