Compare commits

..

74 Commits

Author SHA1 Message Date
Kim Morrison
e1fcd9ac52 deprecations 2024-11-20 11:53:41 +11:00
Kim Morrison
87f94f2297 add find?_pmap 2024-11-20 11:43:16 +11:00
Kim Morrison
287dc6de43 feat: duplicate List.attach/attachWith/pmap API for Array 2024-11-20 11:40:17 +11:00
Kyle Miller
5eef3d27fb feat: have #print show precise fields of structures (#6096)
This PR improves the `#print` command for structures to show all fields
and which parents the fields were inherited from, hiding internal
details such as which parents are represented as subobjects. This
information is still present in the constructor if needed. The pretty
printer for private constants is also improved, and it now handles
private names from the current module like any other name; private names
from other modules are made hygienic.

Example output for `#print Monad`:
```
class Monad.{u, v} (m : Type u → Type v) : Type (max (u + 1) v)
number of parameters: 1
parents:
  Monad.toApplicative : Applicative m
  Monad.toBind : Bind m
fields:
  Functor.map : {α β : Type u} → (α → β) → m α → m β
  Functor.mapConst : {α β : Type u} → α → m β → m α
  Pure.pure : {α : Type u} → α → m α
  Seq.seq : {α β : Type u} → m (α → β) → (Unit → m α) → m β
  SeqLeft.seqLeft : {α β : Type u} → m α → (Unit → m β) → m α
  SeqRight.seqRight : {α β : Type u} → m α → (Unit → m β) → m β
  Bind.bind : {α β : Type u} → m α → (α → m β) → m β
constructor:
  Monad.mk.{u, v} {m : Type u → Type v} [toApplicative : Applicative m] [toBind : Bind m] : Monad m
resolution order:
  Monad, Applicative, Bind, Functor, Pure, Seq, SeqLeft, SeqRight
```

Suggested by Floris van Doorn [on
Zulip](https://leanprover.zulipchat.com/#narrow/channel/270676-lean4/topic/.23print.20command.20for.20structures/near/482503637).
2024-11-19 21:54:45 +00:00
Leonardo de Moura
75d1504af2 fix: isDefEq for constants with different universe parameters (#6131)
This PR fixes a bug at the definitional equality test (`isDefEq`). At
unification constraints of the form `c.{u} =?= c.{v}`, it was not trying
to unfold `c`. This bug did not affect the kernel.

closes #6117
2024-11-19 21:39:13 +00:00
Mario Carneiro
a00cf6330f fix: add a missing case to Level.geq (#2689)
This PR adds a case to `Level.geq` that is present in the kernel's level
`is_geq` procedure, making them consistent with one another.

This came up during testing of `lean4lean`. Currently `Level.geq`
differs from `level::is_geq` in the case of `max u v >= imax u v`. The
elaborator function is overly pessimistic and yields `false` on this
while the kernel function yields true. This comes up concretely in the
`Trans` class:
```lean
class Trans (r : α → β → Sort u) (s : β → γ → Sort v) (t : outParam (α → γ → Sort w)) where
  trans : r a b → s b c → t a c
```
The type of this class is `Sort (max (max (max (max (max (max 1 u) u_1)
u_2) u_3) v) w)` (where `u_1 u_2 u_3` are the levels of `α β γ`), but if
you try writing that type explicitly then the `class` command fails.
Omitting the type leaves the `class` to infer the universe level (the
command assumes the level is correct, and the kernel agrees it is), but
including the type then the elaborator checks the level inequality with
`Level.geq` and fails.

---------

Co-authored-by: Kyle Miller <kmill31415@gmail.com>
2024-11-19 21:27:00 +00:00
Leonardo de Moura
1f32477385 fix: isDefEq when zetaDelta := false (#6129)
This PR fixes a bug at `isDefEq` when `zetaDelta := false`. See new test
for a small example that exposes the issue.
2024-11-19 21:22:02 +00:00
Thomas Köppe
91c14c7ee9 fix: only consider salient bytes in sharecommon eq, hash (#5840)
This PR changes `lean_sharecommon_{eq,hash}` to only consider the
salient bytes of an object, and not any bytes of any
unspecified/uninitialized unused capacity.

Accessing uninitialized storage results in undefined behaviour.

This does not seem to have any semantics disadvantages: If objects
compare equal after this change, their salient bytes are still equal. By
contrast, if the actual identity of allocations needs to be
distinguished, that can be done by just comparing pointers to the
storage.

If we wanted to retain the current logic, we would need initialize the
otherwise unused parts to some specific value to avoid the undefined
behaviour.

Closes #5831
2024-11-19 13:56:46 +00:00
Lean stage0 autoupdater
69530afdf9 chore: update stage0 2024-11-19 13:06:43 +00:00
Marc Huisinga
b7667c1604 fix: don't issue atomic id completions when there is a dangling dot (#5837)
This PR fixes an old auto-completion bug where `x.` would issue
nonsensical completions when `x.` could not be elaborated as a dot
completion.
2024-11-19 12:23:41 +00:00
Eric Wieser
d6f898001b chore: generalize List.get_mem (#6095)
This is syntactically more general than before, though up to eta
expansion it make no difference.
2024-11-19 11:08:10 +00:00
Marc Huisinga
a38566693b test: fix brittle structure instance completion test (#6127)
#5835 contains a brittle test that uses an FVar ID, which caused a
failure on master. This PR changes that test to use a declaration
instead.
2024-11-19 10:13:51 +00:00
Marc Huisinga
4bef3588b5 chore: update stage0 2024-11-19 09:26:58 +01:00
Marc Huisinga
64538cf6e8 chore: prepare for bootstrap
Co-Authored-By: Sebastian Ullrich <sebasti@nullri.ch>
2024-11-19 09:26:58 +01:00
Marc Huisinga
aadf3f1d2c feat: use new structInstFields parser to tag structure instance fields 2024-11-19 09:26:58 +01:00
Marc Huisinga
95bf45ff8b refactor: split Completion.lean 2024-11-19 09:26:58 +01:00
Marc Huisinga
2a02c121cf feat: structure auto-completion & partial InfoTrees 2024-11-19 09:26:58 +01:00
Mac Malone
4600bb16fc feat: use BaseIO at IO.rand (#6102)
This PR moves `IO.rand` and `IO.setRandSeed` to be in the `BaseIO`
monad.

This is their proper monad as neither can error.
2024-11-19 05:26:03 +00:00
Kim Morrison
7ccdfc30ff chore: turn off pp.mvars in apply? results (#6108)
Per request on
[zulip](https://leanprover.zulipchat.com/#narrow/channel/270676-lean4/topic/apply.3F.20using.20tombstones/near/482895588).
2024-11-19 02:02:32 +00:00
Kim Morrison
7f0bdefb6e chore: fix apply? error reporting when out of heartbeats (#6121) 2024-11-19 00:57:59 +00:00
Joachim Breitner
799b2b6628 fix: handle reordered indices in structural recursion (#6116)
This PR fixes a bug where structural recursion did not work when indices
of the recursive argument appeared as function parameters in a different
order than in the argument's type's definition.

Fixes #6015.
2024-11-18 11:28:02 +00:00
David Thrane Christiansen
b8d6e44c4f fix: liberalize rules for atoms by allowing leading '' (#6114)
This PR liberalizes atom rules by allowing `''` to be a prefix of an
atom, after #6012 only added an exception for `''` alone, and also adds
some unit tests for atom validation.
2024-11-18 10:19:20 +00:00
Kim Morrison
5a99cb326c chore: make Lean.Elab.Command.mkMetaContext public (#6113) 2024-11-18 06:14:34 +00:00
Kim Morrison
e10fac93a6 feat: lemmas for Array.findSome? and find? (#6111)
This PR fills in the API for `Array.findSome?` and `Array.find?`,
transferring proofs from the corresponding List statements.
2024-11-18 04:19:56 +00:00
Kyle Miller
62ae320e1c chore: document Lean.Elab.StructInst, refactor (#6110)
This PR does some mild refactoring of the `Lean.Elab.StructInst` module
while adding documentation.

Documentation is drawn from @thorimur's #1928.
2024-11-18 02:57:22 +00:00
Leonardo de Moura
98b1edfc1f fix: backtrack at injection failure (#6109)
This PR fixes an issue in the `injection` tactic. This tactic may
execute multiple sub-tactics. If any of them fail, we must backtrack the
partial assignment. This issue was causing the error: "`mvarId` is
already assigned" in issue #6066. The issue is not yet resolved, as the
equation generator for the match expressions is failing in the example
provided in this issue.
2024-11-18 02:26:06 +00:00
Leonardo de Moura
ab162b3f52 fix: isDefEq, whnf, simp caching and configuration (#6053)
This PR fixes the caching infrastructure for `whnf` and `isDefEq`,
ensuring the cache accounts for all relevant configuration flags. It
also cleans up the `WHNF.lean` module and improves the configuration of
`whnf`.
2024-11-18 01:17:26 +00:00
Kim Morrison
b8a13ab755 chore: fix naming of left/right injectivity lemmas (#6106)
We've been internally inconsistent on the naming of these lemmas in
Lean; this changes them to match Mathlib (which, moreover, I think is
correct).
2024-11-18 00:53:46 +00:00
Sebastian Ullrich
405593ea28 chore: avoid stack overflow in debug tests (#6103) 2024-11-17 14:54:49 +00:00
Kim Morrison
24f305c0e3 chore: fix canonicalizer handling over forall/lambda (#6082)
This PR changes how the canonicalizer handles `forall` and `lambda`,
replacing bvars with temporary fvars. Fixes a bug reported by @hrmacbeth
on
[zulip](https://leanprover.zulipchat.com/#narrow/channel/270676-lean4/topic/Quantifiers.20in.20CanonM/near/482483448).
2024-11-17 07:34:45 +00:00
Leonardo de Moura
5d553d6369 fix: circular assignment at structure instance elaborator (#6105)
This PR fixes a stack overflow caused by a cyclic assignment in the
metavariable context. The cycle is unintentionally introduced by the
structure instance elaborator.

closes #3150
2024-11-17 00:56:52 +00:00
Sebastian Ullrich
a449e3fdd6 feat: IO.getTID (#6049)
This PR adds a primitive for accessing the current thread ID

To be used in a thread-aware trace profiler
2024-11-16 19:13:11 +00:00
Kyle Miller
764386734c fix: improvements to change tactic (#6022)
This PR makes the `change` tactic and conv tactic use the same
elaboration strategy. It works uniformly for both the target and local
hypotheses. Now `change` can assign metavariables, for example:
```lean
example (x y z : Nat) : x + y = z := by
  change ?a = _
  let w := ?a
  -- now `w : Nat := x + y`
```
2024-11-16 07:08:29 +00:00
Kyle Miller
7f1d7a595b fix: use Expr.equal instead of == in MVarId.replaceTargetDefEq and MVarId.replaceLocalDeclDefEq (#6098)
This PR modifies `Lean.MVarId.replaceTargetDefEq` and
`Lean.MVarId.replaceLocalDeclDefEq` to use `Expr.equal` instead of
`Expr.eqv` when determining whether the expression has changed. This is
justified on the grounds that binder names and binder infos are
user-visible and affect elaboration.
2024-11-16 02:03:16 +00:00
Leonardo de Moura
f13e5ca852 chore: naming convention and NaN normalization (#6097)
Changes:
- `Float.fromBits` => `Float.ofBits`
- NaN normalization
2024-11-16 00:14:28 +00:00
Leonardo de Moura
ecbaeff24b feat: add Float.toBits and Float.fromBits (#6094)
This PR adds raw transmutation of floating-point numbers to and from
`UInt64`. Floats and UInts share the same endianness across all
supported platforms. The IEEE 754 standard precisely specifies the bit
layout of floats. Note that `Float.toBits` is distinct from
`Float.toUInt64`, which attempts to preserve the numeric value rather
than the bitwise value.

closes #6071
2024-11-15 19:45:19 +00:00
Kyle Miller
691acde696 feat: pp.parens option to pretty print with all parentheses (#2934)
This PR adds the option `pp.parens` (default: false) that causes the
pretty printer to eagerly insert parentheses, which can be useful for
teaching and for understanding the structure of expressions. For
example, it causes `p → q → r` to pretty print as `p → (q → r)`.

Any notations with precedence greater than or equal to `maxPrec` do not
receive such discretionary parentheses, since this precedence level is
considered to be infinity.

This option was a feature in the Lean 3 community edition.
2024-11-15 19:11:54 +00:00
Kyle Miller
b1e0c1b594 chore: remove decide! tactic (#6016)
This PR removes the `decide!` tactic in favor of `decide +kernel`
(breaking change).
2024-11-15 17:49:33 +00:00
Joachim Breitner
93b4ec0351 refactor: use mkFreshUserName in ArgsPacker (#6093)
and other small refinements done while investigating an issue; not
actually user-visible.
2024-11-15 15:59:14 +00:00
JovanGerb
f06fc30c0b perf: remove @[specialize] from mkBinding (#6019)
This PR removes @[specilize] from `MkBinding.mkBinding`, which is a
function that cannot be specialized (as none of its arguments are
functions). As a result, the specializable function `Nat.foldRevM.loop`
doesn't get specialized, which leads to worse performing code.

As expected, the mathlib bench shows a very small improvement. About 95%
of files show a speedup.
(http://speed.lean-fro.org/mathlib4/compare/e7b27246-a3e6-496a-b552-ff4b45c7236e/to/6033df75-aa53-44d9-819d-51f93fc05e94?hash1=b28f0d7f7e9cc3949a9a3556a6b36513f37f690d)
2024-11-15 15:06:49 +00:00
Markus Himmel
64b35a8c19 perf: add LEAN_ALWAYS_INLINE to some functions (#6045)
Otherwise, clang refuses to inline them for large functions which leads
to a performance cliff.
2024-11-15 15:05:32 +00:00
Markus Himmel
688ee4c887 fix: constant folding for Nat.ble and Nat.blt (#6087)
This PR fixes a bug in the constant folding for the `Nat.ble` and
`Nat.blt` function in the old code generator, leading to a
miscompilation.

Closes #6086
2024-11-15 12:09:52 +00:00
Henrik Böving
9a3dd615e0 chore: bv_decide remove noop rewrites (#6080)
Merely removes rules that are actually just syntactic aliases but equal
at the `Expr` level.
2024-11-15 11:41:54 +00:00
Violeta Hernández
7e6363dc05 chore: join → flatten in docstring (#6040)
Update the docstring of `List.flatten`.
2024-11-15 10:11:42 +00:00
Kim Morrison
a074bd9a2b feat: implementation of Array.pmap (#6052)
This PR adds `Array.pmap`, as well as a `@[csimp]` lemma in terms of the
no-copy `Array.attachWith`.
2024-11-15 02:10:04 +00:00
Kyle Miller
498d41633b fix: pretty print .coeFun with terminfo of coercee (#6085)
This PR improves the term info for coercions marked with
`CoeFnType.coeFun` (such as `DFunLike.coe` in Mathlib), making "go to
definition" on the function name work. Hovering over such a coerced
function will show the coercee rather than the coercion expression. The
coercion expression can still be seen by hovering over the whitespace in
the function application.
2024-11-15 01:45:38 +00:00
Sofia Rodrigues
e0d7c3ac79 feat: add date and time functionality (#4904)
This PR introduces date and time functionality to the Lean 4 Std.

Breaking Changes:
- `Lean.Data.Rat` is now `Std.Internal.Rat` because it's used by the
DateTime library.

---------

Co-authored-by: Markus Himmel <markus@himmel-villmar.de>
Co-authored-by: Mac Malone <tydeu@hatpress.net>
2024-11-14 14:04:19 +00:00
Joachim Breitner
6a5b122b40 perf: use RArray in simp_arith meta code (#6068 part 2)
This PR makes `simp_arith` use `RArray` for the context of the
reflection proofs, which scales better when there are many variables.

On our synthetic benchmark:
```
simp_arith1               instructions    -25.1% (-4892.6 σ)
```

No effect on mathlib, though, guess it’s not used much on large goals there:
http://speed.lean-fro.org/mathlib4/compare/873b982b-2038-462a-9b68-0c0fc457f90d/to/56e66691-2f1f-4947-a922-37b80680315d
2024-11-14 14:08:48 +01:00
Joachim Breitner
bf9ddf2c74 chore: update stage0 2024-11-14 14:08:48 +01:00
Joachim Breitner
3f47871e73 perf: use RArray in simp_arith meta code (#6068 part 1)
This PR prepares #6068 by using the `RArray` data structure in
`simp_arith` the simp-arith meta code.

After the subsequent stage0 we can change the simp-arith theorems in
`Init`.
2024-11-14 14:08:48 +01:00
Joachim Breitner
85f25967ea feat: Lean.RArray (#6070)
This PR adds the Lean.RArray data structure.

This data structure is equivalent to `Fin n → α` or `Array α`, but
optimized for a fast kernel-reduction `get` operation.

It is not suitable as a general-purpose data structure. The primary
intended use case is the “denote” function of a typical proof by
reflection proof, where only the `get` operation is necessary, and where
using `List.get` unnecessarily slows down proofs with more than a
hand-full of atomic expressions.


There is no well-formedness invariant attached to this data structure,
to keep it concise; it's semantics is given through `RArray.get`. In
that way one can also view an `RArray` as a decision tree implementing
`Nat → α`.

In #6068 this data structure is used in `simp_arith`.
2024-11-14 10:56:50 +00:00
David Thrane Christiansen
8e1ddbc5aa fix: validate atoms modulo leading and trailing whitespace (#6012)
This PR improves the validation of new syntactic tokens. Previously, the
validation code had inconsistencies: some atoms would be accepted only
if they had a leading space as a pretty printer hint. Additionally,
atoms with internal whitespace are no longer allowed.

Closes #6011
2024-11-14 10:40:17 +00:00
Henrik Böving
e6e39f502f feat: add options to configure all of bv_decide's preprocessing (#6077)
This PR adds options to `bv_decide`'s configuration structure such that
all non mandatory preprocessing passes can be disabled.
2024-11-14 09:22:23 +00:00
Henrik Böving
debb82bc20 perf: make andFlattening work on deeply nested hyps in one pass (#6075)
No changelog as this PR improves performance of a feature that is not
yet released.
2024-11-14 09:09:25 +00:00
Violeta Hernández
9a85433477 refactor: allow Sort u in Squash (#6074)
Co-authored-by: Kim Morrison <kim@tqft.net>
2024-11-14 05:55:21 +00:00
Mac Malone
4616c0ac3e refactor: lake: avoid v! in builtin code (#6073)
Use of `v!` in Lake code can cause bootstrapping failures and is easily
avoided. It is perfectly safe in user code.
2024-11-14 05:00:02 +00:00
Leonardo de Moura
e55b681774 feat: add Context.setConfig (#6072)
This PR adds `Lean.Simp.Context.setConfig` function.
2024-11-14 00:32:13 +00:00
Kim Morrison
63132105ba feat: lemmas about for loops over Array (#6055)
This PR adds lemmas about for loops over `Array`, following the existing
lemmas for `List`.
2024-11-13 23:23:55 +00:00
Kim Morrison
350b36411c chore: upstream some NameMap functions (#6056) 2024-11-13 23:22:01 +00:00
Kim Morrison
1c30c76e72 chore: remove >6 month old deprecations (#6057) 2024-11-13 23:21:23 +00:00
Alissa Tung
d5adadc00e chore: add newline at end of file for lake new templates (#6026)
This PR adds a newline at end of each Lean file generated by `lake new`
templates.

I have tested it with a locally compiled Lean with this commit. I hope
these changes make `lake new`'s behavior more consistent with the Lean 4
plugins and libraries newlines convention.
2024-11-13 19:39:47 +00:00
Mac Malone
f08805e5c4 feat: message kinds (#5945)
This PR adds a new definition `Message.kind` which returns the top-level
tag of a message. This is serialized as the new field `kind` in
`SerialMessaege` so that i can be used by external consumers (e.g.,
Lake) to identify messages via `lean --json`.

The tag of trace messages has also been changed from `_traceMsg` to the
more friendly `trace`.
2024-11-13 18:05:52 +00:00
Joachim Breitner
256b49bda9 perf: optimize Nat.Linear.Poly.norm (#6064)
Not a huge benefit, but actually reduces the code complexity (no need
for the `.fuse` function), and can help with problems with many repeated
varibles.
2024-11-13 17:36:51 +00:00
Kyle Miller
28cf146d00 fix: make sure monad lift coercion elaborator has no side effects (#6024)
This PR fixes a bug where the monad lift coercion elaborator would
partially unify expressions even if they were not monads. This could be
taken advantage of to propagate information that could help elaboration
make progress, for example the first `change` worked because the monad
lift coercion elaborator was unifying `@Eq _ _` with `@Eq (Nat × Nat)
p`:
```lean
example (p : Nat × Nat) : p = p := by
  change _ = ⟨_, _⟩ -- used to work (yielding `p = (p.fst, p.snd)`), now it doesn't
  change ⟨_, _⟩ = _ -- never worked
```
As such, this is a breaking change; you may need to adjust expressions
to include additional implicit arguments.
2024-11-13 16:22:31 +00:00
Joachim Breitner
970261b1e1 perf: optimize Nat.Linear.Expr.toPoly (#6062) 2024-11-13 15:54:29 +00:00
Joachim Breitner
6b811f8c92 test: synthetic simp_arith benchmark (#6061)
This PR adds a simp_arith benchmark.

This benchmark highlights some improvable asymptotics in `Nat.Linear`,
which
will be fixed subsequently.
2024-11-13 15:49:52 +00:00
Henrik Böving
f721f94045 feat: Bool.to(U)IntX (#6060)
This PR implements conversion functions from `Bool` to all `UIntX` and
`IntX` types.

Note that `Bool.toUInt64` already existed in previous versions of Lean.
2024-11-13 15:49:16 +00:00
Sebastian Ullrich
86524d5c23 fix: line break in simp? output (#6048)
This PR fixes `simp?` suggesting output with invalid indentation 

Fixes #6006
2024-11-13 15:49:11 +00:00
Joachim Breitner
f18d9e04bc refactor: omega: avoid MVar machinery (#5991)
This PR simplifies the implementation of `omega`.

When constructing the proof, `omega` is using MVars only for the purpose
of doing case analysis on `Or`. We can simplify the implementation a
fair bit if we just produce the proof directly using `Or.elim`.

While it didn’t yield the performance benefits I was hoping for, this
still seems a worthwhile simplification, now that we already have it.
2024-11-13 15:49:03 +00:00
Joachim Breitner
fa33423c84 chore: pr-body: run as part of merge_group, but do not do anything (#6069) 2024-11-13 15:47:58 +00:00
Leonardo de Moura
1315266dd3 refactor: mark the Simp.Context constructor as private
motivation: this is the first step to fix the mismatch
between `isDefEq` and the discrimination tree indexing.
2024-11-13 14:12:55 +11:00
Leonardo de Moura
b1e52f1475 chore: mark Meta.Context.config as private (#6051)
Motivation: we want to modify the internal representation and improve
`isDefEq` caching.
This PR is preparing the stage for future modifications.
2024-11-13 13:30:06 +11:00
Kim Morrison
985600f448 chore: update stage0 2024-11-13 11:16:34 +11:00
Kim Morrison
ace6248e20 chore: deprecate Array.sequenceMap 2024-11-13 11:16:34 +11:00
636 changed files with 20882 additions and 2908 deletions

View File

@@ -1,6 +1,7 @@
name: Check PR body for changelog convention
on:
merge_group:
pull_request:
types: [opened, synchronize, reopened, edited, labeled, converted_to_draft, ready_for_review]
@@ -9,6 +10,7 @@ jobs:
runs-on: ubuntu-latest
steps:
- name: Check PR body
if: github.event_name == 'pull_request'
uses: actions/github-script@v7
with:
script: |

View File

@@ -170,7 +170,7 @@ lib.warn "The Nix-based build is deprecated" rec {
ln -sf ${lean-all}/* .
'';
buildPhase = ''
ctest --output-junit test-results.xml --output-on-failure -E 'leancomptest_(doc_example|foreign)|leanlaketest_reverse-ffi' -j$NIX_BUILD_CORES
ctest --output-junit test-results.xml --output-on-failure -E 'leancomptest_(doc_example|foreign)|leanlaketest_reverse-ffi|leanruntest_timeIO' -j$NIX_BUILD_CORES
'';
installPhase = ''
mkdir $out

View File

@@ -1922,12 +1922,12 @@ represents an element of `Squash α` the same as `α` itself
`Squash.lift` will extract a value in any subsingleton `β` from a function on `α`,
while `Nonempty.rec` can only do the same when `β` is a proposition.
-/
def Squash (α : Type u) := Quot (fun (_ _ : α) => True)
def Squash (α : Sort u) := Quot (fun (_ _ : α) => True)
/-- The canonical quotient map into `Squash α`. -/
def Squash.mk {α : Type u} (x : α) : Squash α := Quot.mk _ x
def Squash.mk {α : Sort u} (x : α) : Squash α := Quot.mk _ x
theorem Squash.ind {α : Type u} {motive : Squash α Prop} (h : (a : α), motive (Squash.mk a)) : (q : Squash α), motive q :=
theorem Squash.ind {α : Sort u} {motive : Squash α Prop} (h : (a : α), motive (Squash.mk a)) : (q : Squash α), motive q :=
Quot.ind h
/-- If `β` is a subsingleton, then a function `α → β` lifts to `Squash α → β`. -/

View File

@@ -42,3 +42,4 @@ import Init.Data.PLift
import Init.Data.Zero
import Init.Data.NeZero
import Init.Data.Function
import Init.Data.RArray

View File

@@ -18,3 +18,4 @@ import Init.Data.Array.Bootstrap
import Init.Data.Array.GetLit
import Init.Data.Array.MapIdx
import Init.Data.Array.Set
import Init.Data.Array.Monadic

View File

@@ -10,6 +10,17 @@ import Init.Data.List.Attach
namespace Array
/--
`O(n)`. Partial map. If `f : Π a, P a → β` is a partial function defined on
`a : α` satisfying `P`, then `pmap f l h` is essentially the same as `map f l`
but is defined only when all members of `l` satisfy `P`, using the proof
to apply `f`.
We replace this at runtime with a more efficient version via the `csimp` lemma `pmap_eq_pmapImpl`.
-/
def pmap {P : α Prop} (f : a, P a β) (l : Array α) (H : a l, P a) : Array β :=
(l.toList.pmap f (fun a m => H a (mem_def.mpr m))).toArray
/--
Unsafe implementation of `attachWith`, taking advantage of the fact that the representation of
`Array {x // P x}` is the same as the input `Array α`.
@@ -35,6 +46,10 @@ Unsafe implementation of `attachWith`, taking advantage of the fact that the rep
l.toArray.attach = (l.attachWith (· l.toArray) (by simp)).toArray := by
simp [attach]
@[simp] theorem _root_.List.pmap_toArray {l : List α} {P : α Prop} {f : a, P a β} {H : a l.toArray, P a} :
l.toArray.pmap f H = (l.pmap f (by simpa using H)).toArray := by
simp [pmap]
@[simp] theorem toList_attachWith {l : Array α} {P : α Prop} {H : x l, P x} :
(l.attachWith P H).toList = l.toList.attachWith P (by simpa [mem_toList] using H) := by
simp [attachWith]
@@ -43,6 +58,387 @@ Unsafe implementation of `attachWith`, taking advantage of the fact that the rep
l.attach.toList = l.toList.attachWith (· l) (by simp [mem_toList]) := by
simp [attach]
@[simp] theorem toList_pmap {l : Array α} {P : α Prop} {f : a, P a β} {H : a l, P a} :
(l.pmap f H).toList = l.toList.pmap f (fun a m => H a (mem_def.mpr m)) := by
simp [pmap]
/-- Implementation of `pmap` using the zero-copy version of `attach`. -/
@[inline] private def pmapImpl {P : α Prop} (f : a, P a β) (l : Array α) (H : a l, P a) :
Array β := (l.attachWith _ H).map fun x, h' => f x h'
@[csimp] private theorem pmap_eq_pmapImpl : @pmap = @pmapImpl := by
funext α β p f L h'
cases L
simp only [pmap, pmapImpl, List.attachWith_toArray, List.map_toArray, mk.injEq, List.map_attachWith]
apply List.pmap_congr_left
intro a m h₁ h₂
congr
@[simp] theorem pmap_empty {P : α Prop} (f : a, P a β) : pmap f #[] (by simp) = #[] := rfl
@[simp] theorem pmap_push {P : α Prop} (f : a, P a β) (a : α) (l : Array α) (h : b l.push a, P b) :
pmap f (l.push a) h =
(pmap f l (fun a m => by simp at h; exact h a (.inl m))).push (f a (h a (by simp))) := by
simp [pmap]
@[simp] theorem attach_empty : (#[] : Array α).attach = #[] := rfl
@[simp] theorem attachWith_empty {P : α Prop} (H : x #[], P x) : (#[] : Array α).attachWith P H = #[] := rfl
@[simp] theorem _root_.List.attachWith_mem_toArray {l : List α} :
l.attachWith (fun x => x l.toArray) (fun x h => by simpa using h) =
l.attach.map fun x, h => x, by simpa using h := by
simp only [List.attachWith, List.attach, List.map_pmap]
apply List.pmap_congr_left
simp
@[simp]
theorem pmap_eq_map (p : α Prop) (f : α β) (l : Array α) (H) :
@pmap _ _ p (fun a _ => f a) l H = map f l := by
cases l; simp
theorem pmap_congr_left {p q : α Prop} {f : a, p a β} {g : a, q a β} (l : Array α) {H₁ H₂}
(h : a l, (h₁ h₂), f a h₁ = g a h₂) : pmap f l H₁ = pmap g l H₂ := by
cases l
simp only [mem_toArray] at h
simp only [List.pmap_toArray, mk.injEq]
rw [List.pmap_congr_left _ h]
theorem map_pmap {p : α Prop} (g : β γ) (f : a, p a β) (l H) :
map g (pmap f l H) = pmap (fun a h => g (f a h)) l H := by
cases l
simp [List.map_pmap]
theorem pmap_map {p : β Prop} (g : b, p b γ) (f : α β) (l H) :
pmap g (map f l) H = pmap (fun a h => g (f a) h) l fun _ h => H _ (mem_map_of_mem _ h) := by
cases l
simp [List.pmap_map]
theorem attach_congr {l₁ l₂ : Array α} (h : l₁ = l₂) :
l₁.attach = l₂.attach.map (fun x => x.1, h x.2) := by
subst h
simp
theorem attachWith_congr {l₁ l₂ : Array α} (w : l₁ = l₂) {P : α Prop} {H : x l₁, P x} :
l₁.attachWith P H = l₂.attachWith P fun _ h => H _ (w h) := by
subst w
simp
@[simp] theorem attach_push {a : α} {l : Array α} :
(l.push a).attach =
(l.attach.map (fun x, h => x, mem_push_of_mem a h)).push a, by simp := by
cases l
rw [attach_congr (List.push_toArray _ _)]
simp [Function.comp_def]
@[simp] theorem attachWith_push {a : α} {l : Array α} {P : α Prop} {H : x l.push a, P x} :
(l.push a).attachWith P H =
(l.attachWith P (fun x h => by simp at H; exact H x (.inl h))).push a, H a (by simp) := by
cases l
simp [attachWith_congr (List.push_toArray _ _)]
theorem pmap_eq_map_attach {p : α Prop} (f : a, p a β) (l H) :
pmap f l H = l.attach.map fun x => f x.1 (H _ x.2) := by
cases l
simp [List.pmap_eq_map_attach]
theorem attach_map_coe (l : Array α) (f : α β) :
(l.attach.map fun (i : {i // i l}) => f i) = l.map f := by
cases l
simp [List.attach_map_coe]
theorem attach_map_val (l : Array α) (f : α β) : (l.attach.map fun i => f i.val) = l.map f :=
attach_map_coe _ _
@[simp]
theorem attach_map_subtype_val (l : Array α) : l.attach.map Subtype.val = l := by
cases l; simp
theorem attachWith_map_coe {p : α Prop} (f : α β) (l : Array α) (H : a l, p a) :
((l.attachWith p H).map fun (i : { i // p i}) => f i) = l.map f := by
cases l; simp
theorem attachWith_map_val {p : α Prop} (f : α β) (l : Array α) (H : a l, p a) :
((l.attachWith p H).map fun i => f i.val) = l.map f :=
attachWith_map_coe _ _ _
@[simp]
theorem attachWith_map_subtype_val {p : α Prop} (l : Array α) (H : a l, p a) :
(l.attachWith p H).map Subtype.val = l := by
cases l; simp
@[simp]
theorem mem_attach (l : Array α) : x, x l.attach
| a, h => by
have := mem_map.1 (by rw [attach_map_subtype_val] <;> exact h)
rcases this with _, _, m, rfl
exact m
@[simp]
theorem mem_pmap {p : α Prop} {f : a, p a β} {l H b} :
b pmap f l H (a : _) (h : a l), f a (H a h) = b := by
simp only [pmap_eq_map_attach, mem_map, mem_attach, true_and, Subtype.exists, eq_comm]
theorem mem_pmap_of_mem {p : α Prop} {f : a, p a β} {l H} {a} (h : a l) :
f a (H a h) pmap f l H := by
rw [mem_pmap]
exact a, h, rfl
@[simp]
theorem size_pmap {p : α Prop} {f : a, p a β} {l H} : (pmap f l H).size = l.size := by
cases l; simp
@[simp]
theorem size_attach {L : Array α} : L.attach.size = L.size := by
cases L; simp
@[simp]
theorem size_attachWith {p : α Prop} {l : Array α} {H} : (l.attachWith p H).size = l.size := by
cases l; simp
@[simp]
theorem pmap_eq_empty_iff {p : α Prop} {f : a, p a β} {l H} : pmap f l H = #[] l = #[] := by
cases l; simp
theorem pmap_ne_empty_iff {P : α Prop} (f : (a : α) P a β) {xs : Array α}
(H : (a : α), a xs P a) : xs.pmap f H #[] xs #[] := by
cases xs; simp
theorem pmap_eq_self {l : Array α} {p : α Prop} (hp : (a : α), a l p a)
(f : (a : α) p a α) : l.pmap f hp = l a (h : a l), f a (hp a h) = a := by
cases l; simp [List.pmap_eq_self]
@[simp]
theorem attach_eq_empty_iff {l : Array α} : l.attach = #[] l = #[] := by
cases l; simp
theorem attach_ne_empty_iff {l : Array α} : l.attach #[] l #[] := by
cases l; simp
@[simp]
theorem attachWith_eq_empty_iff {l : Array α} {P : α Prop} {H : a l, P a} :
l.attachWith P H = #[] l = #[] := by
cases l; simp
theorem attachWith_ne_empty_iff {l : Array α} {P : α Prop} {H : a l, P a} :
l.attachWith P H #[] l #[] := by
cases l; simp
@[simp]
theorem getElem?_pmap {p : α Prop} (f : a, p a β) {l : Array α} (h : a l, p a) (n : Nat) :
(pmap f l h)[n]? = Option.pmap f l[n]? fun x H => h x (mem_of_getElem? H) := by
cases l; simp
@[simp]
theorem getElem_pmap {p : α Prop} (f : a, p a β) {l : Array α} (h : a l, p a) {n : Nat}
(hn : n < (pmap f l h).size) :
(pmap f l h)[n] =
f (l[n]'(@size_pmap _ _ p f l h hn))
(h _ (getElem_mem (@size_pmap _ _ p f l h hn))) := by
cases l; simp
@[simp]
theorem getElem?_attachWith {xs : Array α} {i : Nat} {P : α Prop} {H : a xs, P a} :
(xs.attachWith P H)[i]? = xs[i]?.pmap Subtype.mk (fun _ a => H _ (mem_of_getElem? a)) :=
getElem?_pmap ..
@[simp]
theorem getElem?_attach {xs : Array α} {i : Nat} :
xs.attach[i]? = xs[i]?.pmap Subtype.mk (fun _ a => mem_of_getElem? a) :=
getElem?_attachWith
@[simp]
theorem getElem_attachWith {xs : Array α} {P : α Prop} {H : a xs, P a}
{i : Nat} (h : i < (xs.attachWith P H).size) :
(xs.attachWith P H)[i] = xs[i]'(by simpa using h), H _ (getElem_mem (by simpa using h)) :=
getElem_pmap ..
@[simp]
theorem getElem_attach {xs : Array α} {i : Nat} (h : i < xs.attach.size) :
xs.attach[i] = xs[i]'(by simpa using h), getElem_mem (by simpa using h) :=
getElem_attachWith h
theorem foldl_pmap (l : Array α) {P : α Prop} (f : (a : α) P a β)
(H : (a : α), a l P a) (g : γ β γ) (x : γ) :
(l.pmap f H).foldl g x = l.attach.foldl (fun acc a => g acc (f a.1 (H _ a.2))) x := by
rw [pmap_eq_map_attach, foldl_map]
theorem foldr_pmap (l : Array α) {P : α Prop} (f : (a : α) P a β)
(H : (a : α), a l P a) (g : β γ γ) (x : γ) :
(l.pmap f H).foldr g x = l.attach.foldr (fun a acc => g (f a.1 (H _ a.2)) acc) x := by
rw [pmap_eq_map_attach, foldr_map]
/--
If we fold over `l.attach` with a function that ignores the membership predicate,
we get the same results as folding over `l` directly.
This is useful when we need to use `attach` to show termination.
Unfortunately this can't be applied by `simp` because of the higher order unification problem,
and even when rewriting we need to specify the function explicitly.
See however `foldl_subtype` below.
-/
theorem foldl_attach (l : Array α) (f : β α β) (b : β) :
l.attach.foldl (fun acc t => f acc t.1) b = l.foldl f b := by
rcases l with l
simp only [List.attach_toArray, List.attachWith_mem_toArray, List.map_attach, size_toArray,
List.length_pmap, List.foldl_toArray', mem_toArray, List.foldl_subtype]
congr
ext
simpa using fun a => List.mem_of_getElem? a
/--
If we fold over `l.attach` with a function that ignores the membership predicate,
we get the same results as folding over `l` directly.
This is useful when we need to use `attach` to show termination.
Unfortunately this can't be applied by `simp` because of the higher order unification problem,
and even when rewriting we need to specify the function explicitly.
See however `foldr_subtype` below.
-/
theorem foldr_attach (l : Array α) (f : α β β) (b : β) :
l.attach.foldr (fun t acc => f t.1 acc) b = l.foldr f b := by
rcases l with l
simp only [List.attach_toArray, List.attachWith_mem_toArray, List.map_attach, size_toArray,
List.length_pmap, List.foldr_toArray', mem_toArray, List.foldr_subtype]
congr
ext
simpa using fun a => List.mem_of_getElem? a
theorem attach_map {l : Array α} (f : α β) :
(l.map f).attach = l.attach.map (fun x, h => f x, mem_map_of_mem f h) := by
cases l
ext <;> simp
theorem attachWith_map {l : Array α} (f : α β) {P : β Prop} {H : (b : β), b l.map f P b} :
(l.map f).attachWith P H = (l.attachWith (P f) (fun _ h => H _ (mem_map_of_mem f h))).map
fun x, h => f x, h := by
cases l
ext
· simp
· simp only [List.map_toArray, List.attachWith_toArray, List.getElem_toArray,
List.getElem_attachWith, List.getElem_map, Function.comp_apply]
erw [List.getElem_attachWith] -- Why is `erw` needed here?
theorem map_attachWith {l : Array α} {P : α Prop} {H : (a : α), a l P a}
(f : { x // P x } β) :
(l.attachWith P H).map f =
l.pmap (fun a (h : a l P a) => f a, H _ h.1) (fun a h => h, H a h) := by
cases l
ext <;> simp
/-- See also `pmap_eq_map_attach` for writing `pmap` in terms of `map` and `attach`. -/
theorem map_attach {l : Array α} (f : { x // x l } β) :
l.attach.map f = l.pmap (fun a h => f a, h) (fun _ => id) := by
cases l
ext <;> simp
theorem attach_filterMap {l : Array α} {f : α Option β} :
(l.filterMap f).attach = l.attach.filterMap
fun x, h => (f x).pbind (fun b m => some b, mem_filterMap.mpr x, h, m) := by
cases l
rw [attach_congr (List.filterMap_toArray f _)]
simp [List.attach_filterMap, List.map_filterMap, Function.comp_def]
theorem attach_filter {l : Array α} (p : α Bool) :
(l.filter p).attach = l.attach.filterMap
fun x => if w : p x.1 then some x.1, mem_filter.mpr x.2, w else none := by
cases l
rw [attach_congr (List.filter_toArray p _)]
simp [List.attach_filter, List.map_filterMap, Function.comp_def]
-- We are still missing here `attachWith_filterMap` and `attachWith_filter`.
-- Also missing are `filterMap_attach`, `filter_attach`, `filterMap_attachWith` and `filter_attachWith`.
theorem pmap_pmap {p : α Prop} {q : β Prop} (g : a, p a β) (f : b, q b γ) (l H₁ H₂) :
pmap f (pmap g l H₁) H₂ =
pmap (α := { x // x l }) (fun a h => f (g a h) (H₂ (g a h) (mem_pmap_of_mem a.2))) l.attach
(fun a _ => H₁ a a.2) := by
cases l
simp [List.pmap_pmap, List.pmap_map]
@[simp] theorem pmap_append {p : ι Prop} (f : a : ι, p a α) (l₁ l₂ : Array ι)
(h : a l₁ ++ l₂, p a) :
(l₁ ++ l₂).pmap f h =
(l₁.pmap f fun a ha => h a (mem_append_left l₂ ha)) ++
l₂.pmap f fun a ha => h a (mem_append_right l₁ ha) := by
cases l₁
cases l₂
simp
theorem pmap_append' {p : α Prop} (f : a : α, p a β) (l₁ l₂ : Array α)
(h₁ : a l₁, p a) (h₂ : a l₂, p a) :
((l₁ ++ l₂).pmap f fun a ha => (mem_append.1 ha).elim (h₁ a) (h₂ a)) =
l₁.pmap f h₁ ++ l₂.pmap f h₂ :=
pmap_append f l₁ l₂ _
@[simp] theorem attach_append (xs ys : Array α) :
(xs ++ ys).attach = xs.attach.map (fun x, h => x, mem_append_left ys h) ++
ys.attach.map fun x, h => x, mem_append_right xs h := by
cases xs
cases ys
rw [attach_congr (List.append_toArray _ _)]
simp [List.attach_append, Function.comp_def]
@[simp] theorem attachWith_append {P : α Prop} {xs ys : Array α}
{H : (a : α), a xs ++ ys P a} :
(xs ++ ys).attachWith P H = xs.attachWith P (fun a h => H a (mem_append_left ys h)) ++
ys.attachWith P (fun a h => H a (mem_append_right xs h)) := by
simp [attachWith, attach_append, map_pmap, pmap_append]
@[simp] theorem pmap_reverse {P : α Prop} (f : (a : α) P a β) (xs : Array α)
(H : (a : α), a xs.reverse P a) :
xs.reverse.pmap f H = (xs.pmap f (fun a h => H a (by simpa using h))).reverse := by
induction xs <;> simp_all
theorem reverse_pmap {P : α Prop} (f : (a : α) P a β) (xs : Array α)
(H : (a : α), a xs P a) :
(xs.pmap f H).reverse = xs.reverse.pmap f (fun a h => H a (by simpa using h)) := by
rw [pmap_reverse]
@[simp] theorem attachWith_reverse {P : α Prop} {xs : Array α}
{H : (a : α), a xs.reverse P a} :
xs.reverse.attachWith P H =
(xs.attachWith P (fun a h => H a (by simpa using h))).reverse := by
cases xs
simp
theorem reverse_attachWith {P : α Prop} {xs : Array α}
{H : (a : α), a xs P a} :
(xs.attachWith P H).reverse = (xs.reverse.attachWith P (fun a h => H a (by simpa using h))) := by
cases xs
simp
@[simp] theorem attach_reverse (xs : Array α) :
xs.reverse.attach = xs.attach.reverse.map fun x, h => x, by simpa using h := by
cases xs
rw [attach_congr (List.reverse_toArray _)]
simp
theorem reverse_attach (xs : Array α) :
xs.attach.reverse = xs.reverse.attach.map fun x, h => x, by simpa using h := by
cases xs
simp
@[simp] theorem back?_pmap {P : α Prop} (f : (a : α) P a β) (xs : Array α)
(H : (a : α), a xs P a) :
(xs.pmap f H).back? = xs.attach.back?.map fun a, m => f a (H a m) := by
cases xs
simp
@[simp] theorem back?_attachWith {P : α Prop} {xs : Array α}
{H : (a : α), a xs P a} :
(xs.attachWith P H).back? = xs.back?.pbind (fun a h => some a, H _ (mem_of_back?_eq_some h)) := by
cases xs
simp
@[simp]
theorem back?_attach {xs : Array α} :
xs.attach.back? = xs.back?.pbind fun a h => some a, mem_of_back?_eq_some h := by
cases xs
simp
/-! ## unattach
`Array.unattach` is the (one-sided) inverse of `Array.attach`. It is a synonym for `Array.map Subtype.val`.
@@ -83,7 +479,7 @@ def unattach {α : Type _} {p : α → Prop} (l : Array { x // p x }) := l.map (
@[simp] theorem unattach_attach {l : Array α} : l.attach.unattach = l := by
cases l
simp
simp only [List.attach_toArray, List.unattach_toArray, List.unattach_attachWith]
@[simp] theorem unattach_attachWith {p : α Prop} {l : Array α}
{H : a l, p a} :
@@ -91,6 +487,15 @@ def unattach {α : Type _} {p : α → Prop} (l : Array { x // p x }) := l.map (
cases l
simp
@[simp] theorem getElem?_unattach {p : α Prop} {l : Array { x // p x }} (i : Nat) :
l.unattach[i]? = l[i]?.map Subtype.val := by
simp [unattach]
@[simp] theorem getElem_unattach
{p : α Prop} {l : Array { x // p x }} (i : Nat) (h : i < l.unattach.size) :
l.unattach[i] = (l[i]'(by simpa using h)).1 := by
simp [unattach]
/-! ### Recognizing higher order functions using a function that only depends on the value. -/
/--

View File

@@ -15,26 +15,26 @@ This file contains some theorems about `Array` and `List` needed for `Init.Data.
namespace Array
theorem foldlM_eq_foldlM_toList.aux [Monad m]
theorem foldlM_toList.aux [Monad m]
(f : β α m β) (arr : Array α) (i j) (H : arr.size i + j) (b) :
foldlM.loop f arr arr.size (Nat.le_refl _) i j b = (arr.toList.drop j).foldlM f b := by
unfold foldlM.loop
split; split
· cases Nat.not_le_of_gt _ (Nat.zero_add _ H)
· rename_i i; rw [Nat.succ_add] at H
simp [foldlM_eq_foldlM_toList.aux f arr i (j+1) H]
simp [foldlM_toList.aux f arr i (j+1) H]
rw (occs := .pos [2]) [ List.getElem_cons_drop_succ_eq_drop _]
rfl
· rw [List.drop_of_length_le (Nat.ge_of_not_lt _)]; rfl
theorem foldlM_eq_foldlM_toList [Monad m]
@[simp] theorem foldlM_toList [Monad m]
(f : β α m β) (init : β) (arr : Array α) :
arr.foldlM f init = arr.toList.foldlM f init := by
simp [foldlM, foldlM_eq_foldlM_toList.aux]
arr.toList.foldlM f init = arr.foldlM f init := by
simp [foldlM, foldlM_toList.aux]
theorem foldl_eq_foldl_toList (f : β α β) (init : β) (arr : Array α) :
arr.foldl f init = arr.toList.foldl f init :=
List.foldl_eq_foldlM .. foldlM_eq_foldlM_toList ..
@[simp] theorem foldl_toList (f : β α β) (init : β) (arr : Array α) :
arr.toList.foldl f init = arr.foldl f init :=
List.foldl_eq_foldlM .. foldlM_toList ..
theorem foldrM_eq_reverse_foldlM_toList.aux [Monad m]
(f : α β m β) (arr : Array α) (init : β) (i h) :
@@ -51,23 +51,23 @@ theorem foldrM_eq_reverse_foldlM_toList [Monad m] (f : α → β → m β) (init
match arr, this with | _, .inl rfl => rfl | arr, .inr h => ?_
simp [foldrM, h, foldrM_eq_reverse_foldlM_toList.aux, List.take_length]
theorem foldrM_eq_foldrM_toList [Monad m]
@[simp] theorem foldrM_toList [Monad m]
(f : α β m β) (init : β) (arr : Array α) :
arr.foldrM f init = arr.toList.foldrM f init := by
arr.toList.foldrM f init = arr.foldrM f init := by
rw [foldrM_eq_reverse_foldlM_toList, List.foldlM_reverse]
theorem foldr_eq_foldr_toList (f : α β β) (init : β) (arr : Array α) :
arr.foldr f init = arr.toList.foldr f init :=
List.foldr_eq_foldrM .. foldrM_eq_foldrM_toList ..
@[simp] theorem foldr_toList (f : α β β) (init : β) (arr : Array α) :
arr.toList.foldr f init = arr.foldr f init :=
List.foldr_eq_foldrM .. foldrM_toList ..
@[simp] theorem push_toList (arr : Array α) (a : α) : (arr.push a).toList = arr.toList ++ [a] := by
simp [push, List.concat_eq_append]
@[simp] theorem toListAppend_eq (arr : Array α) (l) : arr.toListAppend l = arr.toList ++ l := by
simp [toListAppend, foldr_eq_foldr_toList]
simp [toListAppend, foldr_toList]
@[simp] theorem toListImpl_eq (arr : Array α) : arr.toListImpl = arr.toList := by
simp [toListImpl, foldr_eq_foldr_toList]
simp [toListImpl, foldr_toList]
@[simp] theorem pop_toList (arr : Array α) : arr.pop.toList = arr.toList.dropLast := rfl
@@ -76,7 +76,7 @@ theorem foldr_eq_foldr_toList (f : α → β → β) (init : β) (arr : Array α
@[simp] theorem toList_append (arr arr' : Array α) :
(arr ++ arr').toList = arr.toList ++ arr'.toList := by
rw [ append_eq_append]; unfold Array.append
rw [foldl_eq_foldl_toList]
rw [ foldl_toList]
induction arr'.toList generalizing arr <;> simp [*]
@[simp] theorem toList_empty : (#[] : Array α).toList = [] := rfl
@@ -98,20 +98,44 @@ theorem foldr_eq_foldr_toList (f : α → β → β) (init : β) (arr : Array α
rw [ appendList_eq_append]; unfold Array.appendList
induction l generalizing arr <;> simp [*]
@[deprecated foldlM_eq_foldlM_toList (since := "2024-09-09")]
abbrev foldlM_eq_foldlM_data := @foldlM_eq_foldlM_toList
@[deprecated "Use the reverse direction of `foldrM_toList`." (since := "2024-11-13")]
theorem foldrM_eq_foldrM_toList [Monad m]
(f : α β m β) (init : β) (arr : Array α) :
arr.foldrM f init = arr.toList.foldrM f init := by
simp
@[deprecated foldl_eq_foldl_toList (since := "2024-09-09")]
abbrev foldl_eq_foldl_data := @foldl_eq_foldl_toList
@[deprecated "Use the reverse direction of `foldlM_toList`." (since := "2024-11-13")]
theorem foldlM_eq_foldlM_toList [Monad m]
(f : β α m β) (init : β) (arr : Array α) :
arr.foldlM f init = arr.toList.foldlM f init:= by
simp
@[deprecated "Use the reverse direction of `foldr_toList`." (since := "2024-11-13")]
theorem foldr_eq_foldr_toList
(f : α β β) (init : β) (arr : Array α) :
arr.foldr f init = arr.toList.foldr f init := by
simp
@[deprecated "Use the reverse direction of `foldl_toList`." (since := "2024-11-13")]
theorem foldl_eq_foldl_toList
(f : β α β) (init : β) (arr : Array α) :
arr.foldl f init = arr.toList.foldl f init:= by
simp
@[deprecated foldlM_toList (since := "2024-09-09")]
abbrev foldlM_eq_foldlM_data := @foldlM_toList
@[deprecated foldl_toList (since := "2024-09-09")]
abbrev foldl_eq_foldl_data := @foldl_toList
@[deprecated foldrM_eq_reverse_foldlM_toList (since := "2024-09-09")]
abbrev foldrM_eq_reverse_foldlM_data := @foldrM_eq_reverse_foldlM_toList
@[deprecated foldrM_eq_foldrM_toList (since := "2024-09-09")]
abbrev foldrM_eq_foldrM_data := @foldrM_eq_foldrM_toList
@[deprecated foldrM_toList (since := "2024-09-09")]
abbrev foldrM_eq_foldrM_data := @foldrM_toList
@[deprecated foldr_eq_foldr_toList (since := "2024-09-09")]
abbrev foldr_eq_foldr_data := @foldr_eq_foldr_toList
@[deprecated foldr_toList (since := "2024-09-09")]
abbrev foldr_eq_foldr_data := @foldr_toList
@[deprecated push_toList (since := "2024-09-09")]
abbrev push_data := @push_toList

View File

@@ -0,0 +1,281 @@
/-
Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kim Morrison
-/
prelude
import Init.Data.List.Find
import Init.Data.Array.Lemmas
import Init.Data.Array.Attach
/-!
# Lemmas about `Array.findSome?`, `Array.find?`.
-/
namespace Array
open Nat
/-! ### findSome? -/
@[simp] theorem findSomeRev?_push_of_isSome (l : Array α) (h : (f a).isSome) : (l.push a).findSomeRev? f = f a := by
cases l; simp_all
@[simp] theorem findSomeRev?_push_of_isNone (l : Array α) (h : (f a).isNone) : (l.push a).findSomeRev? f = l.findSomeRev? f := by
cases l; simp_all
theorem exists_of_findSome?_eq_some {f : α Option β} {l : Array α} (w : l.findSome? f = some b) :
a, a l f a = b := by
cases l; simp_all [List.exists_of_findSome?_eq_some]
@[simp] theorem findSome?_eq_none_iff : findSome? p l = none x l, p x = none := by
cases l; simp
@[simp] theorem findSome?_isSome_iff {f : α Option β} {l : Array α} :
(l.findSome? f).isSome x, x l (f x).isSome := by
cases l; simp
theorem findSome?_eq_some_iff {f : α Option β} {l : Array α} {b : β} :
l.findSome? f = some b (l₁ : Array α) (a : α) (l₂ : Array α), l = l₁.push a ++ l₂ f a = some b x l₁, f x = none := by
cases l
simp only [List.findSome?_toArray, List.findSome?_eq_some_iff]
constructor
· rintro l₁, a, l₂, rfl, h₁, h₂
exact l₁.toArray, a, l₂.toArray, by simp_all
· rintro l₁, a, l₂, h₀, h₁, h₂
exact l₁.toList, a, l₂.toList, by simpa using congrArg toList h₀, h₁, by simpa
@[simp] theorem findSome?_guard (l : Array α) : findSome? (Option.guard fun x => p x) l = find? p l := by
cases l; simp
@[simp] theorem getElem?_zero_filterMap (f : α Option β) (l : Array α) : (l.filterMap f)[0]? = l.findSome? f := by
cases l; simp [ List.head?_eq_getElem?]
@[simp] theorem getElem_zero_filterMap (f : α Option β) (l : Array α) (h) :
(l.filterMap f)[0] = (l.findSome? f).get (by cases l; simpa [List.length_filterMap_eq_countP] using h) := by
cases l; simp [ List.head_eq_getElem, getElem?_zero_filterMap]
@[simp] theorem back?_filterMap (f : α Option β) (l : Array α) : (l.filterMap f).back? = l.findSomeRev? f := by
cases l; simp
@[simp] theorem back!_filterMap [Inhabited β] (f : α Option β) (l : Array α) :
(l.filterMap f).back! = (l.findSomeRev? f).getD default := by
cases l; simp
@[simp] theorem map_findSome? (f : α Option β) (g : β γ) (l : Array α) :
(l.findSome? f).map g = l.findSome? (Option.map g f) := by
cases l; simp
theorem findSome?_map (f : β γ) (l : Array β) : findSome? p (l.map f) = l.findSome? (p f) := by
cases l; simp [List.findSome?_map]
theorem findSome?_append {l₁ l₂ : Array α} : (l₁ ++ l₂).findSome? f = (l₁.findSome? f).or (l₂.findSome? f) := by
cases l₁; cases l₂; simp [List.findSome?_append]
theorem getElem?_zero_flatten (L : Array (Array α)) :
(flatten L)[0]? = L.findSome? fun l => l[0]? := by
cases L using array_array_induction
simp [ List.head?_eq_getElem?, List.head?_flatten, List.findSome?_map, Function.comp_def]
theorem getElem_zero_flatten.proof {L : Array (Array α)} (h : 0 < L.flatten.size) :
(L.findSome? fun l => l[0]?).isSome := by
cases L using array_array_induction
simp only [List.findSome?_toArray, List.findSome?_map, Function.comp_def, List.getElem?_toArray,
List.findSome?_isSome_iff, List.isSome_getElem?]
simp only [flatten_toArray_map_toArray, size_toArray, List.length_flatten,
Nat.sum_pos_iff_exists_pos, List.mem_map] at h
obtain _, xs, m, rfl, h := h
exact xs, m, by simpa using h
theorem getElem_zero_flatten {L : Array (Array α)} (h) :
(flatten L)[0] = (L.findSome? fun l => l[0]?).get (getElem_zero_flatten.proof h) := by
have t := getElem?_zero_flatten L
simp [getElem?_eq_getElem, h] at t
simp [ t]
theorem back?_flatten {L : Array (Array α)} :
(flatten L).back? = (L.findSomeRev? fun l => l.back?) := by
cases L using array_array_induction
simp [List.getLast?_flatten, List.map_reverse, List.findSome?_map, Function.comp_def]
theorem findSome?_mkArray : findSome? f (mkArray n a) = if n = 0 then none else f a := by
simp [mkArray_eq_toArray_replicate, List.findSome?_replicate]
@[simp] theorem findSome?_mkArray_of_pos (h : 0 < n) : findSome? f (mkArray n a) = f a := by
simp [findSome?_mkArray, Nat.ne_of_gt h]
-- Argument is unused, but used to decide whether `simp` should unfold.
@[simp] theorem findSome?_mkArray_of_isSome (_ : (f a).isSome) :
findSome? f (mkArray n a) = if n = 0 then none else f a := by
simp [findSome?_mkArray]
@[simp] theorem findSome?_mkArray_of_isNone (h : (f a).isNone) :
findSome? f (mkArray n a) = none := by
rw [Option.isNone_iff_eq_none] at h
simp [findSome?_mkArray, h]
/-! ### find? -/
@[simp] theorem find?_singleton (a : α) (p : α Bool) :
#[a].find? p = if p a then some a else none := by
simp [singleton_eq_toArray_singleton]
@[simp] theorem findRev?_push_of_pos (l : Array α) (h : p a) :
findRev? p (l.push a) = some a := by
cases l; simp [h]
@[simp] theorem findRev?_cons_of_neg (l : Array α) (h : ¬p a) :
findRev? p (l.push a) = findRev? p l := by
cases l; simp [h]
@[simp] theorem find?_eq_none : find? p l = none x l, ¬ p x := by
cases l; simp
theorem find?_eq_some_iff_append {xs : Array α} :
xs.find? p = some b p b (as bs : Array α), xs = as.push b ++ bs a as, !p a := by
rcases xs with xs
simp only [List.find?_toArray, List.find?_eq_some_iff_append, Bool.not_eq_eq_eq_not,
Bool.not_true, exists_and_right, and_congr_right_iff]
intro w
constructor
· rintro as, x, rfl, h
exact as.toArray, x.toArray, by simp , by simpa using h
· rintro as, x, h', h
exact as.toList, x.toList, by simpa using congrArg Array.toList h',
by simpa using h
@[simp]
theorem find?_push_eq_some {xs : Array α} :
(xs.push a).find? p = some b xs.find? p = some b (xs.find? p = none (p a a = b)) := by
cases xs; simp
@[simp] theorem find?_isSome {xs : Array α} {p : α Bool} : (xs.find? p).isSome x, x xs p x := by
cases xs; simp
theorem find?_some {xs : Array α} (h : find? p xs = some a) : p a := by
cases xs
simp at h
exact List.find?_some h
theorem mem_of_find?_eq_some {xs : Array α} (h : find? p xs = some a) : a xs := by
cases xs
simp at h
simpa using List.mem_of_find?_eq_some h
theorem get_find?_mem {xs : Array α} (h) : (xs.find? p).get h xs := by
cases xs
simp [List.get_find?_mem]
@[simp] theorem find?_filter {xs : Array α} (p q : α Bool) :
(xs.filter p).find? q = xs.find? (fun a => p a q a) := by
cases xs; simp
@[simp] theorem getElem?_zero_filter (p : α Bool) (l : Array α) :
(l.filter p)[0]? = l.find? p := by
cases l; simp [ List.head?_eq_getElem?]
@[simp] theorem getElem_zero_filter (p : α Bool) (l : Array α) (h) :
(l.filter p)[0] =
(l.find? p).get (by cases l; simpa [ List.countP_eq_length_filter] using h) := by
cases l
simp [List.getElem_zero_eq_head]
@[simp] theorem back?_filter (p : α Bool) (l : Array α) : (l.filter p).back? = l.findRev? p := by
cases l; simp
@[simp] theorem back!_filter [Inhabited α] (p : α Bool) (l : Array α) :
(l.filter p).back! = (l.findRev? p).get! := by
cases l; simp [Option.get!_eq_getD]
@[simp] theorem find?_filterMap (xs : Array α) (f : α Option β) (p : β Bool) :
(xs.filterMap f).find? p = (xs.find? (fun a => (f a).any p)).bind f := by
cases xs; simp
@[simp] theorem find?_map (f : β α) (xs : Array β) :
find? p (xs.map f) = (xs.find? (p f)).map f := by
cases xs; simp
@[simp] theorem find?_append {l₁ l₂ : Array α} :
(l₁ ++ l₂).find? p = (l₁.find? p).or (l₂.find? p) := by
cases l₁
cases l₂
simp
@[simp] theorem find?_flatten (xs : Array (Array α)) (p : α Bool) :
xs.flatten.find? p = xs.findSome? (·.find? p) := by
cases xs using array_array_induction
simp [List.findSome?_map, Function.comp_def]
theorem find?_flatten_eq_none {xs : Array (Array α)} {p : α Bool} :
xs.flatten.find? p = none ys xs, x ys, !p x := by
simp
/--
If `find? p` returns `some a` from `xs.flatten`, then `p a` holds, and
some array in `xs` contains `a`, and no earlier element of that array satisfies `p`.
Moreover, no earlier array in `xs` has an element satisfying `p`.
-/
theorem find?_flatten_eq_some {xs : Array (Array α)} {p : α Bool} {a : α} :
xs.flatten.find? p = some a
p a (as : Array (Array α)) (ys zs : Array α) (bs : Array (Array α)),
xs = as.push (ys.push a ++ zs) ++ bs
( a as, x a, !p x) ( x ys, !p x) := by
cases xs using array_array_induction
simp only [flatten_toArray_map_toArray, List.find?_toArray, List.find?_flatten_eq_some]
simp only [Bool.not_eq_eq_eq_not, Bool.not_true, exists_and_right, and_congr_right_iff]
intro w
constructor
· rintro as, ys, zs, bs, rfl, h₁, h₂
exact as.toArray.map List.toArray, ys.toArray,
zs.toArray, bs.toArray.map List.toArray, by simp, by simpa using h₁, by simpa using h₂
· rintro as, ys, zs, bs, h, h₁, h₂
replace h := congrArg (·.map Array.toList) (congrArg Array.toList h)
simp [Function.comp_def] at h
exact as.toList.map Array.toList, ys.toList,
zs.toList, bs.toList.map Array.toList, by simpa using h,
by simpa using h₁, by simpa using h₂
@[simp] theorem find?_flatMap (xs : Array α) (f : α Array β) (p : β Bool) :
(xs.flatMap f).find? p = xs.findSome? (fun x => (f x).find? p) := by
cases xs
simp [List.find?_flatMap, Array.flatMap_toArray]
theorem find?_flatMap_eq_none {xs : Array α} {f : α Array β} {p : β Bool} :
(xs.flatMap f).find? p = none x xs, y f x, !p y := by
simp
theorem find?_mkArray :
find? p (mkArray n a) = if n = 0 then none else if p a then some a else none := by
simp [mkArray_eq_toArray_replicate, List.find?_replicate]
@[simp] theorem find?_mkArray_of_length_pos (h : 0 < n) :
find? p (mkArray n a) = if p a then some a else none := by
simp [find?_mkArray, Nat.ne_of_gt h]
@[simp] theorem find?_mkArray_of_pos (h : p a) :
find? p (mkArray n a) = if n = 0 then none else some a := by
simp [find?_mkArray, h]
@[simp] theorem find?_mkArray_of_neg (h : ¬ p a) : find? p (mkArray n a) = none := by
simp [find?_mkArray, h]
-- This isn't a `@[simp]` lemma since there is already a lemma for `l.find? p = none` for any `l`.
theorem find?_mkArray_eq_none {n : Nat} {a : α} {p : α Bool} :
(mkArray n a).find? p = none n = 0 !p a := by
simp [mkArray_eq_toArray_replicate, List.find?_replicate_eq_none, Classical.or_iff_not_imp_left]
@[simp] theorem find?_mkArray_eq_some {n : Nat} {a b : α} {p : α Bool} :
(mkArray n a).find? p = some b n 0 p a a = b := by
simp [mkArray_eq_toArray_replicate]
@[simp] theorem get_find?_mkArray (n : Nat) (a : α) (p : α Bool) (h) :
((mkArray n a).find? p).get h = a := by
simp [mkArray_eq_toArray_replicate]
theorem find?_pmap {P : α Prop} (f : (a : α) P a β) (xs : Array α)
(H : (a : α), a xs P a) (p : β Bool) :
(xs.pmap f H).find? p = (xs.attach.find? (fun a, m => p (f a (H a m)))).map fun a, m => f a (H a m) := by
simp only [pmap_eq_map_attach, find?_map]
rfl
end Array

View File

@@ -23,6 +23,9 @@ import Init.TacticsExtra
namespace Array
@[simp] theorem mem_toArray {a : α} {l : List α} : a l.toArray a l := by
simp [mem_def]
@[simp] theorem getElem_mk {xs : List α} {i : Nat} (h : i < xs.length) : (Array.mk xs)[i] = xs[i] := rfl
theorem getElem_eq_getElem_toList {a : Array α} (h : i < a.size) : a[i] = a.toList[i] := rfl
@@ -36,12 +39,21 @@ theorem getElem?_eq_getElem {a : Array α} {i : Nat} (h : i < a.size) : a[i]? =
· rw [getElem?_neg a i h]
simp_all
@[simp] theorem none_eq_getElem?_iff {a : Array α} {i : Nat} : none = a[i]? a.size i := by
simp [eq_comm (a := none)]
theorem getElem?_eq {a : Array α} {i : Nat} :
a[i]? = if h : i < a.size then some a[i] else none := by
split
· simp_all [getElem?_eq_getElem]
· simp_all
theorem getElem?_eq_some_iff {a : Array α} : a[i]? = some b h : i < a.size, a[i] = b := by
simp [getElem?_eq]
theorem some_eq_getElem?_iff {a : Array α} : some b = a[i]? h : i < a.size, a[i] = b := by
rw [eq_comm, getElem?_eq_some_iff]
theorem getElem?_eq_getElem?_toList (a : Array α) (i : Nat) : a[i]? = a.toList[i]? := by
rw [getElem?_eq]
split <;> simp_all
@@ -66,6 +78,35 @@ theorem getElem_push (a : Array α) (x : α) (i : Nat) (h : i < (a.push x).size)
@[deprecated getElem_push_lt (since := "2024-10-21")] abbrev get_push_lt := @getElem_push_lt
@[deprecated getElem_push_eq (since := "2024-10-21")] abbrev get_push_eq := @getElem_push_eq
@[simp] theorem mem_push {a : Array α} {x y : α} : x a.push y x a x = y := by
simp [mem_def]
theorem mem_push_self {a : Array α} {x : α} : x a.push x :=
mem_push.2 (Or.inr rfl)
theorem mem_push_of_mem {a : Array α} {x : α} (y : α) (h : x a) : x a.push y :=
mem_push.2 (Or.inl h)
theorem getElem_of_mem {a} {l : Array α} (h : a l) : (n : Nat) (h : n < l.size), l[n]'h = a := by
cases l
simp [List.getElem_of_mem (by simpa using h)]
theorem getElem?_of_mem {a} {l : Array α} (h : a l) : n : Nat, l[n]? = some a :=
let n, _, e := getElem_of_mem h; n, e getElem?_eq_getElem _
theorem mem_of_getElem? {l : Array α} {n : Nat} {a : α} (e : l[n]? = some a) : a l :=
let _, e := getElem?_eq_some_iff.1 e; e getElem_mem ..
theorem mem_iff_getElem {a} {l : Array α} : a l (n : Nat) (h : n < l.size), l[n]'h = a :=
getElem_of_mem, fun _, _, e => e getElem_mem ..
theorem mem_iff_getElem? {a} {l : Array α} : a l n : Nat, l[n]? = some a := by
simp [getElem?_eq_some_iff, mem_iff_getElem]
theorem forall_getElem {l : Array α} {p : α Prop} :
( (n : Nat) h, p (l[n]'h)) a, a l p a := by
cases l; simp [List.forall_getElem]
@[simp] theorem get!_eq_getElem! [Inhabited α] (a : Array α) (i : Nat) : a.get! i = a[i]! := by
simp [getElem!_def, get!, getD]
split <;> rename_i h
@@ -93,9 +134,6 @@ We prefer to pull `List.toArray` outwards.
(a.toArrayAux b).size = b.size + a.length := by
simp [size]
@[simp] theorem mem_toArray {a : α} {l : List α} : a l.toArray a l := by
simp [mem_def]
@[simp] theorem push_toArray (l : List α) (a : α) : l.toArray.push a = (l ++ [a]).toArray := by
apply ext'
simp
@@ -151,15 +189,15 @@ theorem foldrM_toArray [Monad m] (f : α → β → m β) (init : β) (l : List
theorem foldlM_toArray [Monad m] (f : β α m β) (init : β) (l : List α) :
l.toArray.foldlM f init = l.foldlM f init := by
rw [foldlM_eq_foldlM_toList]
rw [foldlM_toList]
theorem foldr_toArray (f : α β β) (init : β) (l : List α) :
l.toArray.foldr f init = l.foldr f init := by
rw [foldr_eq_foldr_toList]
rw [foldr_toList]
theorem foldl_toArray (f : β α β) (init : β) (l : List α) :
l.toArray.foldl f init = l.foldl f init := by
rw [foldl_eq_foldl_toList]
rw [foldl_toList]
/-- Variant of `foldrM_toArray` with a side condition for the `start` argument. -/
@[simp] theorem foldrM_toArray' [Monad m] (f : α β m β) (init : β) (l : List α)
@@ -174,21 +212,21 @@ theorem foldl_toArray (f : β → α → β) (init : β) (l : List α) :
(h : stop = l.toArray.size) :
l.toArray.foldlM f init 0 stop = l.foldlM f init := by
subst h
rw [foldlM_eq_foldlM_toList]
rw [foldlM_toList]
/-- Variant of `foldr_toArray` with a side condition for the `start` argument. -/
@[simp] theorem foldr_toArray' (f : α β β) (init : β) (l : List α)
(h : start = l.toArray.size) :
l.toArray.foldr f init start 0 = l.foldr f init := by
subst h
rw [foldr_eq_foldr_toList]
rw [foldr_toList]
/-- Variant of `foldl_toArray` with a side condition for the `stop` argument. -/
@[simp] theorem foldl_toArray' (f : β α β) (init : β) (l : List α)
(h : stop = l.toArray.size) :
l.toArray.foldl f init 0 stop = l.foldl f init := by
subst h
rw [foldl_eq_foldl_toList]
rw [foldl_toList]
@[simp] theorem append_toArray (l₁ l₂ : List α) :
l₁.toArray ++ l₂.toArray = (l₁ ++ l₂).toArray := by
@@ -202,6 +240,9 @@ theorem foldl_toArray (f : β → α → β) (init : β) (l : List α) :
@[simp] theorem foldl_push {l : List α} {as : Array α} : l.foldl Array.push as = as ++ l.toArray := by
induction l generalizing as <;> simp [*]
@[simp] theorem foldr_push {l : List α} {as : Array α} : l.foldr (fun a b => push b a) as = as ++ l.reverse.toArray := by
rw [foldr_eq_foldl_reverse, foldl_push]
@[simp] theorem findSomeM?_toArray [Monad m] [LawfulMonad m] (f : α m (Option β)) (l : List α) :
l.toArray.findSomeM? f = l.findSomeM? f := by
rw [Array.findSomeM?]
@@ -362,7 +403,8 @@ namespace Array
theorem foldrM_push [Monad m] (f : α β m β) (init : β) (arr : Array α) (a : α) :
(arr.push a).foldrM f init = f a init >>= arr.foldrM f := by
simp [foldrM_eq_reverse_foldlM_toList, -size_push]
simp only [foldrM_eq_reverse_foldlM_toList, push_toList, List.reverse_append, List.reverse_cons,
List.reverse_nil, List.nil_append, List.singleton_append, List.foldlM_cons, List.foldlM_reverse]
/--
Variant of `foldrM_push` with `h : start = arr.size + 1`
@@ -388,11 +430,11 @@ rather than `(arr.push a).size` as the argument.
@[inline] def toListRev (arr : Array α) : List α := arr.foldl (fun l t => t :: l) []
@[simp] theorem toListRev_eq (arr : Array α) : arr.toListRev = arr.toList.reverse := by
rw [toListRev, foldl_eq_foldl_toList, List.foldr_reverse, List.foldr_cons_nil]
rw [toListRev, foldl_toList, List.foldr_reverse, List.foldr_cons_nil]
theorem mapM_eq_foldlM [Monad m] [LawfulMonad m] (f : α m β) (arr : Array α) :
arr.mapM f = arr.foldlM (fun bs a => bs.push <$> f a) #[] := by
rw [mapM, aux, foldlM_eq_foldlM_toList]; rfl
rw [mapM, aux, foldlM_toList]; rfl
where
aux (i r) :
mapM.map f arr i r = (arr.toList.drop i).foldlM (fun bs a => bs.push <$> f a) r := by
@@ -407,7 +449,7 @@ where
@[simp] theorem toList_map (f : α β) (arr : Array α) : (arr.map f).toList = arr.toList.map f := by
rw [map, mapM_eq_foldlM]
apply congrArg toList (foldl_eq_foldl_toList (fun bs a => push bs (f a)) #[] arr) |>.trans
apply congrArg toList (foldl_toList (fun bs a => push bs (f a)) #[] arr).symm |>.trans
have H (l arr) : List.foldl (fun bs a => push bs (f a)) arr l = arr.toList ++ l.map f := by
induction l generalizing arr <;> simp [*]
simp [H]
@@ -597,38 +639,25 @@ theorem getElem?_mkArray (n : Nat) (v : α) (i : Nat) :
/-- # mem -/
theorem mem_toList {a : α} {l : Array α} : a l.toList a l := mem_def.symm
@[simp] theorem mem_toList {a : α} {l : Array α} : a l.toList a l := mem_def.symm
theorem not_mem_nil (a : α) : ¬ a #[] := nofun
theorem getElem_of_mem {a : α} {as : Array α} :
a as ( (n : Nat) (h : n < as.size), as[n]'h = a) := by
intro ha
rcases List.getElem_of_mem ha.val with i, hbound, hi
exists i
exists hbound
theorem getElem?_of_mem {a : α} {as : Array α} :
a as (n : Nat), as[n]? = some a := by
intro ha
rcases List.getElem?_of_mem ha.val with i, hi
exists i
@[simp] theorem mem_dite_empty_left {x : α} [Decidable p] {l : ¬ p Array α} :
(x if h : p then #[] else l h) h : ¬ p, x l h := by
split <;> simp_all [mem_def]
split <;> simp_all
@[simp] theorem mem_dite_empty_right {x : α} [Decidable p] {l : p Array α} :
(x if h : p then l h else #[]) h : p, x l h := by
split <;> simp_all [mem_def]
split <;> simp_all
@[simp] theorem mem_ite_empty_left {x : α} [Decidable p] {l : Array α} :
(x if p then #[] else l) ¬ p x l := by
split <;> simp_all [mem_def]
split <;> simp_all
@[simp] theorem mem_ite_empty_right {x : α} [Decidable p] {l : Array α} :
(x if p then l else #[]) p x l := by
split <;> simp_all [mem_def]
split <;> simp_all
/-- # get lemmas -/
@@ -655,10 +684,6 @@ theorem get?_eq_get?_toList (a : Array α) (i : Nat) : a.get? i = a.toList.get?
theorem get!_eq_get? [Inhabited α] (a : Array α) : a.get! n = (a.get? n).getD default := by
simp only [get!_eq_getElem?, get?_eq_getElem?]
theorem getElem?_eq_some_iff {as : Array α} : as[n]? = some a h : n < as.size, as[n] = a := by
cases as
simp [List.getElem?_eq_some_iff]
theorem back!_eq_back? [Inhabited α] (a : Array α) : a.back! = a.back?.getD default := by
simp only [back!, get!_eq_getElem?, get?_eq_getElem?, back?]
@@ -668,6 +693,10 @@ theorem back!_eq_back? [Inhabited α] (a : Array α) : a.back! = a.back?.getD de
@[simp] theorem back!_push [Inhabited α] (a : Array α) : (a.push x).back! = x := by
simp [back!_eq_back?]
theorem mem_of_back?_eq_some {xs : Array α} {a : α} (h : xs.back? = some a) : a xs := by
cases xs
simpa using List.mem_of_getLast?_eq_some (by simpa using h)
theorem getElem?_push_lt (a : Array α) (x : α) (i : Nat) (h : i < a.size) :
(a.push x)[i]? = some a[i] := by
rw [getElem?_pos, getElem_push_lt]
@@ -1021,9 +1050,13 @@ theorem foldr_congr {as bs : Array α} (h₀ : as = bs) {f g : α → β → β}
@[simp] theorem mem_map {f : α β} {l : Array α} : b l.map f a, a l f a = b := by
simp only [mem_def, toList_map, List.mem_map]
theorem exists_of_mem_map (h : b map f l) : a, a l f a = b := mem_map.1 h
theorem mem_map_of_mem (f : α β) (h : a l) : f a map f l := mem_map.2 _, h, rfl
theorem mapM_eq_mapM_toList [Monad m] [LawfulMonad m] (f : α m β) (arr : Array α) :
arr.mapM f = List.toArray <$> (arr.toList.mapM f) := by
rw [mapM_eq_foldlM, foldlM_eq_foldlM_toList, List.foldrM_reverse]
rw [mapM_eq_foldlM, foldlM_toList, List.foldrM_reverse]
conv => rhs; rw [ List.reverse_reverse arr.toList]
induction arr.toList.reverse with
| nil => simp
@@ -1148,7 +1181,7 @@ theorem getElem?_modify {as : Array α} {i : Nat} {f : αα} {j : Nat} :
@[simp] theorem toList_filter (p : α Bool) (l : Array α) :
(l.filter p).toList = l.toList.filter p := by
dsimp only [filter]
rw [foldl_eq_foldl_toList]
rw [ foldl_toList]
generalize l.toList = l
suffices a, (List.foldl (fun r a => if p a = true then push r a else r) a l).toList =
a.toList ++ List.filter p l by
@@ -1179,7 +1212,7 @@ theorem filter_congr {as bs : Array α} (h : as = bs)
@[simp] theorem toList_filterMap (f : α Option β) (l : Array α) :
(l.filterMap f).toList = l.toList.filterMap f := by
dsimp only [filterMap, filterMapM]
rw [foldlM_eq_foldlM_toList]
rw [ foldlM_toList]
generalize l.toList = l
have this : a : Array β, (Id.run (List.foldlM (m := Id) ?_ a l)).toList =
a.toList ++ List.filterMap f l := ?_
@@ -1211,9 +1244,23 @@ theorem push_eq_append_singleton (as : Array α) (x) : as.push x = as ++ #[x] :=
@[simp] theorem mem_append {a : α} {s t : Array α} : a s ++ t a s a t := by
simp only [mem_def, toList_append, List.mem_append]
theorem mem_append_left {a : α} {l₁ : Array α} (l₂ : Array α) (h : a l₁) : a l₁ ++ l₂ :=
mem_append.2 (Or.inl h)
theorem mem_append_right {a : α} (l₁ : Array α) {l₂ : Array α} (h : a l₂) : a l₁ ++ l₂ :=
mem_append.2 (Or.inr h)
@[simp] theorem size_append (as bs : Array α) : (as ++ bs).size = as.size + bs.size := by
simp only [size, toList_append, List.length_append]
@[simp] theorem empty_append (as : Array α) : #[] ++ as = as := by
cases as
simp
@[simp] theorem append_empty (as : Array α) : as ++ #[] = as := by
cases as
simp
theorem getElem_append {as bs : Array α} (h : i < (as ++ bs).size) :
(as ++ bs)[i] = if h' : i < as.size then as[i] else bs[i - as.size]'(by simp at h; omega) := by
cases as; cases bs
@@ -1258,7 +1305,7 @@ theorem getElem?_append {as bs : Array α} {n : Nat} :
@[simp] theorem toList_flatten {l : Array (Array α)} :
l.flatten.toList = (l.toList.map toList).flatten := by
dsimp [flatten]
simp only [foldl_eq_foldl_toList]
simp only [ foldl_toList]
generalize l.toList = l
have : a : Array α, (List.foldl ?_ a l).toList = a.toList ++ ?_ := ?_
exact this #[]
@@ -1872,6 +1919,76 @@ namespace Array
induction as
simp
/-! ### map -/
@[simp] theorem map_map {f : α β} {g : β γ} {as : Array α} :
(as.map f).map g = as.map (g f) := by
cases as; simp
@[simp] theorem map_id_fun : map (id : α α) = id := by
funext l
induction l <;> simp_all
/-- `map_id_fun'` differs from `map_id_fun` by representing the identity function as a lambda, rather than `id`. -/
@[simp] theorem map_id_fun' : map (fun (a : α) => a) = id := map_id_fun
-- This is not a `@[simp]` lemma because `map_id_fun` will apply.
theorem map_id (as : Array α) : map (id : α α) as = as := by
cases as <;> simp_all
/-- `map_id'` differs from `map_id` by representing the identity function as a lambda, rather than `id`. -/
-- This is not a `@[simp]` lemma because `map_id_fun'` will apply.
theorem map_id' (as : Array α) : map (fun (a : α) => a) as = as := map_id as
/-- Variant of `map_id`, with a side condition that the function is pointwise the identity. -/
theorem map_id'' {f : α α} (h : x, f x = x) (as : Array α) : map f as = as := by
simp [show f = id from funext h]
theorem array_array_induction (P : Array (Array α) Prop) (h : (xss : List (List α)), P (xss.map List.toArray).toArray)
(ass : Array (Array α)) : P ass := by
specialize h (ass.toList.map toList)
simpa [ toList_map, Function.comp_def, map_id] using h
theorem foldl_map (f : β₁ β₂) (g : α β₂ α) (l : Array β₁) (init : α) :
(l.map f).foldl g init = l.foldl (fun x y => g x (f y)) init := by
cases l; simp [List.foldl_map]
theorem foldr_map (f : α₁ α₂) (g : α₂ β β) (l : Array α₁) (init : β) :
(l.map f).foldr g init = l.foldr (fun x y => g (f x) y) init := by
cases l; simp [List.foldr_map]
theorem foldl_filterMap (f : α Option β) (g : γ β γ) (l : Array α) (init : γ) :
(l.filterMap f).foldl g init = l.foldl (fun x y => match f y with | some b => g x b | none => x) init := by
cases l
simp [List.foldl_filterMap]
rfl
theorem foldr_filterMap (f : α Option β) (g : β γ γ) (l : Array α) (init : γ) :
(l.filterMap f).foldr g init = l.foldr (fun x y => match f x with | some b => g b y | none => y) init := by
cases l
simp [List.foldr_filterMap]
rfl
/-! ### flatten -/
@[simp] theorem flatten_empty : flatten (#[] : Array (Array α)) = #[] := rfl
@[simp] theorem flatten_toArray_map_toArray (xss : List (List α)) :
(xss.map List.toArray).toArray.flatten = xss.flatten.toArray := by
simp [flatten]
suffices as, List.foldl (fun r a => r ++ a) as (List.map List.toArray xss) = as ++ xss.flatten.toArray by
simpa using this #[]
intro as
induction xss generalizing as with
| nil => simp
| cons xs xss ih => simp [ih]
/-! ### reverse -/
@[simp] theorem mem_reverse {x : α} {as : Array α} : x as.reverse x as := by
cases as
simp
/-! ### findSomeRevM?, findRevM?, findSomeRev?, findRev? -/
@[simp] theorem findSomeRevM?_eq_findSomeM?_reverse
@@ -1936,6 +2053,27 @@ namespace Array
cases as
simp
@[simp] theorem flatMap_empty {β} (f : α Array β) : (#[] : Array α).flatMap f = #[] := rfl
@[simp] theorem flatMap_toArray_cons {β} (f : α Array β) (a : α) (as : List α) :
(a :: as).toArray.flatMap f = f a ++ as.toArray.flatMap f := by
simp [flatMap]
suffices cs, List.foldl (fun bs a => bs ++ f a) (f a ++ cs) as =
f a ++ List.foldl (fun bs a => bs ++ f a) cs as by
erw [empty_append] -- Why doesn't this work via `simp`?
simpa using this #[]
intro cs
induction as generalizing cs <;> simp_all
@[simp] theorem flatMap_toArray {β} (f : α Array β) (as : List α) :
as.toArray.flatMap f = (as.flatMap (fun a => (f a).toList)).toArray := by
induction as with
| nil => simp
| cons a as ih =>
apply ext'
simp [ih]
end Array
/-! ### Deprecations -/

View File

@@ -0,0 +1,159 @@
/-
Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kim Morrison
-/
prelude
import Init.Data.Array.Lemmas
import Init.Data.Array.Attach
import Init.Data.List.Monadic
/-!
# Lemmas about `Array.forIn'` and `Array.forIn`.
-/
namespace Array
open Nat
/-! ## Monadic operations -/
/-! ### mapM -/
theorem mapM_eq_foldlM_push [Monad m] [LawfulMonad m] (f : α m β) (l : Array α) :
mapM f l = l.foldlM (fun acc a => return (acc.push ( f a))) #[] := by
rcases l with l
simp only [List.mapM_toArray, bind_pure_comp, size_toArray, List.foldlM_toArray']
rw [List.mapM_eq_reverse_foldlM_cons]
simp only [bind_pure_comp, Functor.map_map]
suffices (k), (fun a => a.reverse.toArray) <$> List.foldlM (fun acc a => (fun a => a :: acc) <$> f a) k l =
List.foldlM (fun acc a => acc.push <$> f a) k.reverse.toArray l by
exact this []
intro k
induction l generalizing k with
| nil => simp
| cons a as ih =>
simp [ih, List.foldlM_cons]
/-! ### foldlM and foldrM -/
theorem foldlM_map [Monad m] (f : β₁ β₂) (g : α β₂ m α) (l : Array β₁) (init : α) :
(l.map f).foldlM g init = l.foldlM (fun x y => g x (f y)) init := by
cases l
rw [List.map_toArray] -- Why doesn't this fire via `simp`?
simp [List.foldlM_map]
theorem foldrM_map [Monad m] [LawfulMonad m] (f : β₁ β₂) (g : β₂ α m α) (l : Array β₁)
(init : α) : (l.map f).foldrM g init = l.foldrM (fun x y => g (f x) y) init := by
cases l
rw [List.map_toArray] -- Why doesn't this fire via `simp`?
simp [List.foldrM_map]
theorem foldlM_filterMap [Monad m] [LawfulMonad m] (f : α Option β) (g : γ β m γ) (l : Array α) (init : γ) :
(l.filterMap f).foldlM g init =
l.foldlM (fun x y => match f y with | some b => g x b | none => pure x) init := by
cases l
rw [List.filterMap_toArray] -- Why doesn't this fire via `simp`?
simp [List.foldlM_filterMap]
rfl
theorem foldrM_filterMap [Monad m] [LawfulMonad m] (f : α Option β) (g : β γ m γ) (l : Array α) (init : γ) :
(l.filterMap f).foldrM g init =
l.foldrM (fun x y => match f x with | some b => g b y | none => pure y) init := by
cases l
rw [List.filterMap_toArray] -- Why doesn't this fire via `simp`?
simp [List.foldrM_filterMap]
rfl
theorem foldlM_filter [Monad m] [LawfulMonad m] (p : α Bool) (g : β α m β) (l : Array α) (init : β) :
(l.filter p).foldlM g init =
l.foldlM (fun x y => if p y then g x y else pure x) init := by
cases l
rw [List.filter_toArray] -- Why doesn't this fire via `simp`?
simp [List.foldlM_filter]
theorem foldrM_filter [Monad m] [LawfulMonad m] (p : α Bool) (g : α β m β) (l : Array α) (init : β) :
(l.filter p).foldrM g init =
l.foldrM (fun x y => if p x then g x y else pure y) init := by
cases l
rw [List.filter_toArray] -- Why doesn't this fire via `simp`?
simp [List.foldrM_filter]
/-! ### forIn' -/
/--
We can express a for loop over an array as a fold,
in which whenever we reach `.done b` we keep that value through the rest of the fold.
-/
theorem forIn'_eq_foldlM [Monad m] [LawfulMonad m]
(l : Array α) (f : (a : α) a l β m (ForInStep β)) (init : β) :
forIn' l init f = ForInStep.value <$>
l.attach.foldlM (fun b a, m => match b with
| .yield b => f a m b
| .done b => pure (.done b)) (ForInStep.yield init) := by
cases l
rw [List.attach_toArray] -- Why doesn't this fire via `simp`?
simp only [List.forIn'_toArray, List.forIn'_eq_foldlM, List.attachWith_mem_toArray, size_toArray,
List.length_map, List.length_attach, List.foldlM_toArray', List.foldlM_map]
congr
/-- We can express a for loop over an array which always yields as a fold. -/
@[simp] theorem forIn'_yield_eq_foldlM [Monad m] [LawfulMonad m]
(l : Array α) (f : (a : α) a l β m γ) (g : (a : α) a l β γ β) (init : β) :
forIn' l init (fun a m b => (fun c => .yield (g a m b c)) <$> f a m b) =
l.attach.foldlM (fun b a, m => g a m b <$> f a m b) init := by
cases l
rw [List.attach_toArray] -- Why doesn't this fire via `simp`?
simp [List.foldlM_map]
theorem forIn'_pure_yield_eq_foldl [Monad m] [LawfulMonad m]
(l : Array α) (f : (a : α) a l β β) (init : β) :
forIn' l init (fun a m b => pure (.yield (f a m b))) =
pure (f := m) (l.attach.foldl (fun b a, h => f a h b) init) := by
cases l
simp [List.forIn'_pure_yield_eq_foldl, List.foldl_map]
@[simp] theorem forIn'_yield_eq_foldl
(l : Array α) (f : (a : α) a l β β) (init : β) :
forIn' (m := Id) l init (fun a m b => .yield (f a m b)) =
l.attach.foldl (fun b a, h => f a h b) init := by
cases l
simp [List.foldl_map]
/--
We can express a for loop over an array as a fold,
in which whenever we reach `.done b` we keep that value through the rest of the fold.
-/
theorem forIn_eq_foldlM [Monad m] [LawfulMonad m]
(f : α β m (ForInStep β)) (init : β) (l : Array α) :
forIn l init f = ForInStep.value <$>
l.foldlM (fun b a => match b with
| .yield b => f a b
| .done b => pure (.done b)) (ForInStep.yield init) := by
cases l
simp only [List.forIn_toArray, List.forIn_eq_foldlM, size_toArray, List.foldlM_toArray']
congr
/-- We can express a for loop over an array which always yields as a fold. -/
@[simp] theorem forIn_yield_eq_foldlM [Monad m] [LawfulMonad m]
(l : Array α) (f : α β m γ) (g : α β γ β) (init : β) :
forIn l init (fun a b => (fun c => .yield (g a b c)) <$> f a b) =
l.foldlM (fun b a => g a b <$> f a b) init := by
cases l
simp [List.foldlM_map]
theorem forIn_pure_yield_eq_foldl [Monad m] [LawfulMonad m]
(l : Array α) (f : α β β) (init : β) :
forIn l init (fun a b => pure (.yield (f a b))) =
pure (f := m) (l.foldl (fun b a => f a b) init) := by
cases l
simp [List.forIn_pure_yield_eq_foldl, List.foldl_map]
@[simp] theorem forIn_yield_eq_foldl
(l : Array α) (f : α β β) (init : β) :
forIn (m := Id) l init (fun a b => .yield (f a b)) =
l.foldl (fun b a => f a b) init := by
cases l
simp [List.foldl_map]
end Array

View File

@@ -15,15 +15,6 @@ structure Subarray (α : Type u) where
start_le_stop : start stop
stop_le_array_size : stop array.size
@[deprecated Subarray.array (since := "2024-04-13")]
abbrev Subarray.as (s : Subarray α) : Array α := s.array
@[deprecated Subarray.start_le_stop (since := "2024-04-13")]
theorem Subarray.h₁ (s : Subarray α) : s.start s.stop := s.start_le_stop
@[deprecated Subarray.stop_le_array_size (since := "2024-04-13")]
theorem Subarray.h₂ (s : Subarray α) : s.stop s.array.size := s.stop_le_array_size
namespace Subarray
def size (s : Subarray α) : Nat :=

View File

@@ -29,9 +29,6 @@ section Nat
instance natCastInst : NatCast (BitVec w) := BitVec.ofNat w
@[deprecated isLt (since := "2024-03-12")]
theorem toNat_lt (x : BitVec n) : x.toNat < 2^n := x.isLt
/-- Theorem for normalizing the bit vector literal representation. -/
-- TODO: This needs more usage data to assess which direction the simp should go.
@[simp, bv_toNat] theorem ofNat_eq_ofNat : @OfNat.ofNat (BitVec n) i _ = .ofNat n i := rfl

View File

@@ -403,7 +403,7 @@ theorem getLsbD_neg {i : Nat} {x : BitVec w} :
rw [carry_succ_one _ _ (by omega), Bool.xor_not, decide_not]
simp only [add_one_ne_zero, decide_false, getLsbD_not, and_eq_true, decide_eq_true_eq,
not_eq_eq_eq_not, Bool.not_true, false_bne, not_exists, _root_.not_and, not_eq_true,
bne_left_inj, decide_eq_decide]
bne_right_inj, decide_eq_decide]
constructor
· rintro h j hj; exact And.right <| h j (by omega)
· rintro h j hj; exact by omega, h j (by omega)
@@ -419,7 +419,7 @@ theorem getMsbD_neg {i : Nat} {x : BitVec w} :
simp [hi]; omega
case pos =>
have h₁ : w - 1 - i < w := by omega
simp only [hi, decide_true, h₁, Bool.true_and, Bool.bne_left_inj, decide_eq_decide]
simp only [hi, decide_true, h₁, Bool.true_and, Bool.bne_right_inj, decide_eq_decide]
constructor
· rintro j, hj, h
refine w - 1 - j, by omega, by omega, by omega, _root_.cast ?_ h

View File

@@ -238,8 +238,8 @@ theorem not_bne_not : ∀ (x y : Bool), ((!x) != (!y)) = (x != y) := by simp
@[simp] theorem bne_assoc : (x y z : Bool), ((x != y) != z) = (x != (y != z)) := by decide
instance : Std.Associative (· != ·) := bne_assoc
@[simp] theorem bne_left_inj : {x y z : Bool}, (x != y) = (x != z) y = z := by decide
@[simp] theorem bne_right_inj : {x y z : Bool}, (x != z) = (y != z) x = y := by decide
@[simp] theorem bne_right_inj : {x y z : Bool}, (x != y) = (x != z) y = z := by decide
@[simp] theorem bne_left_inj : {x y z : Bool}, (x != z) = (y != z) x = y := by decide
theorem eq_not_of_ne : {x y : Bool}, x y x = !y := by decide
@@ -295,9 +295,9 @@ theorem xor_right_comm : ∀ (x y z : Bool), ((x ^^ y) ^^ z) = ((x ^^ z) ^^ y) :
theorem xor_assoc : (x y z : Bool), ((x ^^ y) ^^ z) = (x ^^ (y ^^ z)) := bne_assoc
theorem xor_left_inj : {x y z : Bool}, (x ^^ y) = (x ^^ z) y = z := bne_left_inj
theorem xor_right_inj : {x y z : Bool}, (x ^^ y) = (x ^^ z) y = z := bne_right_inj
theorem xor_right_inj : {x y z : Bool}, (x ^^ z) = (y ^^ z) x = y := bne_right_inj
theorem xor_left_inj : {x y z : Bool}, (x ^^ z) = (y ^^ z) x = y := bne_left_inj
/-! ### le/lt -/

View File

@@ -642,7 +642,7 @@ theorem pred_add_one (i : Fin (n + 2)) (h : (i : Nat) < n + 1) :
ext
simp
@[simp] theorem subNat_one_succ (i : Fin (n + 1)) (h : 1 i) : (subNat 1 i h).succ = i := by
@[simp] theorem subNat_one_succ (i : Fin (n + 1)) (h : 1 (i : Nat)) : (subNat 1 i h).succ = i := by
ext
simp
omega

View File

@@ -47,6 +47,25 @@ def Float.lt : Float → Float → Prop := fun a b =>
def Float.le : Float Float Prop := fun a b =>
floatSpec.le a.val b.val
/--
Raw transmutation from `UInt64`.
Floats and UInts have the same endianness on all supported platforms.
IEEE 754 very precisely specifies the bit layout of floats.
-/
@[extern "lean_float_of_bits"] opaque Float.ofBits : UInt64 Float
/--
Raw transmutation to `UInt64`.
Floats and UInts have the same endianness on all supported platforms.
IEEE 754 very precisely specifies the bit layout of floats.
Note that this function is distinct from `Float.toUInt64`, which attempts
to preserve the numeric value, and not the bitwise value.
-/
@[extern "lean_float_to_bits"] opaque Float.toBits : Float UInt64
instance : Add Float := Float.add
instance : Sub Float := Float.sub
instance : Mul Float := Float.mul

View File

@@ -329,22 +329,22 @@ theorem toNat_sub (m n : Nat) : toNat (m - n) = m - n := by
/- ## add/sub injectivity -/
@[simp]
protected theorem add_right_inj {i j : Int} (k : Int) : (i + k = j + k) i = j := by
protected theorem add_left_inj {i j : Int} (k : Int) : (i + k = j + k) i = j := by
apply Iff.intro
· intro p
rw [Int.add_sub_cancel i k, Int.add_sub_cancel j k, p]
· exact congrArg (· + k)
@[simp]
protected theorem add_left_inj {i j : Int} (k : Int) : (k + i = k + j) i = j := by
protected theorem add_right_inj {i j : Int} (k : Int) : (k + i = k + j) i = j := by
simp [Int.add_comm k]
@[simp]
protected theorem sub_left_inj {i j : Int} (k : Int) : (k - i = k - j) i = j := by
protected theorem sub_right_inj {i j : Int} (k : Int) : (k - i = k - j) i = j := by
simp [Int.sub_eq_add_neg, Int.neg_inj]
@[simp]
protected theorem sub_right_inj {i j : Int} (k : Int) : (i - k = j - k) i = j := by
protected theorem sub_left_inj {i j : Int} (k : Int) : (i - k = j - k) i = j := by
simp [Int.sub_eq_add_neg]
/- ## Ring properties -/

View File

@@ -13,7 +13,7 @@ namespace List
`a : α` satisfying `P`, then `pmap f l h` is essentially the same as `map f l`
but is defined only when all members of `l` satisfy `P`, using the proof
to apply `f`. -/
@[simp] def pmap {P : α Prop} (f : a, P a β) : l : List α, (H : a l, P a) List β
def pmap {P : α Prop} (f : a, P a β) : l : List α, (H : a l, P a) List β
| [], _ => []
| a :: l, H => f a (forall_mem_cons.1 H).1 :: pmap f l (forall_mem_cons.1 H).2
@@ -46,6 +46,11 @@ Unsafe implementation of `attachWith`, taking advantage of the fact that the rep
| cons _ L', hL' => congrArg _ <| go L' fun _ hx => hL' (.tail _ hx)
exact go L h'
@[simp] theorem pmap_nil {P : α Prop} (f : a, P a β) : pmap f [] (by simp) = [] := rfl
@[simp] theorem pmap_cons {P : α Prop} (f : a, P a β) (a : α) (l : List α) (h : b a :: l, P b) :
pmap f (a :: l) h = f a (forall_mem_cons.1 h).1 :: pmap f l (forall_mem_cons.1 h).2 := rfl
@[simp] theorem attach_nil : ([] : List α).attach = [] := rfl
@[simp] theorem attachWith_nil : ([] : List α).attachWith P H = [] := rfl
@@ -148,7 +153,7 @@ theorem mem_pmap_of_mem {p : α → Prop} {f : ∀ a, p a → β} {l H} {a} (h :
exact a, h, rfl
@[simp]
theorem length_pmap {p : α Prop} {f : a, p a β} {l H} : length (pmap f l H) = length l := by
theorem length_pmap {p : α Prop} {f : a, p a β} {l H} : (pmap f l H).length = l.length := by
induction l
· rfl
· simp only [*, pmap, length]
@@ -199,7 +204,7 @@ theorem attachWith_ne_nil_iff {l : List α} {P : α → Prop} {H : ∀ a ∈ l,
@[simp]
theorem getElem?_pmap {p : α Prop} (f : a, p a β) {l : List α} (h : a l, p a) (n : Nat) :
(pmap f l h)[n]? = Option.pmap f l[n]? fun x H => h x (getElem?_mem H) := by
(pmap f l h)[n]? = Option.pmap f l[n]? fun x H => h x (mem_of_getElem? H) := by
induction l generalizing n with
| nil => simp
| cons hd tl hl =>
@@ -215,7 +220,7 @@ theorem getElem?_pmap {p : α → Prop} (f : ∀ a, p a → β) {l : List α} (h
· simp_all
theorem get?_pmap {p : α Prop} (f : a, p a β) {l : List α} (h : a l, p a) (n : Nat) :
get? (pmap f l h) n = Option.pmap f (get? l n) fun x H => h x (get?_mem H) := by
get? (pmap f l h) n = Option.pmap f (get? l n) fun x H => h x (mem_of_get? H) := by
simp only [get?_eq_getElem?]
simp [getElem?_pmap, h]
@@ -238,18 +243,18 @@ theorem get_pmap {p : α → Prop} (f : ∀ a, p a → β) {l : List α} (h :
(hn : n < (pmap f l h).length) :
get (pmap f l h) n, hn =
f (get l n, @length_pmap _ _ p f l h hn)
(h _ (get_mem l n (@length_pmap _ _ p f l h hn))) := by
(h _ (getElem_mem (@length_pmap _ _ p f l h hn))) := by
simp only [get_eq_getElem]
simp [getElem_pmap]
@[simp]
theorem getElem?_attachWith {xs : List α} {i : Nat} {P : α Prop} {H : a xs, P a} :
(xs.attachWith P H)[i]? = xs[i]?.pmap Subtype.mk (fun _ a => H _ (getElem?_mem a)) :=
(xs.attachWith P H)[i]? = xs[i]?.pmap Subtype.mk (fun _ a => H _ (mem_of_getElem? a)) :=
getElem?_pmap ..
@[simp]
theorem getElem?_attach {xs : List α} {i : Nat} :
xs.attach[i]? = xs[i]?.pmap Subtype.mk (fun _ a => getElem?_mem a) :=
xs.attach[i]? = xs[i]?.pmap Subtype.mk (fun _ a => mem_of_getElem? a) :=
getElem?_attachWith
@[simp]
@@ -333,6 +338,7 @@ This is useful when we need to use `attach` to show termination.
Unfortunately this can't be applied by `simp` because of the higher order unification problem,
and even when rewriting we need to specify the function explicitly.
See however `foldl_subtype` below.
-/
theorem foldl_attach (l : List α) (f : β α β) (b : β) :
l.attach.foldl (fun acc t => f acc t.1) b = l.foldl f b := by
@@ -348,6 +354,7 @@ This is useful when we need to use `attach` to show termination.
Unfortunately this can't be applied by `simp` because of the higher order unification problem,
and even when rewriting we need to specify the function explicitly.
See however `foldr_subtype` below.
-/
theorem foldr_attach (l : List α) (f : α β β) (b : β) :
l.attach.foldr (fun t acc => f t.1 acc) b = l.foldr f b := by
@@ -452,16 +459,16 @@ theorem pmap_append' {p : α → Prop} (f : ∀ a : α, p a → β) (l₁ l₂ :
pmap_append f l₁ l₂ _
@[simp] theorem attach_append (xs ys : List α) :
(xs ++ ys).attach = xs.attach.map (fun x, h => x, mem_append_of_mem_left ys h) ++
ys.attach.map fun x, h => x, mem_append_of_mem_right xs h := by
(xs ++ ys).attach = xs.attach.map (fun x, h => x, mem_append_left ys h) ++
ys.attach.map fun x, h => x, mem_append_right xs h := by
simp only [attach, attachWith, pmap, map_pmap, pmap_append]
congr 1 <;>
exact pmap_congr_left _ fun _ _ _ _ => rfl
@[simp] theorem attachWith_append {P : α Prop} {xs ys : List α}
{H : (a : α), a xs ++ ys P a} :
(xs ++ ys).attachWith P H = xs.attachWith P (fun a h => H a (mem_append_of_mem_left ys h)) ++
ys.attachWith P (fun a h => H a (mem_append_of_mem_right xs h)) := by
(xs ++ ys).attachWith P H = xs.attachWith P (fun a h => H a (mem_append_left ys h)) ++
ys.attachWith P (fun a h => H a (mem_append_right xs h)) := by
simp only [attachWith, attach_append, map_pmap, pmap_append]
@[simp] theorem pmap_reverse {P : α Prop} (f : (a : α) P a β) (xs : List α)
@@ -598,6 +605,15 @@ def unattach {α : Type _} {p : α → Prop} (l : List { x // p x }) := l.map (
| nil => simp
| cons a l ih => simp [ih, Function.comp_def]
@[simp] theorem getElem?_unattach {p : α Prop} {l : List { x // p x }} (i : Nat) :
l.unattach[i]? = l[i]?.map Subtype.val := by
simp [unattach]
@[simp] theorem getElem_unattach
{p : α Prop} {l : List { x // p x }} (i : Nat) (h : i < l.unattach.length) :
l.unattach[i] = (l[i]'(by simpa using h)).1 := by
simp [unattach]
/-! ### Recognizing higher order functions on subtypes using a function that only depends on the value. -/
/--

View File

@@ -551,7 +551,7 @@ theorem reverseAux_eq_append (as bs : List α) : reverseAux as bs = reverseAux a
/-! ### flatten -/
/--
`O(|flatten L|)`. `join L` concatenates all the lists in `L` into one list.
`O(|flatten L|)`. `flatten L` concatenates all the lists in `L` into one list.
* `flatten [[a], [], [b, c], [d, e, f]] = [a, b, c, d, e, f]`
-/
def flatten : List (List α) List α
@@ -726,13 +726,13 @@ theorem elem_eq_true_of_mem [BEq α] [LawfulBEq α] {a : α} {as : List α} (h :
instance [BEq α] [LawfulBEq α] (a : α) (as : List α) : Decidable (a as) :=
decidable_of_decidable_of_iff (Iff.intro mem_of_elem_eq_true elem_eq_true_of_mem)
theorem mem_append_of_mem_left {a : α} {as : List α} (bs : List α) : a as a as ++ bs := by
theorem mem_append_left {a : α} {as : List α} (bs : List α) : a as a as ++ bs := by
intro h
induction h with
| head => apply Mem.head
| tail => apply Mem.tail; assumption
theorem mem_append_of_mem_right {b : α} {bs : List α} (as : List α) : b bs b as ++ bs := by
theorem mem_append_right {b : α} {bs : List α} (as : List α) : b bs b as ++ bs := by
intro h
induction as with
| nil => simp [h]

View File

@@ -256,7 +256,7 @@ theorem findM?_eq_findSomeM? [Monad m] [LawfulMonad m] (p : α → m Bool) (as :
have : a as := by
have bs, h := h
subst h
exact mem_append_of_mem_right _ (Mem.head ..)
exact mem_append_right _ (Mem.head ..)
match ( f a this b) with
| ForInStep.done b => pure b
| ForInStep.yield b =>

View File

@@ -91,7 +91,7 @@ The following operations are given `@[csimp]` replacements below:
@[specialize] def foldrTR (f : α β β) (init : β) (l : List α) : β := l.toArray.foldr f init
@[csimp] theorem foldr_eq_foldrTR : @foldr = @foldrTR := by
funext α β f init l; simp [foldrTR, Array.foldr_eq_foldr_toList, -Array.size_toArray]
funext α β f init l; simp [foldrTR, Array.foldr_toList, -Array.size_toArray]
/-! ### flatMap -/
@@ -331,7 +331,7 @@ def enumFromTR (n : Nat) (l : List α) : List (Nat × α) :=
| a::as, n => by
rw [ show _ + as.length = n + (a::as).length from Nat.succ_add .., foldr, go as]
simp [enumFrom, f]
rw [Array.foldr_eq_foldr_toList]
rw [ Array.foldr_toList]
simp [go]
/-! ## Other list operations -/

View File

@@ -372,6 +372,17 @@ theorem getElem?_concat_length (l : List α) (a : α) : (l ++ [a])[l.length]? =
@[deprecated getElem?_concat_length (since := "2024-06-12")]
theorem get?_concat_length (l : List α) (a : α) : (l ++ [a]).get? l.length = some a := by simp
@[simp] theorem isSome_getElem? {l : List α} {n : Nat} : l[n]?.isSome n < l.length := by
by_cases h : n < l.length
· simp_all
· simp [h]
simp_all
@[simp] theorem isNone_getElem? {l : List α} {n : Nat} : l[n]?.isNone l.length n := by
by_cases h : n < l.length
· simp_all
· simp [h]
/-! ### mem -/
@[simp] theorem not_mem_nil (a : α) : ¬ a [] := nofun
@@ -383,9 +394,9 @@ theorem get?_concat_length (l : List α) (a : α) : (l ++ [a]).get? l.length = s
theorem mem_cons_self (a : α) (l : List α) : a a :: l := .head ..
theorem mem_concat_self (xs : List α) (a : α) : a xs ++ [a] :=
mem_append_of_mem_right xs (mem_cons_self a _)
mem_append_right xs (mem_cons_self a _)
theorem mem_append_cons_self : a xs ++ a :: ys := mem_append_of_mem_right _ (mem_cons_self _ _)
theorem mem_append_cons_self : a xs ++ a :: ys := mem_append_right _ (mem_cons_self _ _)
theorem eq_append_cons_of_mem {a : α} {xs : List α} (h : a xs) :
as bs, xs = as ++ a :: bs a as := by
@@ -492,16 +503,20 @@ theorem getElem?_of_mem {a} {l : List α} (h : a ∈ l) : ∃ n : Nat, l[n]? = s
theorem get?_of_mem {a} {l : List α} (h : a l) : n, l.get? n = some a :=
let n, _, e := get_of_mem h; n, e get?_eq_get _
theorem get_mem : (l : List α) n h, get l n, h l
| _ :: _, 0, _ => .head ..
| _ :: l, _+1, _ => .tail _ (get_mem l ..)
theorem get_mem : (l : List α) n, get l n l
| _ :: _, 0, _ => .head ..
| _ :: l, _+1, _ => .tail _ (get_mem l ..)
theorem getElem?_mem {l : List α} {n : Nat} {a : α} (e : l[n]? = some a) : a l :=
theorem mem_of_getElem? {l : List α} {n : Nat} {a : α} (e : l[n]? = some a) : a l :=
let _, e := getElem?_eq_some_iff.1 e; e getElem_mem ..
theorem get?_mem {l : List α} {n a} (e : l.get? n = some a) : a l :=
@[deprecated mem_of_getElem? (since := "2024-09-06")] abbrev getElem?_mem := @mem_of_getElem?
theorem mem_of_get? {l : List α} {n a} (e : l.get? n = some a) : a l :=
let _, e := get?_eq_some.1 e; e get_mem ..
@[deprecated mem_of_get? (since := "2024-09-06")] abbrev get?_mem := @mem_of_get?
theorem mem_iff_getElem {a} {l : List α} : a l (n : Nat) (h : n < l.length), l[n]'h = a :=
getElem_of_mem, fun _, _, e => e getElem_mem ..
@@ -1025,6 +1040,10 @@ theorem getLast_eq_getElem : ∀ (l : List α) (h : l ≠ []),
| _ :: _ :: _, _ => by
simp [getLast, get, Nat.succ_sub_succ, getLast_eq_getElem]
theorem getElem_length_sub_one_eq_getLast (l : List α) (h) :
l[l.length - 1] = getLast l (by cases l; simp at h; simp) := by
rw [ getLast_eq_getElem]
@[deprecated getLast_eq_getElem (since := "2024-07-15")]
theorem getLast_eq_get (l : List α) (h : l []) :
getLast l h = l.get l.length - 1, by
@@ -1149,6 +1168,11 @@ theorem head_eq_getElem (l : List α) (h : l ≠ []) : head l h = l[0]'(length_p
| nil => simp at h
| cons _ _ => simp
theorem getElem_zero_eq_head (l : List α) (h) : l[0] = head l (by simpa [length_pos] using h) := by
cases l with
| nil => simp at h
| cons _ _ => simp
theorem head_eq_iff_head?_eq_some {xs : List α} (h) : xs.head h = a xs.head? = some a := by
cases xs with
| nil => simp at h
@@ -1977,11 +2001,8 @@ theorem not_mem_append {a : α} {s t : List α} (h₁ : a ∉ s) (h₂ : a ∉ t
theorem mem_append_eq (a : α) (s t : List α) : (a s ++ t) = (a s a t) :=
propext mem_append
theorem mem_append_left {a : α} {l₁ : List α} (l₂ : List α) (h : a l₁) : a l₁ ++ l₂ :=
mem_append.2 (Or.inl h)
theorem mem_append_right {a : α} (l₁ : List α) {l₂ : List α} (h : a l₂) : a l₁ ++ l₂ :=
mem_append.2 (Or.inr h)
@[deprecated mem_append_left (since := "2024-11-20")] abbrev mem_append_of_mem_left := @mem_append_left
@[deprecated mem_append_right (since := "2024-11-20")] abbrev mem_append_of_mem_right := @mem_append_right
theorem mem_iff_append {a : α} {l : List α} : a l s t : List α, l = s ++ a :: t :=
append_of_mem, fun s, t, e => e by simp
@@ -2395,7 +2416,7 @@ theorem forall_mem_replicate {p : α → Prop} {a : α} {n} :
@[simp] theorem getElem_replicate (a : α) {n : Nat} {m} (h : m < (replicate n a).length) :
(replicate n a)[m] = a :=
eq_of_mem_replicate (get_mem _ _ _)
eq_of_mem_replicate (getElem_mem _)
@[deprecated getElem_replicate (since := "2024-06-12")]
theorem get_replicate (a : α) {n : Nat} (m : Fin _) : (replicate n a).get m = a := by

View File

@@ -417,7 +417,7 @@ theorem Sublist.of_sublist_append_left (w : ∀ a, a ∈ l → a ∉ l₂) (h :
obtain l₁', l₂', rfl, h₁, h₂ := h
have : l₂' = [] := by
rw [eq_nil_iff_forall_not_mem]
exact fun x m => w x (mem_append_of_mem_right l₁' m) (h₂.mem m)
exact fun x m => w x (mem_append_right l₁' m) (h₂.mem m)
simp_all
theorem Sublist.of_sublist_append_right (w : a, a l a l₁) (h : l <+ l₁ ++ l₂) : l <+ l₂ := by
@@ -425,7 +425,7 @@ theorem Sublist.of_sublist_append_right (w : ∀ a, a ∈ l → a ∉ l₁) (h :
obtain l₁', l₂', rfl, h₁, h₂ := h
have : l₁' = [] := by
rw [eq_nil_iff_forall_not_mem]
exact fun x m => w x (mem_append_of_mem_left l₂' m) (h₁.mem m)
exact fun x m => w x (mem_append_left l₂' m) (h₁.mem m)
simp_all
theorem Sublist.middle {l : List α} (h : l <+ l₁ ++ l₂) (a : α) : l <+ l₁ ++ a :: l₂ := by

View File

@@ -1029,3 +1029,12 @@ instance decidableExistsLT [h : DecidablePred p] : DecidablePred fun n => ∃ m
instance decidableExistsLE [DecidablePred p] : DecidablePred fun n => m : Nat, m n p m :=
fun n => decidable_of_iff ( m, m < n + 1 p m)
(exists_congr fun _ => and_congr_left' Nat.lt_succ_iff)
/-! ### Results about `List.sum` specialized to `Nat` -/
protected theorem sum_pos_iff_exists_pos {l : List Nat} : 0 < l.sum x l, 0 < x := by
induction l with
| nil => simp
| cons x xs ih =>
simp [ ih]
omega

View File

@@ -6,6 +6,7 @@ Authors: Leonardo de Moura
prelude
import Init.ByCases
import Init.Data.Prod
import Init.Data.RArray
namespace Nat.Linear
@@ -15,7 +16,7 @@ namespace Nat.Linear
abbrev Var := Nat
abbrev Context := List Nat
abbrev Context := Lean.RArray Nat
/--
When encoding polynomials. We use `fixedVar` for encoding numerals.
@@ -23,12 +24,7 @@ abbrev Context := List Nat
def fixedVar := 100000000 -- Any big number should work here
def Var.denote (ctx : Context) (v : Var) : Nat :=
bif v == fixedVar then 1 else go ctx v
where
go : List Nat Nat Nat
| [], _ => 0
| a::_, 0 => a
| _::as, i+1 => go as i
bif v == fixedVar then 1 else ctx.get v
inductive Expr where
| num (v : Nat)
@@ -52,25 +48,23 @@ def Poly.denote (ctx : Context) (p : Poly) : Nat :=
| [] => 0
| (k, v) :: p => Nat.add (Nat.mul k (v.denote ctx)) (denote ctx p)
def Poly.insertSorted (k : Nat) (v : Var) (p : Poly) : Poly :=
def Poly.insert (k : Nat) (v : Var) (p : Poly) : Poly :=
match p with
| [] => [(k, v)]
| (k', v') :: p => bif Nat.blt v v' then (k, v) :: (k', v') :: p else (k', v') :: insertSorted k v p
| (k', v') :: p =>
bif Nat.blt v v' then
(k, v) :: (k', v') :: p
else bif Nat.beq v v' then
(k + k', v') :: p
else
(k', v') :: insert k v p
def Poly.sort (p : Poly) : Poly :=
let rec go (p : Poly) (r : Poly) : Poly :=
def Poly.norm (p : Poly) : Poly := go p []
where
go (p : Poly) (r : Poly) : Poly :=
match p with
| [] => r
| (k, v) :: p => go p (r.insertSorted k v)
go p []
def Poly.fuse (p : Poly) : Poly :=
match p with
| [] => []
| (k, v) :: p =>
match fuse p with
| [] => [(k, v)]
| (k', v') :: p' => bif v == v' then (Nat.add k k', v)::p' else (k, v) :: (k', v') :: p'
| (k, v) :: p => go p (r.insert k v)
def Poly.mul (k : Nat) (p : Poly) : Poly :=
bif k == 0 then
@@ -146,15 +140,17 @@ def Poly.combineAux (fuel : Nat) (p₁ p₂ : Poly) : Poly :=
def Poly.combine (p₁ p₂ : Poly) : Poly :=
combineAux hugeFuel p₁ p₂
def Expr.toPoly : Expr Poly
| Expr.num k => bif k == 0 then [] else [ (k, fixedVar) ]
| Expr.var i => [(1, i)]
| Expr.add a b => a.toPoly ++ b.toPoly
| Expr.mulL k a => a.toPoly.mul k
| Expr.mulR a k => a.toPoly.mul k
def Poly.norm (p : Poly) : Poly :=
p.sort.fuse
def Expr.toPoly (e : Expr) :=
go 1 e []
where
-- Implementation note: This assembles the result using difference lists
-- to avoid `++` on lists.
go (coeff : Nat) : Expr (Poly Poly)
| Expr.num k => bif k == 0 then id else ((coeff * k, fixedVar) :: ·)
| Expr.var i => ((coeff, i) :: ·)
| Expr.add a b => go coeff a go coeff b
| Expr.mulL k a
| Expr.mulR a k => bif k == 0 then id else go (coeff * k) a
def Expr.toNormPoly (e : Expr) : Poly :=
e.toPoly.norm
@@ -201,7 +197,7 @@ def PolyCnstr.denote (ctx : Context) (c : PolyCnstr) : Prop :=
Poly.denote_le ctx (c.lhs, c.rhs)
def PolyCnstr.norm (c : PolyCnstr) : PolyCnstr :=
let (lhs, rhs) := Poly.cancel c.lhs.sort.fuse c.rhs.sort.fuse
let (lhs, rhs) := Poly.cancel c.lhs.norm c.rhs.norm
{ eq := c.eq, lhs, rhs }
def PolyCnstr.isUnsat (c : PolyCnstr) : Bool :=
@@ -268,24 +264,32 @@ def PolyCnstr.toExpr (c : PolyCnstr) : ExprCnstr :=
{ c with lhs := c.lhs.toExpr, rhs := c.rhs.toExpr }
attribute [local simp] Nat.add_comm Nat.add_assoc Nat.add_left_comm Nat.right_distrib Nat.left_distrib Nat.mul_assoc Nat.mul_comm
attribute [local simp] Poly.denote Expr.denote Poly.insertSorted Poly.sort Poly.sort.go Poly.fuse Poly.cancelAux
attribute [local simp] Poly.denote Expr.denote Poly.insert Poly.norm Poly.norm.go Poly.cancelAux
attribute [local simp] Poly.mul Poly.mul.go
theorem Poly.denote_insertSorted (ctx : Context) (k : Nat) (v : Var) (p : Poly) : (p.insertSorted k v).denote ctx = p.denote ctx + k * v.denote ctx := by
theorem Poly.denote_insert (ctx : Context) (k : Nat) (v : Var) (p : Poly) :
(p.insert k v).denote ctx = p.denote ctx + k * v.denote ctx := by
match p with
| [] => simp
| (k', v') :: p => by_cases h : Nat.blt v v' <;> simp [h, denote_insertSorted]
| (k', v') :: p =>
by_cases h₁ : Nat.blt v v'
· simp [h₁]
· by_cases h₂ : Nat.beq v v'
· simp only [insert, h₁, h₂, cond_false, cond_true]
simp [Nat.eq_of_beq_eq_true h₂]
· simp only [insert, h₁, h₂, cond_false, cond_true]
simp [denote_insert]
attribute [local simp] Poly.denote_insertSorted
attribute [local simp] Poly.denote_insert
theorem Poly.denote_sort_go (ctx : Context) (p : Poly) (r : Poly) : (sort.go p r).denote ctx = p.denote ctx + r.denote ctx := by
theorem Poly.denote_norm_go (ctx : Context) (p : Poly) (r : Poly) : (norm.go p r).denote ctx = p.denote ctx + r.denote ctx := by
match p with
| [] => simp
| (k, v):: p => simp [denote_sort_go]
| (k, v):: p => simp [denote_norm_go]
attribute [local simp] Poly.denote_sort_go
attribute [local simp] Poly.denote_norm_go
theorem Poly.denote_sort (ctx : Context) (m : Poly) : m.sort.denote ctx = m.denote ctx := by
theorem Poly.denote_sort (ctx : Context) (m : Poly) : m.norm.denote ctx = m.denote ctx := by
simp
attribute [local simp] Poly.denote_sort
@@ -316,18 +320,6 @@ theorem Poly.denote_reverse (ctx : Context) (p : Poly) : denote ctx (List.revers
attribute [local simp] Poly.denote_reverse
theorem Poly.denote_fuse (ctx : Context) (p : Poly) : p.fuse.denote ctx = p.denote ctx := by
match p with
| [] => rfl
| (k, v) :: p =>
have ih := denote_fuse ctx p
simp
split
case _ h => simp [ ih, h]
case _ k' v' p' h => by_cases he : v == v' <;> simp [he, ih, h]; rw [eq_of_beq he]
attribute [local simp] Poly.denote_fuse
theorem Poly.denote_mul (ctx : Context) (k : Nat) (p : Poly) : (p.mul k).denote ctx = k * p.denote ctx := by
simp
by_cases h : k == 0 <;> simp [h]; simp [eq_of_beq h]
@@ -516,13 +508,25 @@ theorem Poly.denote_combine (ctx : Context) (p₁ p₂ : Poly) : (p₁.combine p
attribute [local simp] Poly.denote_combine
theorem Expr.denote_toPoly_go (ctx : Context) (e : Expr) :
(toPoly.go k e p).denote ctx = k * e.denote ctx + p.denote ctx := by
induction k, e using Expr.toPoly.go.induct generalizing p with
| case1 k k' =>
simp only [toPoly.go]
by_cases h : k' == 0
· simp [h, eq_of_beq h]
· simp [h, Var.denote]
| case2 k i => simp [toPoly.go]
| case3 k a b iha ihb => simp [toPoly.go, iha, ihb]
| case4 k k' a ih
| case5 k a k' ih =>
simp only [toPoly.go, denote, mul_eq]
by_cases h : k' == 0
· simp [h, eq_of_beq h]
· simp [h, cond_false, ih, Nat.mul_assoc]
theorem Expr.denote_toPoly (ctx : Context) (e : Expr) : e.toPoly.denote ctx = e.denote ctx := by
induction e with
| num k => by_cases h : k == 0 <;> simp [toPoly, h, Var.denote]; simp [eq_of_beq h]
| var i => simp [toPoly]
| add a b iha ihb => simp [toPoly, iha, ihb]
| mulL k a ih => simp [toPoly, ih, -Poly.mul]
| mulR k a ih => simp [toPoly, ih, -Poly.mul]
simp [toPoly, Expr.denote_toPoly_go]
attribute [local simp] Expr.denote_toPoly
@@ -554,8 +558,8 @@ theorem ExprCnstr.denote_toPoly (ctx : Context) (c : ExprCnstr) : c.toPoly.denot
cases c; rename_i eq lhs rhs
simp [ExprCnstr.denote, PolyCnstr.denote, ExprCnstr.toPoly];
by_cases h : eq = true <;> simp [h]
· simp [Poly.denote_eq, Expr.toPoly]
· simp [Poly.denote_le, Expr.toPoly]
· simp [Poly.denote_eq]
· simp [Poly.denote_le]
attribute [local simp] ExprCnstr.denote_toPoly

View File

@@ -16,10 +16,6 @@ def getM [Alternative m] : Option α → m α
| none => failure
| some a => pure a
@[deprecated getM (since := "2024-04-17")]
-- `[Monad m]` is not needed here.
def toMonad [Monad m] [Alternative m] : Option α m α := getM
/-- Returns `true` on `some x` and `false` on `none`. -/
@[inline] def isSome : Option α Bool
| some _ => true
@@ -28,8 +24,6 @@ def toMonad [Monad m] [Alternative m] : Option α → m α := getM
@[simp] theorem isSome_none : @isSome α none = false := rfl
@[simp] theorem isSome_some : isSome (some a) = true := rfl
@[deprecated isSome (since := "2024-04-17"), inline] def toBool : Option α Bool := isSome
/-- Returns `true` on `none` and `false` on `some x`. -/
@[inline] def isNone : Option α Bool
| some _ => false

View File

@@ -55,7 +55,9 @@ theorem get_eq_getD {fallback : α} : (o : Option α) → {h : o.isSome} → o.g
theorem some_get! [Inhabited α] : (o : Option α) o.isSome some (o.get!) = o
| some _, _ => rfl
theorem get!_eq_getD_default [Inhabited α] (o : Option α) : o.get! = o.getD default := rfl
theorem get!_eq_getD [Inhabited α] (o : Option α) : o.get! = o.getD default := rfl
@[deprecated get!_eq_getD (since := "2024-11-18")] abbrev get!_eq_getD_default := @get!_eq_getD
theorem mem_unique {o : Option α} {a b : α} (ha : a o) (hb : b o) : a = b :=
some.inj <| ha hb

69
src/Init/Data/RArray.lean Normal file
View File

@@ -0,0 +1,69 @@
/-
Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joachim Breitner
-/
prelude
import Init.PropLemmas
namespace Lean
/--
A `RArray` can model `Fin n → α` or `Array α`, but is optimized for a fast kernel-reducible `get`
operation.
The primary intended use case is the “denote” function of a typical proof by reflection proof, where
only the `get` operation is necessary. It is not suitable as a general-purpose data structure.
There is no well-formedness invariant attached to this data structure, to keep it concise; it's
semantics is given through `RArray.get`. In that way one can also view an `RArray` as a decision
tree implementing `Nat → α`.
See `RArray.ofFn` and `RArray.ofArray` in module `Lean.Data.RArray` for functions that construct an
`RArray`.
It is not universe-polymorphic. ; smaller proof objects and no complication with the `ToExpr` type
class.
-/
inductive RArray (α : Type) : Type where
| leaf : α RArray α
| branch : Nat RArray α RArray α RArray α
variable {α : Type}
/-- The crucial operation, written with very little abstractional overhead -/
noncomputable def RArray.get (a : RArray α) (n : Nat) : α :=
RArray.rec (fun x => x) (fun p _ _ l r => (Nat.ble p n).rec l r) a
private theorem RArray.get_eq_def (a : RArray α) (n : Nat) :
a.get n = match a with
| .leaf x => x
| .branch p l r => (Nat.ble p n).rec (l.get n) (r.get n) := by
conv => lhs; unfold RArray.get
split <;> rfl
/-- `RArray.get`, implemented conventionally -/
def RArray.getImpl (a : RArray α) (n : Nat) : α :=
match a with
| .leaf x => x
| .branch p l r => if n < p then l.getImpl n else r.getImpl n
@[csimp]
theorem RArray.get_eq_getImpl : @RArray.get = @RArray.getImpl := by
funext α a n
induction a with
| leaf _ => rfl
| branch p l r ihl ihr =>
rw [RArray.getImpl, RArray.get_eq_def]
simp only [ihl, ihr, Nat.not_le, Nat.ble_eq, ite_not]
cases hnp : Nat.ble p n <;> rfl
instance : GetElem (RArray α) Nat α (fun _ _ => True) where
getElem a n _ := a.get n
def RArray.size : RArray α Nat
| leaf _ => 1
| branch _ l r => l.size + r.size
end Lean

View File

@@ -113,10 +113,10 @@ initialize IO.stdGenRef : IO.Ref StdGen ←
let seed := UInt64.toNat (ByteArray.toUInt64LE! ( IO.getRandomBytes 8))
IO.mkRef (mkStdGen seed)
def IO.setRandSeed (n : Nat) : IO Unit :=
def IO.setRandSeed (n : Nat) : BaseIO Unit :=
IO.stdGenRef.set (mkStdGen n)
def IO.rand (lo hi : Nat) : IO Nat := do
def IO.rand (lo hi : Nat) : BaseIO Nat := do
let gen IO.stdGenRef.get
let (r, gen) := randNat gen lo hi
IO.stdGenRef.set gen

View File

@@ -148,6 +148,9 @@ instance : ShiftLeft Int8 := ⟨Int8.shiftLeft⟩
instance : ShiftRight Int8 := Int8.shiftRight
instance : DecidableEq Int8 := Int8.decEq
@[extern "lean_bool_to_int8"]
def Bool.toInt8 (b : Bool) : Int8 := if b then 1 else 0
@[extern "lean_int8_dec_lt"]
def Int8.decLt (a b : Int8) : Decidable (a < b) :=
inferInstanceAs (Decidable (a.toBitVec.slt b.toBitVec))
@@ -249,6 +252,9 @@ instance : ShiftLeft Int16 := ⟨Int16.shiftLeft⟩
instance : ShiftRight Int16 := Int16.shiftRight
instance : DecidableEq Int16 := Int16.decEq
@[extern "lean_bool_to_int16"]
def Bool.toInt16 (b : Bool) : Int16 := if b then 1 else 0
@[extern "lean_int16_dec_lt"]
def Int16.decLt (a b : Int16) : Decidable (a < b) :=
inferInstanceAs (Decidable (a.toBitVec.slt b.toBitVec))
@@ -354,6 +360,9 @@ instance : ShiftLeft Int32 := ⟨Int32.shiftLeft⟩
instance : ShiftRight Int32 := Int32.shiftRight
instance : DecidableEq Int32 := Int32.decEq
@[extern "lean_bool_to_int32"]
def Bool.toInt32 (b : Bool) : Int32 := if b then 1 else 0
@[extern "lean_int32_dec_lt"]
def Int32.decLt (a b : Int32) : Decidable (a < b) :=
inferInstanceAs (Decidable (a.toBitVec.slt b.toBitVec))
@@ -463,6 +472,9 @@ instance : ShiftLeft Int64 := ⟨Int64.shiftLeft⟩
instance : ShiftRight Int64 := Int64.shiftRight
instance : DecidableEq Int64 := Int64.decEq
@[extern "lean_bool_to_int64"]
def Bool.toInt64 (b : Bool) : Int64 := if b then 1 else 0
@[extern "lean_int64_dec_lt"]
def Int64.decLt (a b : Int64) : Decidable (a < b) :=
inferInstanceAs (Decidable (a.toBitVec.slt b.toBitVec))
@@ -574,6 +586,9 @@ instance : ShiftLeft ISize := ⟨ISize.shiftLeft⟩
instance : ShiftRight ISize := ISize.shiftRight
instance : DecidableEq ISize := ISize.decEq
@[extern "lean_bool_to_isize"]
def Bool.toISize (b : Bool) : ISize := if b then 1 else 0
@[extern "lean_isize_dec_lt"]
def ISize.decLt (a b : ISize) : Decidable (a < b) :=
inferInstanceAs (Decidable (a.toBitVec.slt b.toBitVec))

View File

@@ -514,9 +514,6 @@ instance : Inhabited String := ⟨""⟩
instance : Append String := String.append
@[deprecated push (since := "2024-04-06")]
def str : String Char String := push
@[inline] def pushn (s : String) (c : Char) (n : Nat) : String :=
n.repeat (fun s => s.push c) s

View File

@@ -56,6 +56,9 @@ instance : Xor UInt8 := ⟨UInt8.xor⟩
instance : ShiftLeft UInt8 := UInt8.shiftLeft
instance : ShiftRight UInt8 := UInt8.shiftRight
@[extern "lean_bool_to_uint8"]
def Bool.toUInt8 (b : Bool) : UInt8 := if b then 1 else 0
@[extern "lean_uint8_dec_lt"]
def UInt8.decLt (a b : UInt8) : Decidable (a < b) :=
inferInstanceAs (Decidable (a.toBitVec < b.toBitVec))
@@ -116,6 +119,9 @@ instance : Xor UInt16 := ⟨UInt16.xor⟩
instance : ShiftLeft UInt16 := UInt16.shiftLeft
instance : ShiftRight UInt16 := UInt16.shiftRight
@[extern "lean_bool_to_uint16"]
def Bool.toUInt16 (b : Bool) : UInt16 := if b then 1 else 0
set_option bootstrap.genMatcherCode false in
@[extern "lean_uint16_dec_lt"]
def UInt16.decLt (a b : UInt16) : Decidable (a < b) :=
@@ -174,6 +180,9 @@ instance : Xor UInt32 := ⟨UInt32.xor⟩
instance : ShiftLeft UInt32 := UInt32.shiftLeft
instance : ShiftRight UInt32 := UInt32.shiftRight
@[extern "lean_bool_to_uint32"]
def Bool.toUInt32 (b : Bool) : UInt32 := if b then 1 else 0
@[extern "lean_uint64_add"]
def UInt64.add (a b : UInt64) : UInt64 := a.toBitVec + b.toBitVec
@[extern "lean_uint64_sub"]
@@ -278,5 +287,8 @@ instance : Xor USize := ⟨USize.xor⟩
instance : ShiftLeft USize := USize.shiftLeft
instance : ShiftRight USize := USize.shiftRight
@[extern "lean_bool_to_usize"]
def Bool.toUSize (b : Bool) : USize := if b then 1 else 0
instance : Max USize := maxOfLe
instance : Min USize := minOfLe

View File

@@ -374,6 +374,9 @@ partial def structEq : Syntax → Syntax → Bool
instance : BEq Lean.Syntax := structEq
instance : BEq (Lean.TSyntax k) := (·.raw == ·.raw)
/--
Finds the first `SourceInfo` from the back of `stx` or `none` if no `SourceInfo` can be found.
-/
partial def getTailInfo? : Syntax Option SourceInfo
| atom info _ => info
| ident info .. => info
@@ -382,14 +385,39 @@ partial def getTailInfo? : Syntax → Option SourceInfo
| node info _ _ => info
| _ => none
/--
Finds the first `SourceInfo` from the back of `stx` or `SourceInfo.none`
if no `SourceInfo` can be found.
-/
def getTailInfo (stx : Syntax) : SourceInfo :=
stx.getTailInfo?.getD SourceInfo.none
/--
Finds the trailing size of the first `SourceInfo` from the back of `stx`.
If no `SourceInfo` can be found or the first `SourceInfo` from the back of `stx` contains no
trailing whitespace, the result is `0`.
-/
def getTrailingSize (stx : Syntax) : Nat :=
match stx.getTailInfo? with
| some (SourceInfo.original (trailing := trailing) ..) => trailing.bsize
| _ => 0
/--
Finds the trailing whitespace substring of the first `SourceInfo` from the back of `stx`.
If no `SourceInfo` can be found or the first `SourceInfo` from the back of `stx` contains
no trailing whitespace, the result is `none`.
-/
def getTrailing? (stx : Syntax) : Option Substring :=
stx.getTailInfo.getTrailing?
/--
Finds the tail position of the trailing whitespace of the first `SourceInfo` from the back of `stx`.
If no `SourceInfo` can be found or the first `SourceInfo` from the back of `stx` contains
no trailing whitespace and lacks a tail position, the result is `none`.
-/
def getTrailingTailPos? (stx : Syntax) (canonicalOnly := false) : Option String.Pos :=
stx.getTailInfo.getTrailingTailPos? canonicalOnly
/--
Return substring of original input covering `stx`.
Result is meaningful only if all involved `SourceInfo.original`s refer to the same string (as is the case after parsing). -/

View File

@@ -3654,7 +3654,8 @@ namespace SourceInfo
/--
Gets the position information from a `SourceInfo`, if available.
If `originalOnly` is true, then `.synthetic` syntax will also return `none`.
If `canonicalOnly` is true, then `.synthetic` syntax with `canonical := false`
will also return `none`.
-/
def getPos? (info : SourceInfo) (canonicalOnly := false) : Option String.Pos :=
match info, canonicalOnly with
@@ -3665,7 +3666,8 @@ def getPos? (info : SourceInfo) (canonicalOnly := false) : Option String.Pos :=
/--
Gets the end position information from a `SourceInfo`, if available.
If `originalOnly` is true, then `.synthetic` syntax will also return `none`.
If `canonicalOnly` is true, then `.synthetic` syntax with `canonical := false`
will also return `none`.
-/
def getTailPos? (info : SourceInfo) (canonicalOnly := false) : Option String.Pos :=
match info, canonicalOnly with
@@ -3674,6 +3676,24 @@ def getTailPos? (info : SourceInfo) (canonicalOnly := false) : Option String.Pos
| synthetic (endPos := endPos) .., false => some endPos
| _, _ => none
/--
Gets the substring representing the trailing whitespace of a `SourceInfo`, if available.
-/
def getTrailing? (info : SourceInfo) : Option Substring :=
match info with
| original (trailing := trailing) .. => some trailing
| _ => none
/--
Gets the end position information of the trailing whitespace of a `SourceInfo`, if available.
If `canonicalOnly` is true, then `.synthetic` syntax with `canonical := false`
will also return `none`.
-/
def getTrailingTailPos? (info : SourceInfo) (canonicalOnly := false) : Option String.Pos :=
match info.getTrailing? with
| some trailing => some trailing.stopPos
| none => info.getTailPos? canonicalOnly
end SourceInfo
/--
@@ -3972,7 +3992,6 @@ position information.
def getPos? (stx : Syntax) (canonicalOnly := false) : Option String.Pos :=
stx.getHeadInfo.getPos? canonicalOnly
/--
Get the ending position of the syntax, if possible.
If `canonicalOnly` is true, non-canonical `synthetic` nodes are treated as not carrying

View File

@@ -802,6 +802,9 @@ def run (args : SpawnArgs) : IO String := do
end Process
/-- Returns the thread ID of the calling thread. -/
@[extern "lean_io_get_tid"] opaque getTID : BaseIO UInt64
structure AccessRight where
read : Bool := false
write : Bool := false

View File

@@ -466,7 +466,7 @@ hypotheses or the goal. It can have one of the forms:
* `at h₁ h₂ ⊢`: target the hypotheses `h₁` and `h₂`, and the goal
* `at *`: target all hypotheses and the goal
-/
syntax location := withPosition(" at" (locationWildcard <|> locationHyp))
syntax location := withPosition(ppGroup(" at" (locationWildcard <|> locationHyp)))
/--
* `change tgt'` will change the goal from `tgt` to `tgt'`,
@@ -1155,7 +1155,7 @@ Configuration for the `decide` tactic family.
structure DecideConfig where
/-- If true (default: false), then use only kernel reduction when reducing the `Decidable` instance.
This is more efficient, since the default mode reduces twice (once in the elaborator and again in the kernel),
however kernel reduction ignores transparency settings. The `decide!` tactic is a synonym for `decide +kernel`. -/
however kernel reduction ignores transparency settings. -/
kernel : Bool := false
/-- If true (default: false), then uses the native code compiler to evaluate the `Decidable` instance,
admitting the result via the axiom `Lean.ofReduceBool`. This can be significantly more efficient,
@@ -1165,7 +1165,9 @@ structure DecideConfig where
native : Bool := false
/-- If true (default: true), then when preprocessing the goal, do zeta reduction to attempt to eliminate free variables. -/
zetaReduce : Bool := true
/-- If true (default: false), then when preprocessing reverts free variables. -/
/-- If true (default: false), then when preprocessing, removes irrelevant variables and reverts the local context.
A variable is *relevant* if it appears in the target, if it appears in a relevant variable,
or if it is a proposition that refers to a relevant variable. -/
revert : Bool := false
/--
@@ -1240,17 +1242,6 @@ example : 1 + 1 = 2 := by rfl
-/
syntax (name := decide) "decide" optConfig : tactic
/--
`decide!` is a variant of the `decide` tactic that uses kernel reduction to prove the goal.
It has the following properties:
- Since it uses kernel reduction instead of elaborator reduction, it ignores transparency and can unfold everything.
- While `decide` needs to reduce the `Decidable` instance twice (once during elaboration to verify whether the tactic succeeds,
and once during kernel type checking), the `decide!` tactic reduces it exactly once.
The `decide!` syntax is short for `decide +kernel`.
-/
syntax (name := decideBang) "decide!" optConfig : tactic
/--
`native_decide` is a synonym for `decide +native`.
It will attempt to prove a goal of type `p` by synthesizing an instance

View File

@@ -133,8 +133,8 @@ def foldNatBinBoolPred (fn : Nat → Nat → Bool) (a₁ a₂ : Expr) : Option E
return mkConst ``Bool.false
def foldNatBeq := fun _ : Bool => foldNatBinBoolPred (fun a b => a == b)
def foldNatBle := fun _ : Bool => foldNatBinBoolPred (fun a b => a < b)
def foldNatBlt := fun _ : Bool => foldNatBinBoolPred (fun a b => a b)
def foldNatBlt := fun _ : Bool => foldNatBinBoolPred (fun a b => a < b)
def foldNatBle := fun _ : Bool => foldNatBinBoolPred (fun a b => a b)
def natFoldFns : List (Name × BinFoldFn) :=
[(``Nat.add, foldNatAdd),

View File

@@ -29,4 +29,4 @@ import Lean.Data.Xml
import Lean.Data.NameTrie
import Lean.Data.RBTree
import Lean.Data.RBMap
import Lean.Data.Rat
import Lean.Data.RArray

View File

@@ -365,6 +365,7 @@ structure TextDocumentRegistrationOptions where
inductive MarkupKind where
| plaintext | markdown
deriving DecidableEq, Hashable
instance : FromJson MarkupKind := fun
| str "plaintext" => Except.ok MarkupKind.plaintext
@@ -378,7 +379,7 @@ instance : ToJson MarkupKind := ⟨fun
structure MarkupContent where
kind : MarkupKind
value : String
deriving ToJson, FromJson
deriving ToJson, FromJson, DecidableEq, Hashable
/-- Reference to the progress of some in-flight piece of work.

View File

@@ -25,7 +25,7 @@ inductive CompletionItemKind where
| unit | value | enum | keyword | snippet
| color | file | reference | folder | enumMember
| constant | struct | event | operator | typeParameter
deriving Inhabited, DecidableEq, Repr
deriving Inhabited, DecidableEq, Repr, Hashable
instance : ToJson CompletionItemKind where
toJson a := toJson (a.toCtorIdx + 1)
@@ -39,11 +39,11 @@ structure InsertReplaceEdit where
newText : String
insert : Range
replace : Range
deriving FromJson, ToJson
deriving FromJson, ToJson, BEq, Hashable
inductive CompletionItemTag where
| deprecated
deriving Inhabited, DecidableEq, Repr
deriving Inhabited, DecidableEq, Repr, Hashable
instance : ToJson CompletionItemTag where
toJson t := toJson (t.toCtorIdx + 1)
@@ -73,7 +73,7 @@ structure CompletionItem where
commitCharacters? : string[]
command? : Command
-/
deriving FromJson, ToJson, Inhabited
deriving FromJson, ToJson, Inhabited, BEq, Hashable
structure CompletionList where
isIncomplete : Bool

View File

@@ -33,6 +33,16 @@ def find? (m : NameMap α) (n : Name) : Option α := RBMap.find? m n
instance : ForIn m (NameMap α) (Name × α) :=
inferInstanceAs (ForIn _ (RBMap ..) ..)
/-- `filter f m` returns the `NameMap` consisting of all
"`key`/`val`"-pairs in `m` where `f key val` returns `true`. -/
def filter (f : Name α Bool) (m : NameMap α) : NameMap α := RBMap.filter f m
/-- `filterMap f m` filters an `NameMap` and simultaneously modifies the filtered values.
It takes a function `f : Name → α → Option β` and applies `f name` to the value with key `name`.
The resulting entries with non-`none` value are collected to form the output `NameMap`. -/
def filterMap (f : Name α Option β) (m : NameMap α) : NameMap β := RBMap.filterMap f m
end NameMap
def NameSet := RBTree Name Name.quickCmp
@@ -53,6 +63,9 @@ def append (s t : NameSet) : NameSet :=
instance : Append NameSet where
append := NameSet.append
/-- `filter f s` returns the `NameSet` consisting of all `x` in `s` where `f x` returns `true`. -/
def filter (f : Name Bool) (s : NameSet) : NameSet := RBTree.filter f s
end NameSet
def NameSSet := SSet Name
@@ -73,6 +86,9 @@ instance : EmptyCollection NameHashSet := ⟨empty⟩
instance : Inhabited NameHashSet := {}
def insert (s : NameHashSet) (n : Name) := Std.HashSet.insert s n
def contains (s : NameHashSet) (n : Name) : Bool := Std.HashSet.contains s n
/-- `filter f s` returns the `NameHashSet` consisting of all `x` in `s` where `f x` returns `true`. -/
def filter (f : Name Bool) (s : NameHashSet) : NameHashSet := Std.HashSet.filter f s
end NameHashSet
def MacroScopesView.isPrefixOf (v₁ v₂ : MacroScopesView) : Bool :=

75
src/Lean/Data/RArray.lean Normal file
View File

@@ -0,0 +1,75 @@
/-
Copyright (c) 2024 Lean FRO, LLC. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joachim Breitner
-/
prelude
import Init.Data.RArray
import Lean.ToExpr
/-!
Auxillary definitions related to `Lean.RArray` that are typically only used in meta-code, in
particular the `ToExpr` instance.
-/
namespace Lean
-- This function could live in Init/Data/RArray.lean, but without omega it's tedious to implement
def RArray.ofFn {n : Nat} (f : Fin n α) (h : 0 < n) : RArray α :=
go 0 n h (Nat.le_refl _)
where
go (lb ub : Nat) (h1 : lb < ub) (h2 : ub n) : RArray α :=
if h : lb + 1 = ub then
.leaf (f lb, Nat.lt_of_lt_of_le h1 h2)
else
let mid := (lb + ub)/2
.branch mid (go lb mid (by omega) (by omega)) (go mid ub (by omega) h2)
def RArray.ofArray (xs : Array α) (h : 0 < xs.size) : RArray α :=
.ofFn (xs[·]) h
/-- The correctness theorem for `ofFn` -/
theorem RArray.get_ofFn {n : Nat} (f : Fin n α) (h : 0 < n) (i : Fin n) :
(ofFn f h).get i = f i :=
go 0 n h (Nat.le_refl _) (Nat.zero_le _) i.2
where
go lb ub h1 h2 (h3 : lb i.val) (h3 : i.val < ub) : (ofFn.go f lb ub h1 h2).get i = f i := by
induction lb, ub, h1, h2 using RArray.ofFn.go.induct (f := f) (n := n)
case case1 =>
simp [ofFn.go, RArray.get_eq_getImpl, RArray.getImpl]
congr
omega
case case2 ih1 ih2 hiu =>
rw [ofFn.go]; simp only [reduceDIte, *]
simp [RArray.get_eq_getImpl, RArray.getImpl] at *
split
· rw [ih1] <;> omega
· rw [ih2] <;> omega
@[simp]
theorem RArray.size_ofFn {n : Nat} (f : Fin n α) (h : 0 < n) :
(ofFn f h).size = n :=
go 0 n h (Nat.le_refl _)
where
go lb ub h1 h2 : (ofFn.go f lb ub h1 h2).size = ub - lb := by
induction lb, ub, h1, h2 using RArray.ofFn.go.induct (f := f) (n := n)
case case1 => simp [ofFn.go, size]; omega
case case2 ih1 ih2 hiu => rw [ofFn.go]; simp [size, *]; omega
section Meta
open Lean
def RArray.toExpr (ty : Expr) (f : α Expr) : RArray α Expr
| .leaf x =>
mkApp2 (mkConst ``RArray.leaf) ty (f x)
| .branch p l r =>
mkApp4 (mkConst ``RArray.branch) ty (mkRawNatLit p) (l.toExpr ty f) (r.toExpr ty f)
instance [ToExpr α] : ToExpr (RArray α) where
toTypeExpr := mkApp (mkConst ``RArray) (toTypeExpr α)
toExpr a := a.toExpr (toTypeExpr α) toExpr
end Meta
end Lean

View File

@@ -404,6 +404,24 @@ def intersectBy {γ : Type v₁} {δ : Type v₂} (mergeFn : α → β → γ
| some b₂ => acc.insert a <| mergeFn a b₁ b₂
| none => acc
/--
`filter f m` returns the `RBMap` consisting of all
"`key`/`val`"-pairs in `m` where `f key val` returns `true`.
-/
def filter (f : α β Bool) (m : RBMap α β cmp) : RBMap α β cmp :=
m.fold (fun r k v => if f k v then r.insert k v else r) {}
/--
`filterMap f m` filters an `RBMap` and simultaneously modifies the filtered values.
It takes a function `f : α → β → Option γ` and applies `f k v` to the value with key `k`.
The resulting entries with non-`none` value are collected to form the output `RBMap`.
-/
def filterMap (f : α β Option γ) (m : RBMap α β cmp) : RBMap α γ cmp :=
m.fold (fun r k v => match f k v with
| none => r
| some b => r.insert k b) {}
end RBMap
def rbmapOf {α : Type u} {β : Type v} (l : List (α × β)) (cmp : α α Ordering) : RBMap α β cmp :=

View File

@@ -114,6 +114,13 @@ def union (t₁ t₂ : RBTree α cmp) : RBTree α cmp :=
def diff (t₁ t₂ : RBTree α cmp) : RBTree α cmp :=
t₂.fold .erase t₁
/--
`filter f m` returns the `RBTree` consisting of all
`x` in `m` where `f x` returns `true`.
-/
def filter (f : α Bool) (m : RBTree α cmp) : RBTree α cmp :=
RBMap.filter (fun a _ => f a) m
end RBTree
def rbtreeOf {α : Type u} (l : List α) (cmp : α α Ordering) : RBTree α cmp :=

View File

@@ -1399,8 +1399,8 @@ private def elabAppLValsAux (namedArgs : Array NamedArg) (args : Array Arg) (exp
let rec loop : Expr List LVal TermElabM Expr
| f, [] => elabAppArgs f namedArgs args expectedType? explicit ellipsis
| f, lval::lvals => do
if let LVal.fieldName (fullRef := fullRef) .. := lval then
addDotCompletionInfo fullRef f expectedType?
if let LVal.fieldName (ref := ref) .. := lval then
addDotCompletionInfo ref f expectedType?
let hasArgs := !namedArgs.isEmpty || !args.isEmpty
let (f, lvalRes) resolveLVal f lval hasArgs
match lvalRes with
@@ -1650,6 +1650,14 @@ private def getSuccesses (candidates : Array (TermElabResult Expr)) : TermElabM
-/
private def mergeFailures (failures : Array (TermElabResult Expr)) : TermElabM α := do
let exs := failures.map fun | .error ex _ => ex | _ => unreachable!
let trees := failures.map (fun | .error _ s => s.meta.core.infoState.trees | _ => unreachable!)
|>.filterMap (·[0]?)
-- Retain partial `InfoTree` subtrees in an `.ofChoiceInfo` node in case of multiple failures.
-- This ensures that the language server still has `Info` to work with when multiple overloaded
-- elaborators fail.
withInfoContext (mkInfo := pure <| .ofChoiceInfo { elaborator := .anonymous, stx := getRef }) do
for tree in trees do
pushInfoTree tree
throwErrorWithNestedErrors "overloaded" exs
private def elabAppAux (f : Syntax) (namedArgs : Array NamedArg) (args : Array Arg) (ellipsis : Bool) (expectedType? : Option Expr) : TermElabM Expr := do

View File

@@ -42,16 +42,15 @@ private def elabOptLevel (stx : Syntax) : TermElabM Level :=
@[builtin_term_elab «completion»] def elabCompletion : TermElab := fun stx expectedType? => do
/- `ident.` is ambiguous in Lean, we may try to be completing a declaration name or access a "field". -/
if stx[0].isIdent then
/- If we can elaborate the identifier successfully, we assume it is a dot-completion. Otherwise, we treat it as
identifier completion with a dangling `.`.
Recall that the server falls back to identifier completion when dot-completion fails. -/
-- Add both an `id` and a `dot` `CompletionInfo` and have the language server figure out which
-- one to use.
addCompletionInfo <| CompletionInfo.id stx stx[0].getId (danglingDot := true) ( getLCtx) expectedType?
let s saveState
try
let e elabTerm stx[0] none
addDotCompletionInfo stx e expectedType?
catch _ =>
s.restore
addCompletionInfo <| CompletionInfo.id stx stx[0].getId (danglingDot := true) ( getLCtx) expectedType?
throwErrorAt stx[1] "invalid field notation, identifier or numeral expected"
else
elabPipeCompletion stx expectedType?
@@ -328,7 +327,7 @@ private def mkSilentAnnotationIfHole (e : Expr) : TermElabM Expr := do
@[builtin_term_elab withAnnotateTerm] def elabWithAnnotateTerm : TermElab := fun stx expectedType? => do
match stx with
| `(with_annotate_term $stx $e) =>
withInfoContext' stx (elabTerm e expectedType?) (mkTermInfo .anonymous (expectedType? := expectedType?) stx)
withTermInfoContext' .anonymous stx (expectedType? := expectedType?) (elabTerm e expectedType?)
| _ => throwUnsupportedSyntax
private unsafe def evalFilePathUnsafe (stx : Syntax) : TermElabM System.FilePath :=

View File

@@ -214,7 +214,7 @@ private def addTraceAsMessagesCore (ctx : Context) (log : MessageLog) (traceStat
let mut log := log
let traces' := traces.toArray.qsort fun ((a, _), _) ((b, _), _) => a < b
for ((pos, endPos), traceMsg) in traces' do
let data := .tagged `_traceMsg <| .joinSep traceMsg.toList "\n"
let data := .tagged `trace <| .joinSep traceMsg.toList "\n"
log := log.add <| mkMessageCore ctx.fileName ctx.fileMap data .information pos endPos
return log
@@ -555,7 +555,11 @@ private def getVarDecls (s : State) : Array Syntax :=
instance {α} : Inhabited (CommandElabM α) where
default := throw default
private def mkMetaContext : Meta.Context := {
/--
The environment linter framework needs to be able to run linters with the same context
as `liftTermElabM`, so we expose that context as a public function here.
-/
def mkMetaContext : Meta.Context := {
config := { foApprox := true, ctxApprox := true, quasiPatternApprox := true }
}

View File

@@ -327,15 +327,18 @@ private def toExprCore (t : Tree) : TermElabM Expr := do
| .term _ trees e =>
modifyInfoState (fun s => { s with trees := s.trees ++ trees }); return e
| .binop ref kind f lhs rhs =>
withRef ref <| withInfoContext' ref (mkInfo := mkTermInfo .anonymous ref) do
mkBinOp (kind == .lazy) f ( toExprCore lhs) ( toExprCore rhs)
withRef ref <|
withTermInfoContext' .anonymous ref do
mkBinOp (kind == .lazy) f ( toExprCore lhs) ( toExprCore rhs)
| .unop ref f arg =>
withRef ref <| withInfoContext' ref (mkInfo := mkTermInfo .anonymous ref) do
mkUnOp f ( toExprCore arg)
withRef ref <|
withTermInfoContext' .anonymous ref do
mkUnOp f ( toExprCore arg)
| .macroExpansion macroName stx stx' nested =>
withRef stx <| withInfoContext' stx (mkInfo := mkTermInfo macroName stx) do
withMacroExpansion stx stx' do
toExprCore nested
withRef stx <|
withTermInfoContext' macroName stx <|
withMacroExpansion stx stx' <|
toExprCore nested
/--
Auxiliary function to decide whether we should coerce `f`'s argument to `maxType` or not.

View File

@@ -139,12 +139,16 @@ def TermInfo.runMetaM (info : TermInfo) (ctx : ContextInfo) (x : MetaM α) : IO
def TermInfo.format (ctx : ContextInfo) (info : TermInfo) : IO Format := do
info.runMetaM ctx do
let ty : Format try
Meta.ppExpr ( Meta.inferType info.expr)
catch _ =>
pure "<failed-to-infer-type>"
let ty : Format
try
Meta.ppExpr ( Meta.inferType info.expr)
catch _ =>
pure "<failed-to-infer-type>"
return f!"{← Meta.ppExpr info.expr} {if info.isBinder then "(isBinder := true) " else ""}: {ty} @ {formatElabInfo ctx info.toElabInfo}"
def PartialTermInfo.format (ctx : ContextInfo) (info : PartialTermInfo) : Format :=
f!"Partial term @ {formatElabInfo ctx info.toElabInfo}"
def CompletionInfo.format (ctx : ContextInfo) (info : CompletionInfo) : IO Format :=
match info with
| .dot i (expectedType? := expectedType?) .. => return f!"[.] {← i.format ctx} : {expectedType?}"
@@ -191,9 +195,13 @@ def FieldRedeclInfo.format (ctx : ContextInfo) (info : FieldRedeclInfo) : Format
def OmissionInfo.format (ctx : ContextInfo) (info : OmissionInfo) : IO Format := do
return f!"Omission @ {← TermInfo.format ctx info.toTermInfo}\nReason: {info.reason}"
def ChoiceInfo.format (ctx : ContextInfo) (info : ChoiceInfo) : Format :=
f!"Choice @ {formatElabInfo ctx info.toElabInfo}"
def Info.format (ctx : ContextInfo) : Info IO Format
| ofTacticInfo i => i.format ctx
| ofTermInfo i => i.format ctx
| ofPartialTermInfo i => pure <| i.format ctx
| ofCommandInfo i => i.format ctx
| ofMacroExpansionInfo i => i.format ctx
| ofOptionInfo i => i.format ctx
@@ -204,10 +212,12 @@ def Info.format (ctx : ContextInfo) : Info → IO Format
| ofFVarAliasInfo i => pure <| i.format
| ofFieldRedeclInfo i => pure <| i.format ctx
| ofOmissionInfo i => i.format ctx
| ofChoiceInfo i => pure <| i.format ctx
def Info.toElabInfo? : Info Option ElabInfo
| ofTacticInfo i => some i.toElabInfo
| ofTermInfo i => some i.toElabInfo
| ofPartialTermInfo i => some i.toElabInfo
| ofCommandInfo i => some i.toElabInfo
| ofMacroExpansionInfo _ => none
| ofOptionInfo _ => none
@@ -218,6 +228,7 @@ def Info.toElabInfo? : Info → Option ElabInfo
| ofFVarAliasInfo _ => none
| ofFieldRedeclInfo _ => none
| ofOmissionInfo i => some i.toElabInfo
| ofChoiceInfo i => some i.toElabInfo
/--
Helper function for propagating the tactic metavariable context to its children nodes.
@@ -311,24 +322,36 @@ def realizeGlobalNameWithInfos (ref : Syntax) (id : Name) : CoreM (List (Name ×
addConstInfo ref n
return ns
/-- Use this to descend a node on the infotree that is being built.
/--
Adds a node containing the `InfoTree`s generated by `x` to the `InfoTree`s in `m`.
It saves the current list of trees `t₀` and resets it and then runs `x >>= mkInfo`, producing either an `i : Info` or a hole id.
Running `x >>= mkInfo` will modify the trees state and produce a new list of trees `t₁`.
In the `i : Info` case, `t₁` become the children of a node `node i t₁` that is appended to `t₀`.
-/
def withInfoContext' [MonadFinally m] (x : m α) (mkInfo : α m (Sum Info MVarId)) : m α := do
If `x` succeeds and `mkInfo` yields an `Info`, the `InfoTree`s of `x` become subtrees of a node
containing the `Info` produced by `mkInfo`, which is then added to the `InfoTree`s in `m`.
If `x` succeeds and `mkInfo` yields an `MVarId`, the `InfoTree`s of `x` are discarded and a `hole`
node is added to the `InfoTree`s in `m`.
If `x` fails, the `InfoTree`s of `x` become subtrees of a node containing the `Info` produced by
`mkInfoOnError`, which is then added to the `InfoTree`s in `m`.
The `InfoTree`s in `m` are reset before `x` is executed and restored with the addition of a new tree
after `x` is executed.
-/
def withInfoContext'
[MonadFinally m]
(x : m α)
(mkInfo : α m (Sum Info MVarId))
(mkInfoOnError : m Info) :
m α := do
if ( getInfoState).enabled then
let treesSaved getResetInfoTrees
Prod.fst <$> MonadFinally.tryFinally' x fun a? => do
match a? with
| none => modifyInfoTrees fun _ => treesSaved
| some a =>
let info mkInfo a
modifyInfoTrees fun trees =>
match info with
| Sum.inl info => treesSaved.push <| InfoTree.node info trees
| Sum.inr mvarId => treesSaved.push <| InfoTree.hole mvarId
let info do
match a? with
| none => pure <| .inl <| mkInfoOnError
| some a => mkInfo a
modifyInfoTrees fun trees =>
match info with
| Sum.inl info => treesSaved.push <| InfoTree.node info trees
| Sum.inr mvarId => treesSaved.push <| InfoTree.hole mvarId
else
x

View File

@@ -70,6 +70,18 @@ structure TermInfo extends ElabInfo where
isBinder : Bool := false
deriving Inhabited
/--
Used instead of `TermInfo` when a term couldn't successfully be elaborated,
and so there is no complete expression available.
The main purpose of `PartialTermInfo` is to ensure that the sub-`InfoTree`s of a failed elaborator
are retained so that they can still be used in the language server.
-/
structure PartialTermInfo extends ElabInfo where
lctx : LocalContext -- The local context when the term was elaborated.
expectedType? : Option Expr
deriving Inhabited
structure CommandInfo extends ElabInfo where
deriving Inhabited
@@ -79,7 +91,7 @@ inductive CompletionInfo where
| dot (termInfo : TermInfo) (expectedType? : Option Expr)
| id (stx : Syntax) (id : Name) (danglingDot : Bool) (lctx : LocalContext) (expectedType? : Option Expr)
| dotId (stx : Syntax) (id : Name) (lctx : LocalContext) (expectedType? : Option Expr)
| fieldId (stx : Syntax) (id : Name) (lctx : LocalContext) (structName : Name)
| fieldId (stx : Syntax) (id : Option Name) (lctx : LocalContext) (structName : Name)
| namespaceId (stx : Syntax)
| option (stx : Syntax)
| endSection (stx : Syntax) (scopeNames : List String)
@@ -165,10 +177,18 @@ regular delaboration settings.
structure OmissionInfo extends TermInfo where
reason : String
/--
Indicates that all overloaded elaborators failed. The subtrees of a `ChoiceInfo` node are the
partial `InfoTree`s of those failed elaborators. Retaining these partial `InfoTree`s helps
the language server provide interactivity even when all overloaded elaborators failed.
-/
structure ChoiceInfo extends ElabInfo where
/-- Header information for a node in `InfoTree`. -/
inductive Info where
| ofTacticInfo (i : TacticInfo)
| ofTermInfo (i : TermInfo)
| ofPartialTermInfo (i : PartialTermInfo)
| ofCommandInfo (i : CommandInfo)
| ofMacroExpansionInfo (i : MacroExpansionInfo)
| ofOptionInfo (i : OptionInfo)
@@ -179,6 +199,7 @@ inductive Info where
| ofFVarAliasInfo (i : FVarAliasInfo)
| ofFieldRedeclInfo (i : FieldRedeclInfo)
| ofOmissionInfo (i : OmissionInfo)
| ofChoiceInfo (i : ChoiceInfo)
deriving Inhabited
/-- The InfoTree is a structure that is generated during elaboration and used

View File

@@ -90,9 +90,12 @@ private def elabLetRecDeclValues (view : LetRecView) : TermElabM (Array Expr) :=
for i in [0:view.binderIds.size] do
addLocalVarInfo view.binderIds[i]! xs[i]!
withDeclName view.declName do
withInfoContext' view.valStx (mkInfo := (pure <| .inl <| mkBodyInfo view.valStx ·)) do
let value elabTermEnsuringType view.valStx type
mkLambdaFVars xs value
withInfoContext' view.valStx
(mkInfo := (pure <| .inl <| mkBodyInfo view.valStx ·))
(mkInfoOnError := (pure <| mkBodyInfo view.valStx none))
do
let value elabTermEnsuringType view.valStx type
mkLambdaFVars xs value
private def registerLetRecsToLift (views : Array LetRecDeclView) (fvars : Array Expr) (values : Array Expr) : TermElabM Unit := do
let letRecsToLiftCurr := ( get).letRecsToLift

View File

@@ -644,7 +644,7 @@ where
if inaccessible? p |>.isSome then
return mkMData k ( withReader (fun _ => true) (go b))
else if let some (stx, p) := patternWithRef? p then
Elab.withInfoContext' (go p) fun p => do
Elab.withInfoContext' (go p) (mkInfoOnError := mkPartialTermInfo .anonymous stx) fun p => do
/- If `p` is a free variable and we are not inside of an "inaccessible" pattern, this `p` is a binder. -/
mkTermInfo Name.anonymous stx p (isBinder := p.isFVar && !( read))
else

View File

@@ -283,7 +283,7 @@ private partial def withFunLocalDecls {α} (headers : Array DefViewElabHeader) (
loop 0 #[]
private def expandWhereStructInst : Macro
| `(Parser.Command.whereStructInst|where $[$decls:letDecl];* $[$whereDecls?:whereDecls]?) => do
| whereStx@`(Parser.Command.whereStructInst|where%$whereTk $[$decls:letDecl];* $[$whereDecls?:whereDecls]?) => do
let letIdDecls decls.mapM fun stx => match stx with
| `(letDecl|$_decl:letPatDecl) => Macro.throwErrorAt stx "patterns are not allowed here"
| `(letDecl|$decl:letEqnsDecl) => expandLetEqnsDecl decl (useExplicit := false)
@@ -300,7 +300,30 @@ private def expandWhereStructInst : Macro
`(structInstField|$id:ident := $val)
| stx@`(letIdDecl|_ $_* $[: $_]? := $_) => Macro.throwErrorAt stx "'_' is not allowed here"
| _ => Macro.throwUnsupported
let startOfStructureTkInfo : SourceInfo :=
match whereTk.getPos? with
| some pos => .synthetic pos pos.byteIdx + 1 true
| none => .none
-- Position the closing `}` at the end of the trailing whitespace of `where $[$_:letDecl];*`.
-- We need an accurate range of the generated structure instance in the generated `TermInfo`
-- so that we can determine the expected type in structure field completion.
let structureStxTailInfo :=
whereStx[1].getTailInfo?
<|> whereStx[0].getTailInfo?
let endOfStructureTkInfo : SourceInfo :=
match structureStxTailInfo with
| some (SourceInfo.original _ _ trailing _) =>
let tokenPos := trailing.str.prev trailing.stopPos
let tokenEndPos := trailing.stopPos
.synthetic tokenPos tokenEndPos true
| _ => .none
let body `(structInst| { $structInstFields,* })
let body := body.raw.setInfo <|
match startOfStructureTkInfo.getPos?, endOfStructureTkInfo.getTailPos? with
| some startPos, some endPos => .synthetic startPos endPos true
| _, _ => .none
match whereDecls? with
| some whereDecls => expandWhereDecls whereDecls body
| none => return body
@@ -417,12 +440,15 @@ private def elabFunValues (headers : Array DefViewElabHeader) (vars : Array Expr
-- Store instantiated body in info tree for the benefit of the unused variables linter
-- and other metaprograms that may want to inspect it without paying for the instantiation
-- again
withInfoContext' valStx (mkInfo := (pure <| .inl <| mkBodyInfo valStx ·)) do
-- synthesize mvars here to force the top-level tactic block (if any) to run
let val elabTermEnsuringType valStx type <* synthesizeSyntheticMVarsNoPostponing
-- NOTE: without this `instantiatedMVars`, `mkLambdaFVars` may leave around a redex that
-- leads to more section variables being included than necessary
instantiateMVarsProfiling val
withInfoContext' valStx
(mkInfo := (pure <| .inl <| mkBodyInfo valStx ·))
(mkInfoOnError := (pure <| mkBodyInfo valStx none))
do
-- synthesize mvars here to force the top-level tactic block (if any) to run
let val elabTermEnsuringType valStx type <* synthesizeSyntheticMVarsNoPostponing
-- NOTE: without this `instantiatedMVars`, `mkLambdaFVars` may leave around a redex that
-- leads to more section variables being included than necessary
instantiateMVarsProfiling val
let val mkLambdaFVars xs val
if linter.unusedSectionVars.get ( getOptions) && !header.type.hasSorry && !val.hasSorry then
let unusedVars vars.filterMapM fun var => do

View File

@@ -50,7 +50,9 @@ private partial def mkProof (declName : Name) (type : Expr) : MetaM Expr := do
go mvarId
else if let some mvarId whnfReducibleLHS? mvarId then
go mvarId
else match ( simpTargetStar mvarId { config.dsimp := false } (simprocs := {})).1 with
else
let ctx Simp.mkContext (config := { dsimp := false })
match ( simpTargetStar mvarId ctx (simprocs := {})).1 with
| TacticResultCNM.closed => return ()
| TacticResultCNM.modified mvarId => go mvarId
| TacticResultCNM.noChange =>

View File

@@ -45,7 +45,9 @@ where
go mvarId
else if let some mvarId simpIf? mvarId then
go mvarId
else match ( simpTargetStar mvarId {} (simprocs := {})).1 with
else
let ctx Simp.mkContext
match ( simpTargetStar mvarId ctx (simprocs := {})).1 with
| TacticResultCNM.closed => return ()
| TacticResultCNM.modified mvarId => go mvarId
| TacticResultCNM.noChange =>

View File

@@ -243,7 +243,7 @@ def tryAllArgs (fnNames : Array Name) (xs : Array Expr) (values : Array Expr)
recArgInfoss := recArgInfoss.push recArgInfos
-- Put non-indices first
recArgInfoss := recArgInfoss.map nonIndicesFirst
trace[Elab.definition.structural] "recArgInfoss: {recArgInfoss.map (·.map (·.recArgPos))}"
trace[Elab.definition.structural] "recArgInfos:{indentD (.joinSep (recArgInfoss.flatten.toList.map (repr ·)) Format.line)}"
-- Inductive groups to consider
let groups inductiveGroups recArgInfoss.flatten
trace[Elab.definition.structural] "inductive groups: {groups}"

View File

@@ -27,7 +27,7 @@ constituents.
structure IndGroupInfo where
all : Array Name
numNested : Nat
deriving BEq, Inhabited
deriving BEq, Inhabited, Repr
def IndGroupInfo.ofInductiveVal (indInfo : InductiveVal) : IndGroupInfo where
all := indInfo.all.toArray
@@ -56,7 +56,7 @@ mutual structural recursion on such incompatible types.
structure IndGroupInst extends IndGroupInfo where
levels : List Level
params : Array Expr
deriving Inhabited
deriving Inhabited, Repr
def IndGroupInst.toMessageData (igi : IndGroupInst) : MessageData :=
mkAppN (.const igi.all[0]! igi.levels) igi.params

View File

@@ -23,9 +23,9 @@ structure RecArgInfo where
fnName : Name
/-- the fixed prefix of arguments of the function we are trying to justify termination using structural recursion. -/
numFixed : Nat
/-- position of the argument (counted including fixed prefix) we are recursing on -/
/-- position (counted including fixed prefix) of the argument we are recursing on -/
recArgPos : Nat
/-- position of the indices (counted including fixed prefix) of the inductive datatype indices we are recursing on -/
/-- position (counted including fixed prefix) of the indices of the inductive datatype we are recursing on -/
indicesPos : Array Nat
/-- The inductive group (with parameters) of the argument's type -/
indGroupInst : IndGroupInst
@@ -34,20 +34,23 @@ structure RecArgInfo where
If `< indAll.all`, a normal data type, else an auxiliary data type due to nested recursion
-/
indIdx : Nat
deriving Inhabited
deriving Inhabited, Repr
/--
If `xs` are the parameters of the functions (excluding fixed prefix), partitions them
into indices and major arguments, and other parameters.
-/
def RecArgInfo.pickIndicesMajor (info : RecArgInfo) (xs : Array Expr) : (Array Expr × Array Expr) := Id.run do
-- First indices and major arg, using the order they appear in `info.indicesPos`
let mut indexMajorArgs := #[]
let indexMajorPos := info.indicesPos.push info.recArgPos
for j in indexMajorPos do
assert! info.numFixed j && j - info.numFixed < xs.size
indexMajorArgs := indexMajorArgs.push xs[j - info.numFixed]!
-- Then the other arguments, in the order they appear in `xs`
let mut otherArgs := #[]
for h : i in [:xs.size] do
let j := i + info.numFixed
if j = info.recArgPos || info.indicesPos.contains j then
indexMajorArgs := indexMajorArgs.push xs[i]
else
unless indexMajorPos.contains (i + info.numFixed) do
otherArgs := otherArgs.push xs[i]
return (indexMajorArgs, otherArgs)

View File

@@ -57,7 +57,9 @@ private partial def mkProof (declName : Name) (type : Expr) : MetaM Expr := do
go mvarId
else if let some mvarId whnfReducibleLHS? mvarId then
go mvarId
else match ( simpTargetStar mvarId { config.dsimp := false } (simprocs := {})).1 with
else
let ctx Simp.mkContext (config := { dsimp := false })
match ( simpTargetStar mvarId ctx (simprocs := {})).1 with
| TacticResultCNM.closed => return ()
| TacticResultCNM.modified mvarId => go mvarId
| TacticResultCNM.noChange =>

View File

@@ -227,7 +227,7 @@ def mkFix (preDef : PreDefinition) (prefixArgs : Array Expr) (argsPacker : ArgsP
-- decreasing goals when the function has only one non fixed argument.
-- This renaming is irrelevant if the function has multiple non fixed arguments. See `process*` functions above.
let lctx := ( getLCtx).setUserName x.fvarId! varName
withTheReader Meta.Context (fun ctx => { ctx with lctx }) do
withLCtx' lctx do
let F := xs[1]!
let val := preDef.value.beta (prefixArgs.push x)
let val processSumCasesOn x F val fun x F val => do

View File

@@ -166,7 +166,7 @@ def mayOmitSizeOf (is_mutual : Bool) (args : Array Expr) (x : Expr) : MetaM Bool
def withUserNames {α} (xs : Array Expr) (ns : Array Name) (k : MetaM α) : MetaM α := do
let mut lctx getLCtx
for x in xs, n in ns do lctx := lctx.setUserName x.fvarId! n
withTheReader Meta.Context (fun ctx => { ctx with lctx }) k
withLCtx' lctx k
/-- Create one measure for each (eligible) parameter of the given predefintion. -/
def simpleMeasures (preDefs : Array PreDefinition) (fixedPrefixSize : Nat)

View File

@@ -22,7 +22,7 @@ private def levelParamsToMessageData (levelParams : List Name) : MessageData :=
m := m ++ ", " ++ toMessageData u
return m ++ "}"
private def mkHeader (kind : String) (id : Name) (levelParams : List Name) (type : Expr) (safety : DefinitionSafety) : CommandElabM MessageData := do
private def mkHeader (kind : String) (id : Name) (levelParams : List Name) (type : Expr) (safety : DefinitionSafety) (sig : Bool := true) : CommandElabM MessageData := do
let m : MessageData :=
match ( getReducibilityStatus id) with
| ReducibilityStatus.irreducible => "@[irreducible] "
@@ -38,11 +38,13 @@ private def mkHeader (kind : String) (id : Name) (levelParams : List Name) (type
let (m, id) := match privateToUserName? id with
| some id => (m ++ "private ", id)
| none => (m, id)
let m := m ++ kind ++ " " ++ id ++ levelParamsToMessageData levelParams ++ " : " ++ type
pure m
if sig then
return m!"{m}{kind} {id}{levelParamsToMessageData levelParams} : {type}"
else
return m!"{m}{kind}"
private def mkHeader' (kind : String) (id : Name) (levelParams : List Name) (type : Expr) (isUnsafe : Bool) : CommandElabM MessageData :=
mkHeader kind id levelParams type (if isUnsafe then DefinitionSafety.unsafe else DefinitionSafety.safe)
private def mkHeader' (kind : String) (id : Name) (levelParams : List Name) (type : Expr) (isUnsafe : Bool) (sig : Bool := true) : CommandElabM MessageData :=
mkHeader kind id levelParams type (if isUnsafe then DefinitionSafety.unsafe else DefinitionSafety.safe) (sig := sig)
private def printDefLike (kind : String) (id : Name) (levelParams : List Name) (type : Expr) (value : Expr) (safety := DefinitionSafety.safe) : CommandElabM Unit := do
let m mkHeader kind id levelParams type safety
@@ -65,32 +67,63 @@ private def printInduct (id : Name) (levelParams : List Name) (numParams : Nat)
m := m ++ Format.line ++ ctor ++ " : " ++ cinfo.type
logInfo m
/--
Computes the origin of a field. Returns its projection function at the origin.
Multiple parents could be the origin of a field, but we say the first parent that provides it is the one that determines the origin.
-/
private partial def getFieldOrigin (structName field : Name) : MetaM Name := do
let env getEnv
for parent in getStructureParentInfo env structName do
if (findField? env parent.structName field).isSome then
return getFieldOrigin parent.structName field
let some fi := getFieldInfo? env structName field
| throwError "no such field {field} in {structName}"
return fi.projFn
open Meta in
private def printStructure (id : Name) (levelParams : List Name) (numParams : Nat) (type : Expr)
(ctor : Name) (fields : Array Name) (isUnsafe : Bool) (isClass : Bool) : CommandElabM Unit := do
let kind := if isClass then "class" else "structure"
let mut m mkHeader' kind id levelParams type isUnsafe
m := m ++ Format.line ++ "number of parameters: " ++ toString numParams
m := m ++ Format.line ++ "constructor:"
let cinfo getConstInfo ctor
m := m ++ Format.line ++ ctor ++ " : " ++ cinfo.type
m := m ++ Format.line ++ "fields:" ++ ( doFields)
logInfo m
where
doFields := liftTermElabM do
forallTelescope ( getConstInfo id).type fun params _ =>
withLocalDeclD `self (mkAppN (Expr.const id (levelParams.map .param)) params) fun self => do
let params := params.push self
let mut m : MessageData := ""
(isUnsafe : Bool) : CommandElabM Unit := do
let env getEnv
let kind := if isClass env id then "class" else "structure"
let header mkHeader' kind id levelParams type isUnsafe (sig := false)
liftTermElabM <| forallTelescope ( getConstInfo id).type fun params _ =>
let s := Expr.const id (levelParams.map .param)
withLocalDeclD `self (mkAppN s params) fun self => do
let mut m : MessageData := header
-- Signature
m := m ++ " " ++ .ofFormatWithInfosM do
let (stx, infos) PrettyPrinter.delabCore s (delab := PrettyPrinter.Delaborator.delabConstWithSignature)
pure PrettyPrinter.ppTerm stx, infos
m := m ++ Format.line ++ m!"number of parameters: {numParams}"
-- Parents
let parents := getStructureParentInfo env id
unless parents.isEmpty do
m := m ++ Format.line ++ "parents:"
for parent in parents do
let ptype inferType (mkApp (mkAppN (.const parent.projFn (levelParams.map .param)) params) self)
m := m ++ indentD m!"{.ofConstName parent.projFn (fullNames := true)} : {ptype}"
-- Fields
let fields := getStructureFieldsFlattened env id (includeSubobjectFields := false)
if fields.isEmpty then
m := m ++ Format.line ++ "fields: (none)"
else
m := m ++ Format.line ++ "fields:"
for field in fields do
match getProjFnForField? ( getEnv) id field with
| some proj =>
let field : Format := if isPrivateName proj then "private " ++ toString field else toString field
let cinfo getConstInfo proj
let ftype instantiateForall cinfo.type params
m := m ++ Format.line ++ field ++ " : " ++ ftype
| none => panic! "missing structure field info"
addMessageContext m
let some source := findField? env id field | panic! "missing structure field info"
let proj getFieldOrigin source field
let modifier := if isPrivateName proj then "private " else ""
let ftype inferType ( mkProjection self field)
m := m ++ indentD (m!"{modifier}{.ofConstName proj (fullNames := true)} : {ftype}")
-- Constructor
let cinfo := getStructureCtor ( getEnv) id
let ctorModifier := if isPrivateName cinfo.name then "private " else ""
m := m ++ Format.line ++ "constructor:" ++ indentD (ctorModifier ++ .signature cinfo.name)
-- Resolution order
let resOrder getStructureResolutionOrder id
if resOrder.size > 1 then
m := m ++ Format.line ++ "resolution order:"
++ indentD (MessageData.joinSep (resOrder.map (.ofConstName · (fullNames := true))).toList ", ")
logInfo m
private def printIdCore (id : Name) : CommandElabM Unit := do
let env getEnv
@@ -103,11 +136,10 @@ private def printIdCore (id : Name) : CommandElabM Unit := do
| ConstantInfo.ctorInfo { levelParams := us, type := t, isUnsafe := u, .. } => printAxiomLike "constructor" id us t u
| ConstantInfo.recInfo { levelParams := us, type := t, isUnsafe := u, .. } => printAxiomLike "recursor" id us t u
| ConstantInfo.inductInfo { levelParams := us, numParams, type := t, ctors, isUnsafe := u, .. } =>
match getStructureInfo? env id with
| some { fieldNames, .. } =>
let [ctor] := ctors | panic! "structures have only one constructor"
printStructure id us numParams t ctor fieldNames u (isClass env id)
| none => printInduct id us numParams t ctors u
if isStructure env id then
printStructure id us numParams t u
else
printInduct id us numParams t ctors u
| none => throwUnknownId id
private def printId (id : Syntax) : CommandElabM Unit := do

View File

@@ -11,21 +11,40 @@ import Lean.Elab.App
import Lean.Elab.Binders
import Lean.PrettyPrinter
/-!
# Structure instance elaborator
A *structure instance* is notation to construct a term of a `structure`.
Examples: `{ x := 2, y.z := true }`, `{ s with cache := c' }`, and `{ s with values[2] := v }`.
Structure instances are the preferred way to invoke a `structure`'s constructor,
since they hide Lean implementation details such as whether parents are represented as subobjects,
and also they do correct processing of default values, which are complicated due to the fact that `structure`s can override default values of their parents.
This module elaborates structure instance notation.
Note that the `where` syntax to define structures (`Lean.Parser.Command.whereStructInst`)
macro expands into the structure instance notation elaborated by this module.
-/
namespace Lean.Elab.Term.StructInst
open Meta
open TSyntax.Compat
/-
Structure instances are of the form:
"{" >> optional (atomic (sepBy1 termParser ", " >> " with "))
>> manyIndent (group ((structInstFieldAbbrev <|> structInstField) >> optional ", "))
>> optEllipsis
>> optional (" : " >> termParser)
>> " }"
/-!
Recall that structure instances are of the form:
```
"{" >> optional (atomic (sepBy1 termParser ", " >> " with "))
>> manyIndent (group ((structInstFieldAbbrev <|> structInstField) >> optional ", "))
>> optEllipsis
>> optional (" : " >> termParser)
>> " }"
```
-/
/--
Transforms structure instances such as `{ x := 0 : Foo }` into `({ x := 0 } : Foo)`.
Structure instance notation makes use of the expected type.
-/
@[builtin_macro Lean.Parser.Term.structInst] def expandStructInstExpectedType : Macro := fun stx =>
let expectedArg := stx[4]
if expectedArg.isNone then
@@ -35,7 +54,10 @@ open TSyntax.Compat
let stxNew := stx.setArg 4 mkNullNode
`(($stxNew : $expected))
/-- Expand field abbreviations. Example: `{ x, y := 0 }` expands to `{ x := x, y := 0 }` -/
/--
Expands field abbreviation notation.
Example: `{ x, y := 0 }` expands to `{ x := x, y := 0 }`.
-/
@[builtin_macro Lean.Parser.Term.structInst] def expandStructInstFieldAbbrev : Macro
| `({ $[$srcs,* with]? $fields,* $[..%$ell]? $[: $ty]? }) =>
if fields.getElems.raw.any (·.getKind == ``Lean.Parser.Term.structInstFieldAbbrev) then do
@@ -49,9 +71,12 @@ open TSyntax.Compat
| _ => Macro.throwUnsupported
/--
If `stx` is of the form `{ s₁, ..., sₙ with ... }` and `sᵢ` is not a local variable, expand into `let src := sᵢ; { ..., src, ... with ... }`.
If `stx` is of the form `{ s₁, ..., sₙ with ... }` and `sᵢ` is not a local variable,
expands into `let __src := sᵢ; { ..., __src, ... with ... }`.
The significance of `__src` is that the variable is treated as an implementation-detail local variable,
which can be unfolded by `simp` when `zetaDelta := false`.
Note that this one is not a `Macro` because we need to access the local context.
Note that this one is not a `Macro` because we need to access the local context.
-/
private def expandNonAtomicExplicitSources (stx : Syntax) : TermElabM (Option Syntax) := do
let sourcesOpt := stx[1]
@@ -100,27 +125,44 @@ where
let r go sources (sourcesNew.push sourceNew)
`(let __src := $source; $r)
structure ExplicitSourceInfo where
/--
An *explicit source* is one of the structures `sᵢ` that appear in `{ s₁, …, sₙ with … }`.
-/
structure ExplicitSourceView where
/-- The syntax of the explicit source. -/
stx : Syntax
/-- The name of the structure for the type of the explicit source. -/
structName : Name
deriving Inhabited
structure Source where
explicit : Array ExplicitSourceInfo -- `s₁ ... sₙ with`
implicit : Option Syntax -- `..`
/--
A view of the sources of fields for the structure instance notation.
-/
structure SourcesView where
/-- Explicit sources (i.e., one of the structures `sᵢ` that appear in `{ s₁, …, sₙ with … }`). -/
explicit : Array ExplicitSourceView
/-- The syntax for a trailing `..`. This is "ellipsis mode" for missing fields, similar to ellipsis mode for applications. -/
implicit : Option Syntax
deriving Inhabited
def Source.isNone : Source Bool
/-- Returns `true` if the structure instance has no sources (neither explicit sources nor a `..`). -/
def SourcesView.isNone : SourcesView Bool
| { explicit := #[], implicit := none } => true
| _ => false
/-- `optional (atomic (sepBy1 termParser ", " >> " with ")` -/
/--
Given an array of explicit sources, returns syntax of the form
`optional (atomic (sepBy1 termParser ", " >> " with ")`
-/
private def mkSourcesWithSyntax (sources : Array Syntax) : Syntax :=
let ref := sources[0]!
let stx := Syntax.mkSep sources (mkAtomFrom ref ", ")
mkNullNode #[stx, mkAtomFrom ref "with "]
private def getStructSource (structStx : Syntax) : TermElabM Source :=
/--
Creates a structure source view from structure instance notation.
-/
private def getStructSources (structStx : Syntax) : TermElabM SourcesView :=
withRef structStx do
let explicitSource := structStx[1]
let implicitSource := structStx[3]
@@ -138,13 +180,13 @@ private def getStructSource (structStx : Syntax) : TermElabM Source :=
return { explicit, implicit }
/--
We say a `{ ... }` notation is a `modifyOp` if it contains only one
```
def structInstArrayRef := leading_parser "[" >> termParser >>"]"
```
We say a structure instance notation is a "modifyOp" if it contains only a single array update.
```lean
def structInstArrayRef := leading_parser "[" >> termParser >>"]"
```
-/
private def isModifyOp? (stx : Syntax) : TermElabM (Option Syntax) := do
let s? stx[2].getSepArgs.foldlM (init := none) fun s? arg => do
let s? stx[2][0].getSepArgs.foldlM (init := none) fun s? arg => do
/- arg is of the form `structInstFieldAbbrev <|> structInstField` -/
if arg.getKind == ``Lean.Parser.Term.structInstField then
/- Remark: the syntax for `structInstField` is
@@ -177,7 +219,11 @@ private def isModifyOp? (stx : Syntax) : TermElabM (Option Syntax) := do
| none => return none
| some s => if s[0][0].getKind == ``Lean.Parser.Term.structInstArrayRef then return s? else return none
private def elabModifyOp (stx modifyOp : Syntax) (sources : Array ExplicitSourceInfo) (expectedType? : Option Expr) : TermElabM Expr := do
/--
Given a `stx` that is a structure instance notation that's a modifyOp (according to `isModifyOp?`), elaborates it.
Only supports structure instances with a single source.
-/
private def elabModifyOp (stx modifyOp : Syntax) (sources : Array ExplicitSourceView) (expectedType? : Option Expr) : TermElabM Expr := do
if sources.size > 1 then
throwError "invalid \{...} notation, multiple sources and array update is not supported."
let cont (val : Syntax) : TermElabM Expr := do
@@ -199,17 +245,18 @@ private def elabModifyOp (stx modifyOp : Syntax) (sources : Array ExplicitSource
let valField := modifyOp.setArg 0 <| mkNode ``Parser.Term.structInstLVal #[valFirst, valRest]
let valSource := mkSourcesWithSyntax #[s]
let val := stx.setArg 1 valSource
let val := val.setArg 2 <| mkNullNode #[valField]
let val := val.setArg 2 <| mkNode ``Parser.Term.structInstFields #[mkNullNode #[valField]]
trace[Elab.struct.modifyOp] "{stx}\nval: {val}"
cont val
/--
Get structure name.
This method triest to postpone execution if the expected type is not available.
Gets the structure name for the structure instance from the expected type and the sources.
This method tries to postpone execution if the expected type is not available.
If the expected type is available and it is a structure, then we use it.
Otherwise, we use the type of the first source. -/
private def getStructName (expectedType? : Option Expr) (sourceView : Source) : TermElabM Name := do
If the expected type is available and it is a structure, then we use it.
Otherwise, we use the type of the first source.
-/
private def getStructName (expectedType? : Option Expr) (sourceView : SourcesView) : TermElabM Name := do
tryPostponeIfNoneOrMVar expectedType?
let useSource : Unit TermElabM Name := fun _ => do
unless sourceView.explicit.isEmpty do
@@ -226,7 +273,7 @@ private def getStructName (expectedType? : Option Expr) (sourceView : Source) :
unless isStructure ( getEnv) constName do
throwError "invalid \{...} notation, structure type expected{indentExpr expectedType}"
return constName
| _ => useSource ()
| _ => useSource ()
where
throwUnknownExpectedType :=
throwError "invalid \{...} notation, expected type is not known"
@@ -237,72 +284,92 @@ where
else
throwError "invalid \{...} notation, {kind} type is not of the form (C ...){indentExpr type}"
/--
A component of a left-hand side for a field appearing in structure instance syntax.
-/
inductive FieldLHS where
/-- A name component for a field left-hand side. For example, `x` and `y` in `{ x.y := v }`. -/
| fieldName (ref : Syntax) (name : Name)
/-- A numeric index component for a field left-hand side. For example `3` in `{ x.3 := v }`. -/
| fieldIndex (ref : Syntax) (idx : Nat)
/-- An array indexing component for a field left-hand side. For example `[3]` in `{ arr[3] := v }`. -/
| modifyOp (ref : Syntax) (index : Syntax)
deriving Inhabited
instance : ToFormat FieldLHS := fun lhs =>
match lhs with
| .fieldName _ n => format n
| .fieldIndex _ i => format i
| .modifyOp _ i => "[" ++ i.prettyPrint ++ "]"
instance : ToFormat FieldLHS where
format
| .fieldName _ n => format n
| .fieldIndex _ i => format i
| .modifyOp _ i => "[" ++ i.prettyPrint ++ "]"
/--
`FieldVal StructInstView` is a representation of a field value in the structure instance.
-/
inductive FieldVal (σ : Type) where
| term (stx : Syntax) : FieldVal σ
/-- A `term` to use for the value of the field. -/
| term (stx : Syntax) : FieldVal σ
/-- A `StructInstView` to use for the value of a subobject field. -/
| nested (s : σ) : FieldVal σ
| default : FieldVal σ -- mark that field must be synthesized using default value
/-- A field that was not provided and should be synthesized using default values. -/
| default : FieldVal σ
deriving Inhabited
/--
`Field StructInstView` is a representation of a field in the structure instance.
-/
structure Field (σ : Type) where
/-- The whole field syntax. -/
ref : Syntax
/-- The LHS decomposed into components. -/
lhs : List FieldLHS
/-- The value of the field. -/
val : FieldVal σ
/-- The elaborated field value, filled in at `elabStruct`.
Missing fields use a metavariable for the elaborated value and are later solved for in `DefaultFields.propagate`. -/
expr? : Option Expr := none
deriving Inhabited
/--
Returns if the field has a single component in its LHS.
-/
def Field.isSimple {σ} : Field σ Bool
| { lhs := [_], .. } => true
| _ => false
inductive Struct where
/-- Remark: the field `params` is use for default value propagation. It is initially empty, and then set at `elabStruct`. -/
| mk (ref : Syntax) (structName : Name) (params : Array (Name × Expr)) (fields : List (Field Struct)) (source : Source)
/--
The view for structure instance notation.
-/
structure StructInstView where
/-- The syntax for the whole structure instance. -/
ref : Syntax
/-- The name of the structure for the type of the structure instance. -/
structName : Name
/-- Used for default values, to propagate structure type parameters. It is initially empty, and then set at `elabStruct`. -/
params : Array (Name × Expr)
/-- The fields of the structure instance. -/
fields : List (Field StructInstView)
/-- The additional sources for fields for the structure instance. -/
sources : SourcesView
deriving Inhabited
abbrev Fields := List (Field Struct)
def Struct.ref : Struct Syntax
| ref, _, _, _, _ => ref
def Struct.structName : Struct Name
| _, structName, _, _, _ => structName
def Struct.params : Struct Array (Name × Expr)
| _, _, params, _, _ => params
def Struct.fields : Struct Fields
| _, _, _, fields, _ => fields
def Struct.source : Struct Source
| _, _, _, _, s => s
/-- Abbreviation for the type of `StructInstView.fields`, namely `List (Field StructInstView)`. -/
abbrev Fields := List (Field StructInstView)
/-- `true` iff all fields of the given structure are marked as `default` -/
partial def Struct.allDefault (s : Struct) : Bool :=
partial def StructInstView.allDefault (s : StructInstView) : Bool :=
s.fields.all fun { val := val, .. } => match val with
| .term _ => false
| .default => true
| .nested s => allDefault s
def formatField (formatStruct : Struct Format) (field : Field Struct) : Format :=
def formatField (formatStruct : StructInstView Format) (field : Field StructInstView) : Format :=
Format.joinSep field.lhs " . " ++ " := " ++
match field.val with
| .term v => v.prettyPrint
| .nested s => formatStruct s
| .default => "<default>"
partial def formatStruct : Struct Format
partial def formatStruct : StructInstView Format
| _, _, _, fields, source =>
let fieldsFmt := Format.joinSep (fields.map (formatField formatStruct)) ", "
let implicitFmt := if source.implicit.isSome then " .. " else ""
@@ -311,31 +378,39 @@ partial def formatStruct : Struct → Format
else
"{" ++ format (source.explicit.map (·.stx)) ++ " with " ++ fieldsFmt ++ implicitFmt ++ "}"
instance : ToFormat Struct := formatStruct
instance : ToString Struct := toString format
instance : ToFormat StructInstView := formatStruct
instance : ToString StructInstView := toString format
instance : ToFormat (Field Struct) := formatField formatStruct
instance : ToString (Field Struct) := toString format
instance : ToFormat (Field StructInstView) := formatField formatStruct
instance : ToString (Field StructInstView) := toString format
/--
Converts a `FieldLHS` back into syntax. This assumes the `ref` fields have the correct structure.
/-
Recall that `structInstField` elements have the form
```
def structInstField := leading_parser structInstLVal >> " := " >> termParser
def structInstLVal := leading_parser (ident <|> numLit <|> structInstArrayRef) >> many (("." >> (ident <|> numLit)) <|> structInstArrayRef)
def structInstArrayRef := leading_parser "[" >> termParser >>"]"
```lean
def structInstField := leading_parser structInstLVal >> " := " >> termParser
def structInstLVal := leading_parser (ident <|> numLit <|> structInstArrayRef) >> many (("." >> (ident <|> numLit)) <|> structInstArrayRef)
def structInstArrayRef := leading_parser "[" >> termParser >>"]"
```
-/
-- Remark: this code relies on the fact that `expandStruct` only transforms `fieldLHS.fieldName`
def FieldLHS.toSyntax (first : Bool) : FieldLHS Syntax
private def FieldLHS.toSyntax (first : Bool) : FieldLHS Syntax
| .modifyOp stx _ => stx
| .fieldName stx name => if first then mkIdentFrom stx name else mkGroupNode #[mkAtomFrom stx ".", mkIdentFrom stx name]
| .fieldIndex stx _ => if first then stx else mkGroupNode #[mkAtomFrom stx ".", stx]
def FieldVal.toSyntax : FieldVal Struct Syntax
/--
Converts a `FieldVal StructInstView` back into syntax. Only supports `.term`, and it assumes the `stx` field has the correct structure.
-/
private def FieldVal.toSyntax : FieldVal Struct Syntax
| .term stx => stx
| _ => unreachable!
| _ => unreachable!
def Field.toSyntax : Field Struct Syntax
/--
Converts a `Field StructInstView` back into syntax. Used to construct synthetic structure instance notation for subobjects in `StructInst.expandStruct` processing.
-/
private def Field.toSyntax : Field Struct Syntax
| field =>
let stx := field.ref
let stx := stx.setArg 2 field.val.toSyntax
@@ -343,6 +418,7 @@ def Field.toSyntax : Field Struct → Syntax
| first::rest => stx.setArg 0 <| mkNullNode #[first.toSyntax true, mkNullNode <| rest.toArray.map (FieldLHS.toSyntax false) ]
| _ => unreachable!
/-- Creates a view of a field left-hand side. -/
private def toFieldLHS (stx : Syntax) : MacroM FieldLHS :=
if stx.getKind == ``Lean.Parser.Term.structInstArrayRef then
return FieldLHS.modifyOp stx stx[1]
@@ -355,11 +431,16 @@ private def toFieldLHS (stx : Syntax) : MacroM FieldLHS :=
| some idx => return FieldLHS.fieldIndex stx idx
| none => Macro.throwError "unexpected structure syntax"
private def mkStructView (stx : Syntax) (structName : Name) (source : Source) : MacroM Struct := do
/--
Creates a structure instance view from structure instance notation
and the computed structure name (from `Lean.Elab.Term.StructInst.getStructName`)
and structure source view (from `Lean.Elab.Term.StructInst.getStructSources`).
-/
private def mkStructView (stx : Syntax) (structName : Name) (sources : SourcesView) : MacroM StructInstView := do
/- Recall that `stx` is of the form
```
leading_parser "{" >> optional (atomic (sepBy1 termParser ", " >> " with "))
>> sepByIndent (structInstFieldAbbrev <|> structInstField) ...
>> structInstFields (sepByIndent (structInstFieldAbbrev <|> structInstField) ...)
>> optional ".."
>> optional (" : " >> termParser)
>> " }"
@@ -367,28 +448,22 @@ private def mkStructView (stx : Syntax) (structName : Name) (source : Source) :
This method assumes that `structInstFieldAbbrev` had already been expanded.
-/
let fields stx[2].getSepArgs.toList.mapM fun fieldStx => do
let fields stx[2][0].getSepArgs.toList.mapM fun fieldStx => do
let val := fieldStx[2]
let first toFieldLHS fieldStx[0][0]
let rest fieldStx[0][1].getArgs.toList.mapM toFieldLHS
return { ref := fieldStx, lhs := first :: rest, val := FieldVal.term val : Field Struct }
return stx, structName, #[], fields, source
return { ref := fieldStx, lhs := first :: rest, val := FieldVal.term val : Field StructInstView }
return { ref := stx, structName, params := #[], fields, sources }
def Struct.modifyFieldsM {m : Type Type} [Monad m] (s : Struct) (f : Fields m Fields) : m Struct :=
def StructInstView.modifyFieldsM {m : Type Type} [Monad m] (s : StructInstView) (f : Fields m Fields) : m StructInstView :=
match s with
| ref, structName, params, fields, source => return ref, structName, params, ( f fields), source
| { ref, structName, params, fields, sources } => return { ref, structName, params, fields := ( f fields), sources }
def Struct.modifyFields (s : Struct) (f : Fields Fields) : Struct :=
def StructInstView.modifyFields (s : StructInstView) (f : Fields Fields) : StructInstView :=
Id.run <| s.modifyFieldsM f
def Struct.setFields (s : Struct) (fields : Fields) : Struct :=
s.modifyFields fun _ => fields
def Struct.setParams (s : Struct) (ps : Array (Name × Expr)) : Struct :=
match s with
| ref, structName, _, fields, source => ref, structName, ps, fields, source
private def expandCompositeFields (s : Struct) : Struct :=
/-- Expands name field LHSs with multi-component names into multi-component LHSs. -/
private def expandCompositeFields (s : StructInstView) : StructInstView :=
s.modifyFields fun fields => fields.map fun field => match field with
| { lhs := .fieldName _ (.str Name.anonymous ..) :: _, .. } => field
| { lhs := .fieldName ref n@(.str ..) :: rest, .. } =>
@@ -396,7 +471,8 @@ private def expandCompositeFields (s : Struct) : Struct :=
{ field with lhs := newEntries ++ rest }
| _ => field
private def expandNumLitFields (s : Struct) : TermElabM Struct :=
/-- Replaces numeric index field LHSs with the corresponding named field, or throws an error if no such field exists. -/
private def expandNumLitFields (s : StructInstView) : TermElabM StructInstView :=
s.modifyFieldsM fun fields => do
let env getEnv
let fieldNames := getStructureFields env s.structName
@@ -407,28 +483,31 @@ private def expandNumLitFields (s : Struct) : TermElabM Struct :=
else return { field with lhs := .fieldName ref fieldNames[idx - 1]! :: rest }
| _ => return field
/-- For example, consider the following structures:
```
structure A where
x : Nat
/--
Expands fields that are actually represented as fields of subobject fields.
structure B extends A where
y : Nat
For example, consider the following structures:
```
structure A where
x : Nat
structure C extends B where
z : Bool
```
This method expands parent structure fields using the path to the parent structure.
For example,
```
{ x := 0, y := 0, z := true : C }
```
is expanded into
```
{ toB.toA.x := 0, toB.y := 0, z := true : C }
```
structure B extends A where
y : Nat
structure C extends B where
z : Bool
```
This method expands parent structure fields using the path to the parent structure.
For example,
```
{ x := 0, y := 0, z := true : C }
```
is expanded into
```
{ toB.toA.x := 0, toB.y := 0, z := true : C }
```
-/
private def expandParentFields (s : Struct) : TermElabM Struct := do
private def expandParentFields (s : StructInstView) : TermElabM StructInstView := do
let env getEnv
s.modifyFieldsM fun fields => fields.mapM fun field => do match field with
| { lhs := .fieldName ref fieldName :: _, .. } =>
@@ -448,6 +527,11 @@ private def expandParentFields (s : Struct) : TermElabM Struct := do
private abbrev FieldMap := Std.HashMap Name Fields
/--
Creates a hash map collecting all fields with the same first name component.
Throws an error if there are multiple simple fields with the same name.
Used by `StructInst.expandStruct` processing.
-/
private def mkFieldMap (fields : Fields) : TermElabM FieldMap :=
fields.foldlM (init := {}) fun fieldMap field =>
match field.lhs with
@@ -461,15 +545,16 @@ private def mkFieldMap (fields : Fields) : TermElabM FieldMap :=
| _ => return fieldMap.insert fieldName [field]
| _ => unreachable!
private def isSimpleField? : Fields Option (Field Struct)
/--
Given a value of the hash map created by `mkFieldMap`, returns true if the value corresponds to a simple field.
-/
private def isSimpleField? : Fields Option (Field StructInstView)
| [field] => if field.isSimple then some field else none
| _ => none
private def getFieldIdx (structName : Name) (fieldNames : Array Name) (fieldName : Name) : TermElabM Nat := do
match fieldNames.findIdx? fun n => n == fieldName with
| some idx => return idx
| none => throwError "field '{fieldName}' is not a valid field of '{structName}'"
/--
Creates projection notation for the given structure field. Used
-/
def mkProjStx? (s : Syntax) (structName : Name) (fieldName : Name) : TermElabM (Option Syntax) := do
if (findField? ( getEnv) structName fieldName).isNone then
return none
@@ -478,7 +563,10 @@ def mkProjStx? (s : Syntax) (structName : Name) (fieldName : Name) : TermElabM (
#[mkAtomFrom s "@",
mkNode ``Parser.Term.proj #[s, mkAtomFrom s ".", mkIdentFrom s fieldName]]
def findField? (fields : Fields) (fieldName : Name) : Option (Field Struct) :=
/--
Finds a simple field of the given name.
-/
def findField? (fields : Fields) (fieldName : Name) : Option (Field StructInstView) :=
fields.find? fun field =>
match field.lhs with
| [.fieldName _ n] => n == fieldName
@@ -486,7 +574,10 @@ def findField? (fields : Fields) (fieldName : Name) : Option (Field Struct) :=
mutual
private partial def groupFields (s : Struct) : TermElabM Struct := do
/--
Groups compound fields according to which subobject they are from.
-/
private partial def groupFields (s : StructInstView) : TermElabM StructInstView := do
let env getEnv
withRef s.ref do
s.modifyFieldsM fun fields => do
@@ -499,26 +590,28 @@ mutual
let field := fields.head!
match Lean.isSubobjectField? env s.structName fieldName with
| some substructName =>
let substruct := Struct.mk s.ref substructName #[] substructFields s.source
let substruct := { ref := s.ref, structName := substructName, params := #[], fields := substructFields, sources := s.sources }
let substruct expandStruct substruct
pure { field with lhs := [field.lhs.head!], val := FieldVal.nested substruct }
| none =>
let updateSource (structStx : Syntax) : TermElabM Syntax := do
let sourcesNew s.source.explicit.filterMapM fun source => mkProjStx? source.stx source.structName fieldName
let sourcesNew s.sources.explicit.filterMapM fun source => mkProjStx? source.stx source.structName fieldName
let explicitSourceStx := if sourcesNew.isEmpty then mkNullNode else mkSourcesWithSyntax sourcesNew
let implicitSourceStx := s.source.implicit.getD mkNullNode
let implicitSourceStx := s.sources.implicit.getD mkNullNode
return (structStx.setArg 1 explicitSourceStx).setArg 3 implicitSourceStx
let valStx := s.ref -- construct substructure syntax using s.ref as template
let valStx := valStx.setArg 4 mkNullNode -- erase optional expected type
let args := substructFields.toArray.map (·.toSyntax)
let valStx := valStx.setArg 2 (mkNullNode <| mkSepArray args (mkAtom ","))
let fieldsStx := mkNode ``Parser.Term.structInstFields
#[mkNullNode <| mkSepArray args (mkAtom ",")]
let valStx := valStx.setArg 2 fieldsStx
let valStx updateSource valStx
return { field with lhs := [field.lhs.head!], val := FieldVal.term valStx }
/--
Adds in the missing fields using the explicit sources.
Invariant: a missing field always comes from the first source that can provide it.
-/
private partial def addMissingFields (s : Struct) : TermElabM Struct := do
private partial def addMissingFields (s : StructInstView) : TermElabM StructInstView := do
let env getEnv
let fieldNames := getStructureFields env s.structName
let ref := s.ref.mkSynthetic
@@ -527,7 +620,7 @@ mutual
match findField? s.fields fieldName with
| some field => return field::fields
| none =>
let addField (val : FieldVal Struct) : TermElabM Fields := do
let addField (val : FieldVal StructInstView) : TermElabM Fields := do
return { ref, lhs := [FieldLHS.fieldName ref fieldName], val := val } :: fields
match Lean.isSubobjectField? env s.structName fieldName with
| some substructName =>
@@ -535,8 +628,8 @@ mutual
let downFields := getStructureFieldsFlattened env substructName false
-- Filter out all explicit sources that do not share a leaf field keeping
-- structure with no fields
let filtered := s.source.explicit.filter fun source =>
let sourceFields := getStructureFieldsFlattened env source.structName false
let filtered := s.sources.explicit.filter fun sources =>
let sourceFields := getStructureFieldsFlattened env sources.structName false
sourceFields.any (fun name => downFields.contains name) || sourceFields.isEmpty
-- Take the first such one remaining
match filtered[0]? with
@@ -550,27 +643,30 @@ mutual
-- No sources could provide this subobject in the proper order.
-- Recurse to handle default values for fields.
else
let substruct := Struct.mk ref substructName #[] [] s.source
let substruct := { ref, structName := substructName, params := #[], fields := [], sources := s.sources }
let substruct expandStruct substruct
addField (FieldVal.nested substruct)
-- No sources could provide this subobject.
-- Recurse to handle default values for fields.
| none =>
let substruct := Struct.mk ref substructName #[] [] s.source
let substruct := { ref, structName := substructName, params := #[], fields := [], sources := s.sources }
let substruct expandStruct substruct
addField (FieldVal.nested substruct)
-- Since this is not a subobject field, we are free to use the first source that can
-- provide it.
| none =>
if let some val s.source.explicit.findSomeM? fun source => mkProjStx? source.stx source.structName fieldName then
if let some val s.sources.explicit.findSomeM? fun source => mkProjStx? source.stx source.structName fieldName then
addField (FieldVal.term val)
else if s.source.implicit.isSome then
else if s.sources.implicit.isSome then
addField (FieldVal.term (mkHole ref))
else
addField FieldVal.default
return s.setFields fields.reverse
return { s with fields := fields.reverse }
private partial def expandStruct (s : Struct) : TermElabM Struct := do
/--
Expands all fields of the structure instance, consolidates compound fields into subobject fields, and adds missing fields.
-/
private partial def expandStruct (s : StructInstView) : TermElabM StructInstView := do
let s := expandCompositeFields s
let s expandNumLitFields s
let s expandParentFields s
@@ -579,10 +675,17 @@ mutual
end
/--
The constructor to use for the structure instance notation.
-/
structure CtorHeaderResult where
/-- The constructor function with applied structure parameters. -/
ctorFn : Expr
/-- The type of `ctorFn` -/
ctorFnType : Expr
/-- Instance metavariables for structure parameters that are instance implicit. -/
instMVars : Array MVarId
/-- Type parameter names and metavariables for each parameter. Used to seed `StructInstView.params`. -/
params : Array (Name × Expr)
private def mkCtorHeaderAux : Nat Expr Expr Array MVarId Array (Name × Expr) TermElabM CtorHeaderResult
@@ -604,6 +707,7 @@ private partial def getForallBody : Nat → Expr → Option Expr
| _+1, _ => none
| 0, type => type
/-- Attempts to use the expected type to solve for structure parameters. -/
private def propagateExpectedType (type : Expr) (numFields : Nat) (expectedType? : Option Expr) : TermElabM Unit := do
match expectedType? with
| none => return ()
@@ -614,6 +718,7 @@ private def propagateExpectedType (type : Expr) (numFields : Nat) (expectedType?
unless typeBody.hasLooseBVars do
discard <| isDefEq expectedType typeBody
/-- Elaborates the structure constructor using the expected type, filling in all structure parameters. -/
private def mkCtorHeader (ctorVal : ConstructorVal) (expectedType? : Option Expr) : TermElabM CtorHeaderResult := do
let us mkFreshLevelMVars ctorVal.levelParams.length
let val := Lean.mkConst ctorVal.name us
@@ -623,32 +728,43 @@ private def mkCtorHeader (ctorVal : ConstructorVal) (expectedType? : Option Expr
synthesizeAppInstMVars r.instMVars r.ctorFn
return r
/-- Annotates an expression that it is a value for a missing field. -/
def markDefaultMissing (e : Expr) : Expr :=
mkAnnotation `structInstDefault e
/-- If the expression has been annotated by `markDefaultMissing`, returns the unannotated expression. -/
def defaultMissing? (e : Expr) : Option Expr :=
annotation? `structInstDefault e
/-- Throws "failed to elaborate field" error. -/
def throwFailedToElabField {α} (fieldName : Name) (structName : Name) (msgData : MessageData) : TermElabM α :=
throwError "failed to elaborate field '{fieldName}' of '{structName}, {msgData}"
def trySynthStructInstance? (s : Struct) (expectedType : Expr) : TermElabM (Option Expr) := do
/-- If the struct has all-missing fields, tries to synthesize the structure using typeclass inference. -/
def trySynthStructInstance? (s : StructInstView) (expectedType : Expr) : TermElabM (Option Expr) := do
if !s.allDefault then
return none
else
try synthInstance? expectedType catch _ => return none
/-- The result of elaborating a `StructInstView` structure instance view. -/
structure ElabStructResult where
/-- The elaborated value. -/
val : Expr
struct : Struct
/-- The modified `StructInstView` view after elaboration. -/
struct : StructInstView
/-- Metavariables for instance implicit fields. These will be registered after default value propagation. -/
instMVars : Array MVarId
private partial def elabStruct (s : Struct) (expectedType? : Option Expr) : TermElabM ElabStructResult := withRef s.ref do
/--
Main elaborator for structure instances.
-/
private partial def elabStructInstView (s : StructInstView) (expectedType? : Option Expr) : TermElabM ElabStructResult := withRef s.ref do
let env getEnv
let ctorVal := getStructureCtor env s.structName
if isPrivateNameFromImportedModule env ctorVal.name then
throwError "invalid \{...} notation, constructor for `{s.structName}` is marked as private"
-- We store the parameters at the resulting `Struct`. We use this information during default value propagation.
-- We store the parameters at the resulting `StructInstView`. We use this information during default value propagation.
let { ctorFn, ctorFnType, params, .. } mkCtorHeader ctorVal expectedType?
let (e, _, fields, instMVars) s.fields.foldlM (init := (ctorFn, ctorFnType, [], #[])) fun (e, type, fields, instMVars) field => do
match field.lhs with
@@ -657,7 +773,7 @@ private partial def elabStruct (s : Struct) (expectedType? : Option Expr) : Term
trace[Elab.struct] "elabStruct {field}, {type}"
match type with
| .forallE _ d b bi =>
let cont (val : Expr) (field : Field Struct) (instMVars := instMVars) : TermElabM (Expr × Expr × Fields × Array MVarId) := do
let cont (val : Expr) (field : Field StructInstView) (instMVars := instMVars) : TermElabM (Expr × Expr × Fields × Array MVarId) := do
pushInfoTree <| InfoTree.node (children := {}) <| Info.ofFieldInfo {
projName := s.structName.append fieldName, fieldName, lctx := ( getLCtx), val, stx := ref }
let e := mkApp e val
@@ -671,7 +787,7 @@ private partial def elabStruct (s : Struct) (expectedType? : Option Expr) : Term
match ( trySynthStructInstance? s d) with
| some val => cont val { field with val := FieldVal.term (mkHole field.ref) }
| none =>
let { val, struct := sNew, instMVars := instMVarsNew } elabStruct s (some d)
let { val, struct := sNew, instMVars := instMVarsNew } elabStructInstView s (some d)
let val ensureHasType d val
cont val { field with val := FieldVal.nested sNew } (instMVars ++ instMVarsNew)
| .default =>
@@ -700,17 +816,21 @@ private partial def elabStruct (s : Struct) (expectedType? : Option Expr) : Term
cont (markDefaultMissing val) field
| _ => withRef field.ref <| throwFailedToElabField fieldName s.structName m!"unexpected constructor type{indentExpr type}"
| _ => throwErrorAt field.ref "unexpected unexpanded structure field"
return { val := e, struct := s.setFields fields.reverse |>.setParams params, instMVars }
return { val := e, struct := { s with fields := fields.reverse, params }, instMVars }
namespace DefaultFields
/--
Context for default value propagation.
-/
structure Context where
-- We must search for default values overridden in derived structures
structs : Array Struct := #[]
/-- The current path through `.nested` subobject structures. We must search for default values overridden in derived structures. -/
structs : Array StructInstView := #[]
/-- The collection of structures that could provide a default value. -/
allStructNames : Array Name := #[]
/--
Consider the following example:
```
```lean
structure A where
x : Nat := 1
@@ -736,22 +856,29 @@ structure Context where
-/
maxDistance : Nat := 0
/--
State for default value propagation
-/
structure State where
/-- Whether progress has been made so far on this round of the propagation loop. -/
progress : Bool := false
partial def collectStructNames (struct : Struct) (names : Array Name) : Array Name :=
/-- Collects all structures that may provide default values for fields. -/
partial def collectStructNames (struct : StructInstView) (names : Array Name) : Array Name :=
let names := names.push struct.structName
struct.fields.foldl (init := names) fun names field =>
match field.val with
| .nested struct => collectStructNames struct names
| _ => names
partial def getHierarchyDepth (struct : Struct) : Nat :=
/-- Gets the maximum nesting depth of subobjects. -/
partial def getHierarchyDepth (struct : StructInstView) : Nat :=
struct.fields.foldl (init := 0) fun max field =>
match field.val with
| .nested struct => Nat.max max (getHierarchyDepth struct + 1)
| _ => max
/-- Returns whether the field is still missing. -/
def isDefaultMissing? [Monad m] [MonadMCtx m] (field : Field Struct) : m Bool := do
if let some expr := field.expr? then
if let some (.mvar mvarId) := defaultMissing? expr then
@@ -759,40 +886,51 @@ def isDefaultMissing? [Monad m] [MonadMCtx m] (field : Field Struct) : m Bool :=
return true
return false
partial def findDefaultMissing? [Monad m] [MonadMCtx m] (struct : Struct) : m (Option (Field Struct)) :=
/-- Returns a field that is still missing. -/
partial def findDefaultMissing? [Monad m] [MonadMCtx m] (struct : StructInstView) : m (Option (Field StructInstView)) :=
struct.fields.findSomeM? fun field => do
match field.val with
| .nested struct => findDefaultMissing? struct
| _ => return if ( isDefaultMissing? field) then field else none
partial def allDefaultMissing [Monad m] [MonadMCtx m] (struct : Struct) : m (Array (Field Struct)) :=
/-- Returns all fields that are still missing. -/
partial def allDefaultMissing [Monad m] [MonadMCtx m] (struct : StructInstView) : m (Array (Field StructInstView)) :=
go struct *> get |>.run' #[]
where
go (struct : Struct) : StateT (Array (Field Struct)) m Unit :=
go (struct : StructInstView) : StateT (Array (Field StructInstView)) m Unit :=
for field in struct.fields do
if let .nested struct := field.val then
go struct
else if ( isDefaultMissing? field) then
modify (·.push field)
def getFieldName (field : Field Struct) : Name :=
/-- Returns the name of the field. Assumes all fields under consideration are simple and named. -/
def getFieldName (field : Field StructInstView) : Name :=
match field.lhs with
| [.fieldName _ fieldName] => fieldName
| _ => unreachable!
abbrev M := ReaderT Context (StateRefT State TermElabM)
/-- Returns whether we should interrupt the round because we have made progress allowing nonzero depth. -/
def isRoundDone : M Bool := do
return ( get).progress && ( read).maxDistance > 0
def getFieldValue? (struct : Struct) (fieldName : Name) : Option Expr :=
/-- Returns the `expr?` for the given field. -/
def getFieldValue? (struct : StructInstView) (fieldName : Name) : Option Expr :=
struct.fields.findSome? fun field =>
if getFieldName field == fieldName then
field.expr?
else
none
partial def mkDefaultValueAux? (struct : Struct) : Expr TermElabM (Option Expr)
/-- Instantiates a default value from the given default value declaration, if applicable. -/
partial def mkDefaultValue? (struct : StructInstView) (cinfo : ConstantInfo) : TermElabM (Option Expr) :=
withRef struct.ref do
let us mkFreshLevelMVarsFor cinfo
process ( instantiateValueLevelParams cinfo us)
where
process : Expr TermElabM (Option Expr)
| .lam n d b c => withRef struct.ref do
if c.isExplicit then
let fieldName := n
@@ -801,29 +939,26 @@ partial def mkDefaultValueAux? (struct : Struct) : Expr → TermElabM (Option Ex
| some val =>
let valType inferType val
if ( isDefEq valType d) then
mkDefaultValueAux? struct (b.instantiate1 val)
process (b.instantiate1 val)
else
return none
else
if let some (_, param) := struct.params.find? fun (paramName, _) => paramName == n then
-- Recall that we did not use to have support for parameter propagation here.
if ( isDefEq ( inferType param) d) then
mkDefaultValueAux? struct (b.instantiate1 param)
process (b.instantiate1 param)
else
return none
else
let arg mkFreshExprMVar d
mkDefaultValueAux? struct (b.instantiate1 arg)
process (b.instantiate1 arg)
| e =>
let_expr id _ a := e | return some e
return some a
def mkDefaultValue? (struct : Struct) (cinfo : ConstantInfo) : TermElabM (Option Expr) :=
withRef struct.ref do
let us mkFreshLevelMVarsFor cinfo
mkDefaultValueAux? struct ( instantiateValueLevelParams cinfo us)
/-- Reduce default value. It performs beta reduction and projections of the given structures. -/
/--
Reduces a default value. It performs beta reduction and projections of the given structures to reduce them to the provided values for fields.
-/
partial def reduce (structNames : Array Name) (e : Expr) : MetaM Expr := do
match e with
| .forallE .. =>
@@ -880,7 +1015,10 @@ where
else
k
partial def tryToSynthesizeDefault (structs : Array Struct) (allStructNames : Array Name) (maxDistance : Nat) (fieldName : Name) (mvarId : MVarId) : TermElabM Bool :=
/--
Attempts to synthesize a default value for a missing field `fieldName` using default values from each structure in `structs`.
-/
def tryToSynthesizeDefault (structs : Array StructInstView) (allStructNames : Array Name) (maxDistance : Nat) (fieldName : Name) (mvarId : MVarId) : TermElabM Bool :=
let rec loop (i : Nat) (dist : Nat) := do
if dist > maxDistance then
return false
@@ -900,14 +1038,25 @@ partial def tryToSynthesizeDefault (structs : Array Struct) (allStructNames : Ar
| none =>
let mvarDecl getMVarDecl mvarId
let val ensureHasType mvarDecl.type val
mvarId.assign val
return true
/-
We must use `checkedAssign` here to ensure we do not create a cyclic
assignment. See #3150.
This can happen when there are holes in the the fields the default value
depends on.
Possible improvement: create a new `_` instead of returning `false` when
`checkedAssign` fails. Reason: the field will not be needed after the
other `_` are resolved by the user.
-/
mvarId.checkedAssign val
| _ => loop (i+1) dist
else
return false
loop 0 0
partial def step (struct : Struct) : M Unit :=
/--
Performs one step of default value synthesis.
-/
partial def step (struct : StructInstView) : M Unit :=
unless ( isRoundDone) do
withReader (fun ctx => { ctx with structs := ctx.structs.push struct }) do
for field in struct.fields do
@@ -924,7 +1073,10 @@ partial def step (struct : Struct) : M Unit :=
modify fun _ => { progress := true }
| _ => pure ()
partial def propagateLoop (hierarchyDepth : Nat) (d : Nat) (struct : Struct) : M Unit := do
/--
Main entry point to default value synthesis in the `M` monad.
-/
partial def propagateLoop (hierarchyDepth : Nat) (d : Nat) (struct : StructInstView) : M Unit := do
match ( findDefaultMissing? struct) with
| none => return () -- Done
| some field =>
@@ -947,16 +1099,22 @@ partial def propagateLoop (hierarchyDepth : Nat) (d : Nat) (struct : Struct) : M
else
propagateLoop hierarchyDepth (d+1) struct
def propagate (struct : Struct) : TermElabM Unit :=
/--
Synthesizes default values for all missing fields, if possible.
-/
def propagate (struct : StructInstView) : TermElabM Unit :=
let hierarchyDepth := getHierarchyDepth struct
let structNames := collectStructNames struct #[]
propagateLoop hierarchyDepth 0 struct { allStructNames := structNames } |>.run' {}
end DefaultFields
private def elabStructInstAux (stx : Syntax) (expectedType? : Option Expr) (source : Source) : TermElabM Expr := do
let structName getStructName expectedType? source
let struct liftMacroM <| mkStructView stx structName source
/--
Main entry point to elaborator for structure instance notation, unless the structure instance is a modifyOp.
-/
private def elabStructInstAux (stx : Syntax) (expectedType? : Option Expr) (sources : SourcesView) : TermElabM Expr := do
let structName getStructName expectedType? sources
let struct liftMacroM <| mkStructView stx structName sources
let struct expandStruct struct
trace[Elab.struct] "{struct}"
/- We try to synthesize pending problems with `withSynthesize` combinator before trying to use default values.
@@ -974,7 +1132,7 @@ private def elabStructInstAux (stx : Syntax) (expectedType? : Option Expr) (sour
TODO: investigate whether this design decision may have unintended side effects or produce confusing behavior.
-/
let { val := r, struct, instMVars } withSynthesize (postpone := .yes) <| elabStruct struct expectedType?
let { val := r, struct, instMVars } withSynthesize (postpone := .yes) <| elabStructInstView struct expectedType?
trace[Elab.struct] "before propagate {r}"
DefaultFields.propagate struct
synthesizeAppInstMVars instMVars r
@@ -984,13 +1142,13 @@ private def elabStructInstAux (stx : Syntax) (expectedType? : Option Expr) (sour
match ( expandNonAtomicExplicitSources stx) with
| some stxNew => withMacroExpansion stx stxNew <| elabTerm stxNew expectedType?
| none =>
let sourceView getStructSource stx
let sourcesView getStructSources stx
if let some modifyOp isModifyOp? stx then
if sourceView.explicit.isEmpty then
if sourcesView.explicit.isEmpty then
throwError "invalid \{...} notation, explicit source is required when using '[<index>] := <value>'"
elabModifyOp stx modifyOp sourceView.explicit expectedType?
elabModifyOp stx modifyOp sourcesView.explicit expectedType?
else
elabStructInstAux stx expectedType? sourceView
elabStructInstAux stx expectedType? sourcesView
builtin_initialize
registerTraceClass `Elab.struct

View File

@@ -233,11 +233,15 @@ where
return ( `((with_annotate_term $(stx[0]) @ParserDescr.sepBy1) $p $sep $psep $(quote allowTrailingSep)), 1)
isValidAtom (s : String) : Bool :=
-- Pretty-printing instructions shouldn't affect validity
let s := s.trim
!s.isEmpty &&
s.front != '\'' &&
(s.front != '\'' || "''".isPrefixOf s) &&
s.front != '\"' &&
!(isIdBeginEscape s.front) &&
!(s.front == '`' && (s.endPos == ⟨1⟩ || isIdFirst (s.get ⟨1⟩) || isIdBeginEscape (s.get ⟨1⟩))) &&
!s.front.isDigit
!s.front.isDigit &&
!(s.any Char.isWhitespace)
processAtom (stx : Syntax) := do
match stx[0].isStrLit? with

View File

@@ -198,11 +198,10 @@ def rewriteRulesPass (maxSteps : Nat) : Pass where
let sevalThms getSEvalTheorems
let sevalSimprocs Simp.getSEvalSimprocs
let simpCtx : Simp.Context := {
config := { failIfUnchanged := false, zetaDelta := true, maxSteps }
simpTheorems := #[bvThms, sevalThms]
congrTheorems := ( getSimpCongrTheorems)
}
let simpCtx Simp.mkContext
(config := { failIfUnchanged := false, zetaDelta := true, maxSteps })
(simpTheorems := #[bvThms, sevalThms])
(congrTheorems := ( getSimpCongrTheorems))
let hyps goal.getNondepPropHyps
let result?, _ simpGoal goal
@@ -217,35 +216,23 @@ Flatten out ands. That is look for hypotheses of the form `h : (x && y) = true`
with `h.left : x = true` and `h.right : y = true`. This can enable more fine grained substitutions
in embedded constraint substitution.
-/
def andFlatteningPass : Pass where
partial def andFlatteningPass : Pass where
name := `andFlattening
run goal := do
goal.withContext do
let hyps goal.getNondepPropHyps
let mut newHyps := #[]
let mut oldHyps := #[]
for hyp in hyps do
let typ hyp.getType
let_expr Eq α eqLhs eqRhs := typ | continue
let_expr Bool.and lhs rhs := eqLhs | continue
let_expr Bool := α | continue
let_expr Bool.true := eqRhs | continue
let mkEqTrue (lhs : Expr) : Expr :=
mkApp3 (mkConst ``Eq [1]) (mkConst ``Bool) lhs (mkConst ``Bool.true)
let hypExpr := ( hyp.getDecl).toExpr
let leftHyp : Hypothesis := {
userName := ( hyp.getUserName) ++ `left,
type := mkEqTrue lhs,
value := mkApp3 (mkConst ``Std.Tactic.BVDecide.Normalize.Bool.and_left) lhs rhs hypExpr
for fvar in hyps do
let hyp : Hypothesis := {
userName := ( fvar.getDecl).userName
type := fvar.getType
value := mkFVar fvar
}
let rightHyp : Hypothesis := {
userName := ( hyp.getUserName) ++ `right,
type := mkEqTrue rhs,
value := mkApp3 (mkConst ``Std.Tactic.BVDecide.Normalize.Bool.and_right) lhs rhs hypExpr
}
newHyps := newHyps.push leftHyp
newHyps := newHyps.push rightHyp
oldHyps := oldHyps.push hyp
let sizeBefore := newHyps.size
newHyps splitAnds hyp newHyps
if newHyps.size > sizeBefore then
oldHyps := oldHyps.push fvar
if newHyps.size == 0 then
return goal
else
@@ -253,6 +240,38 @@ def andFlatteningPass : Pass where
-- Given that we collected the hypotheses in the correct order above the invariant is given
let goal goal.tryClearMany oldHyps
return goal
where
splitAnds (hyp : Hypothesis) (hyps : Array Hypothesis) (first : Bool := true) :
MetaM (Array Hypothesis) := do
match trySplit hyp with
| some (left, right) =>
let hyps splitAnds left hyps false
splitAnds right hyps false
| none =>
if first then
return hyps
else
return hyps.push hyp
trySplit (hyp : Hypothesis) : MetaM (Option (Hypothesis × Hypothesis)) := do
let typ := hyp.type
let_expr Eq α eqLhs eqRhs := typ | return none
let_expr Bool.and lhs rhs := eqLhs | return none
let_expr Bool.true := eqRhs | return none
let_expr Bool := α | return none
let mkEqTrue (lhs : Expr) : Expr :=
mkApp3 (mkConst ``Eq [1]) (mkConst ``Bool) lhs (mkConst ``Bool.true)
let leftHyp : Hypothesis := {
userName := hyp.userName,
type := mkEqTrue lhs,
value := mkApp3 (mkConst ``Std.Tactic.BVDecide.Normalize.Bool.and_left) lhs rhs hyp.value
}
let rightHyp : Hypothesis := {
userName := hyp.userName,
type := mkEqTrue rhs,
value := mkApp3 (mkConst ``Std.Tactic.BVDecide.Normalize.Bool.and_right) lhs rhs hyp.value
}
return some (leftHyp, rightHyp)
/--
Substitute embedded constraints. That is look for hypotheses of the form `h : x = true` and use
@@ -283,11 +302,10 @@ def embeddedConstraintPass (maxSteps : Nat) : Pass where
let goal goal.tryClearMany duplicates
let simpCtx : Simp.Context := {
config := { failIfUnchanged := false, maxSteps }
simpTheorems := relevantHyps
congrTheorems := ( getSimpCongrTheorems)
}
let simpCtx Simp.mkContext
(config := { failIfUnchanged := false, maxSteps })
(simpTheorems := relevantHyps)
(congrTheorems := ( getSimpCongrTheorems))
let result?, _ simpGoal goal (ctx := simpCtx) (fvarIdsToSimp := goal.getNondepPropHyps)
let some (_, newGoal) := result? | return none
@@ -310,22 +328,18 @@ def acNormalizePass : Pass where
return newGoal
/--
The normalization passes used by `bv_normalize` and thus `bv_decide`.
-/
def defaultPipeline (cfg : BVDecideConfig ): List Pass :=
[
rewriteRulesPass cfg.maxSteps,
andFlatteningPass,
embeddedConstraintPass cfg.maxSteps
]
def passPipeline (cfg : BVDecideConfig) : List Pass := Id.run do
let mut passPipeline := defaultPipeline cfg
let mut passPipeline := [rewriteRulesPass cfg.maxSteps]
if cfg.acNf then
passPipeline := passPipeline ++ [acNormalizePass]
if cfg.andFlattening then
passPipeline := passPipeline ++ [andFlatteningPass]
if cfg.embeddedConstraintSubst then
passPipeline := passPipeline ++ [embeddedConstraintPass cfg.maxSteps]
return passPipeline
end Pass

View File

@@ -13,6 +13,31 @@ open Meta
# Implementation of the `change` tactic
-/
/--
Elaborates the pattern `p` and ensures that it is defeq to `e`.
Emulates `(show p from ?m : e)`, returning the type of `?m`, but `e` and `p` do not need to be types.
Unlike `(show p from ?m : e)`, this can assign synthetic opaque metavariables appearing in `p`.
-/
def elabChange (e : Expr) (p : Term) : TacticM Expr := do
let p runTermElab do
let p Term.elabTermEnsuringType p ( inferType e)
unless isDefEq p e do
/-
Sometimes isDefEq can fail due to postponed elaboration problems.
We synthesize pending synthetic mvars while allowing typeclass instances to be postponed,
which might enable solving for them with an additional `isDefEq`.
-/
Term.synthesizeSyntheticMVars (postpone := .partial)
discard <| isDefEq p e
pure p
withAssignableSyntheticOpaque do
unless isDefEq p e do
let (p, tgt) addPPExplicitToExposeDiff p e
throwError "\
'change' tactic failed, pattern{indentExpr p}\n\
is not definitionally equal to target{indentExpr tgt}"
instantiateMVars p
/-- `change` can be used to replace the main goal or its hypotheses with
different, yet definitionally equal, goal or hypotheses.
@@ -38,15 +63,13 @@ the main goal. -/
| `(tactic| change $newType:term $[$loc:location]?) => do
withLocation (expandOptLocation (Lean.mkOptionalNode loc))
(atLocal := fun h => do
let hTy h.getType
-- This is a hack to get the new type to elaborate in the same sort of way that
-- it would for a `show` expression for the goal.
let mvar mkFreshExprMVar none
let (_, mvars) elabTermWithHoles
( `(term | show $newType from $( Term.exprToSyntax mvar))) hTy `change
let (hTy', mvars) withCollectingNewGoalsFrom (elabChange ( h.getType) newType) ( getMainTag) `change
liftMetaTactic fun mvarId => do
return ( mvarId.changeLocalDecl h ( inferType mvar)) :: mvars)
(atTarget := evalTactic <| `(tactic| refine_lift show $newType from ?_))
(failed := fun _ => throwError "change tactic failed")
return ( mvarId.changeLocalDecl h hTy') :: mvars)
(atTarget := do
let (tgt', mvars) withCollectingNewGoalsFrom (elabChange ( getMainTarget) newType) ( getMainTag) `change
liftMetaTactic fun mvarId => do
return ( mvarId.replaceTargetDefEq tgt') :: mvars)
(failed := fun _ => throwError "'change' tactic failed")
end Lean.Elab.Tactic

View File

@@ -114,6 +114,13 @@ private def elabConfig (recover : Bool) (structName : Name) (items : Array Confi
let e Term.withSynthesize <| Term.elabTermEnsuringType stx (mkConst structName)
instantiateMVars e
section
-- We automatically disable the following option for `macro`s but the subsequent `def` both contains
-- a quotation and is called only by `macro`s, so we disable the option for it manually. Note that
-- we can't use `in` as it is parsed as a single command and so the option would not influence the
-- parser.
set_option internal.parseQuotWithCurrentStage false
private def mkConfigElaborator
(doc? : Option (TSyntax ``Parser.Command.docComment)) (elabName type monadName : Ident)
(adapt recover : Term) : MacroM (TSyntax `command) := do
@@ -148,6 +155,8 @@ private def mkConfigElaborator
throwError msg
go)
end
/-!
`declare_config_elab elabName TypeName` declares a function `elabName : Syntax → TacticM TypeName`
that elaborates a tactic configuration.

View File

@@ -5,6 +5,7 @@ Authors: Leonardo de Moura
-/
prelude
import Lean.Elab.Tactic.ElabTerm
import Lean.Elab.Tactic.Change
import Lean.Elab.Tactic.Conv.Basic
namespace Lean.Elab.Tactic.Conv
@@ -15,11 +16,9 @@ open Meta
| `(conv| change $e) => withMainContext do
let lhs getLhs
let mvarCounterSaved := ( getMCtx).mvarCounter
let r elabTermEnsuringType e ( inferType lhs)
logUnassignedAndAbort ( filterOldMVars ( getMVars r) mvarCounterSaved)
unless ( isDefEqGuarded r lhs) do
throwError "invalid 'change' conv tactic, term{indentExpr r}\nis not definitionally equal to current left-hand-side{indentExpr lhs}"
changeLhs r
let lhs' elabChange lhs e
logUnassignedAndAbort ( filterOldMVars ( getMVars lhs') mvarCounterSaved)
changeLhs lhs'
| _ => throwUnsupportedSyntax
end Lean.Elab.Tactic.Conv

View File

@@ -12,11 +12,10 @@ namespace Lean.Elab.Tactic.Conv
open Meta
private def getContext : MetaM Simp.Context := do
return {
simpTheorems := {}
congrTheorems := ( getSimpCongrTheorems)
config := Simp.neutralConfig
}
Simp.mkContext
(simpTheorems := {})
(congrTheorems := ( getSimpCongrTheorems))
(config := Simp.neutralConfig)
partial def matchPattern? (pattern : AbstractMVarsResult) (e : Expr) : MetaM (Option (Expr × Array Expr)) :=
withNewMCtxDepth do
@@ -126,7 +125,7 @@ private def pre (pattern : AbstractMVarsResult) (state : IO.Ref PatternMatchStat
pure (.occs #[] 0 ids.toList)
| _ => throwUnsupportedSyntax
let state IO.mkRef occs
let ctx := { getContext with config.memoize := occs matches .all _ }
let ctx := ( getContext).setMemoize (occs matches .all _)
let (result, _) Simp.main lhs ctx (methods := { pre := pre patternA state })
let subgoals match state.get with
| .all #[] | .occs _ 0 _ =>

View File

@@ -18,21 +18,22 @@ private def mkKey (e : Expr) (simp : Bool) : MetaM (Array Key) := do
let (_, _, type) withReducible <| forallMetaTelescopeReducing e
let type whnfR type
if simp then
if let some (_, lhs, _) := type.eq? then
mkPath lhs simpDtConfig
else if let some (lhs, _) := type.iff? then
mkPath lhs simpDtConfig
else if let some (_, lhs, _) := type.ne? then
mkPath lhs simpDtConfig
else if let some p := type.not? then
match p.eq? with
| some (_, lhs, _) =>
mkPath lhs simpDtConfig
| _ => mkPath p simpDtConfig
else
mkPath type simpDtConfig
withSimpGlobalConfig do
if let some (_, lhs, _) := type.eq? then
mkPath lhs
else if let some (lhs, _) := type.iff? then
mkPath lhs
else if let some (_, lhs, _) := type.ne? then
mkPath lhs
else if let some p := type.not? then
match p.eq? with
| some (_, lhs, _) =>
mkPath lhs
| _ => mkPath p
else
mkPath type
else
mkPath type {}
mkPath type
private def getType (t : TSyntax `term) : TermElabM Expr := do
if let `($id:ident) := t then

View File

@@ -542,11 +542,6 @@ declare_config_elab elabDecideConfig Parser.Tactic.DecideConfig
let cfg elabDecideConfig stx[1]
evalDecideCore `decide cfg
@[builtin_tactic Lean.Parser.Tactic.decideBang] def evalDecideBang : Tactic := fun stx => do
let cfg elabDecideConfig stx[1]
let cfg := { cfg with kernel := true }
evalDecideCore `decide! cfg
@[builtin_tactic Lean.Parser.Tactic.nativeDecide] def evalNativeDecide : Tactic := fun stx => do
let cfg elabDecideConfig stx[1]
let cfg := { cfg with native := true }

View File

@@ -195,9 +195,6 @@ structure ExtTheorems where
erased : PHashSet Name := {}
deriving Inhabited
/-- Discrimation tree settings for the `ext` extension. -/
def extExt.config : WhnfCoreConfig := {}
/-- The environment extension to track `@[ext]` theorems. -/
builtin_initialize extExtension :
SimpleScopedEnvExtension ExtTheorem ExtTheorems
@@ -211,7 +208,7 @@ builtin_initialize extExtension :
ordered from high priority to low. -/
@[inline] def getExtTheorems (ty : Expr) : MetaM (Array ExtTheorem) := do
let extTheorems := extExtension.getState ( getEnv)
let arr extTheorems.tree.getMatch ty extExt.config
let arr extTheorems.tree.getMatch ty
let erasedArr := arr.filter fun thm => !extTheorems.erased.contains thm.declName
-- Using insertion sort because it is stable and the list of matches should be mostly sorted.
-- Most ext theorems have default priority.
@@ -258,7 +255,7 @@ builtin_initialize registerBuiltinAttribute {
but this theorem proves{indentD declTy}"
let some (ty, lhs, rhs) := declTy.eq? | failNotEq
unless lhs.isMVar && rhs.isMVar do failNotEq
let keys withReducible <| DiscrTree.mkPath ty extExt.config
let keys withReducible <| DiscrTree.mkPath ty
let priority liftCommandElabM <| Elab.liftMacroM do evalPrio (prio.getD ( `(prio| default)))
extExtension.add {declName, keys, priority} kind
-- Realize iff theorem

View File

@@ -40,7 +40,7 @@ def exact? (ref : Syntax) (required : Option (Array (TSyntax `term))) (requireCl
| some suggestions =>
if requireClose then throwError
"`exact?` could not close the goal. Try `apply?` to see partial suggestions."
reportOutOfHeartbeats `library_search ref
reportOutOfHeartbeats `apply? ref
for (_, suggestionMCtx) in suggestions do
withMCtx suggestionMCtx do
addExactSuggestion ref ( instantiateMVars (mkMVar mvar)).headBeta (addSubgoalsMsg := true)

View File

@@ -28,8 +28,10 @@ def proveEqUsing (s : SimpTheorems) (a b : Expr) : MetaM (Option Simp.Result) :=
unless isDefEq a'.expr b'.expr do return none
a'.mkEqTrans ( b'.mkEqSymm b)
withReducible do
(go ( Simp.mkDefaultMethods).toMethodsRef
{ simpTheorems := #[s], congrTheorems := Meta.getSimpCongrTheorems }).run' {}
let ctx Simp.mkContext
(simpTheorems := #[s])
(congrTheorems := Meta.getSimpCongrTheorems)
(go ( Simp.mkDefaultMethods).toMethodsRef ctx).run' {}
/-- Proves `a = b` by simplifying using move and squash lemmas. -/
def proveEqUsingDown (a b : Expr) : MetaM (Option Simp.Result) := do
@@ -191,19 +193,25 @@ def derive (e : Expr) : MetaM Simp.Result := do
-- step 1: pre-processing of numerals
let r withTrace "pre-processing numerals" do
let post e := return Simp.Step.done ( try numeralToCoe e catch _ => pure {expr := e})
r.mkEqTrans ( Simp.main r.expr { config, congrTheorems } (methods := { post })).1
let ctx Simp.mkContext (config := config) (congrTheorems := congrTheorems)
r.mkEqTrans ( Simp.main r.expr ctx (methods := { post })).1
-- step 2: casts are moved upwards and eliminated
let r withTrace "moving upward, splitting and eliminating" do
let post := upwardAndElim ( normCastExt.up.getTheorems)
r.mkEqTrans ( Simp.main r.expr { config, congrTheorems } (methods := { post })).1
let ctx Simp.mkContext (config := config) (congrTheorems := congrTheorems)
r.mkEqTrans ( Simp.main r.expr ctx (methods := { post })).1
let simprocs ({} : Simp.SimprocsArray).add `reduceCtorEq false
-- step 3: casts are squashed
let r withTrace "squashing" do
let simpTheorems := #[ normCastExt.squash.getTheorems]
r.mkEqTrans ( simp r.expr { simpTheorems, config, congrTheorems } simprocs).1
let ctx Simp.mkContext
(config := config)
(simpTheorems := simpTheorems)
(congrTheorems := congrTheorems)
r.mkEqTrans ( simp r.expr ctx simprocs).1
return r
@@ -263,7 +271,7 @@ def evalConvNormCast : Tactic :=
def evalPushCast : Tactic := fun stx => do
let { ctx, simprocs, dischargeWrapper } withMainContext do
mkSimpContext (simpTheorems := pushCastExt.getTheorems) stx (eraseLocal := false)
let ctx := { ctx with config := { ctx.config with failIfUnchanged := false } }
let ctx := ctx.setFailIfUnchanged false
dischargeWrapper.with fun discharge? =>
discard <| simpLocation ctx simprocs discharge? (expandOptLocation stx[5])

View File

@@ -6,7 +6,6 @@ Authors: Kim Morrison
prelude
import Lean.Elab.Tactic.Omega.Core
import Lean.Elab.Tactic.FalseOrByContra
import Lean.Meta.Tactic.Cases
import Lean.Elab.Tactic.Config
/-!
@@ -520,23 +519,6 @@ partial def processFacts (p : MetaProblem) : OmegaM (MetaProblem × Nat) := do
end MetaProblem
/--
Given `p : P Q` (or any inductive type with two one-argument constructors),
split the goal into two subgoals:
one containing the hypothesis `h : P` and another containing `h : Q`.
-/
def cases₂ (mvarId : MVarId) (p : Expr) (hName : Name := `h) :
MetaM ((MVarId × FVarId) × (MVarId × FVarId)) := do
let mvarId mvarId.assert `hByCases ( inferType p) p
let (fvarId, mvarId) mvarId.intro1
let #[s₁, s₂] mvarId.cases fvarId #[{ varNames := [hName] }, { varNames := [hName] }] |
throwError "'cases' tactic failed, unexpected number of subgoals"
let #[Expr.fvar f₁ ..] pure s₁.fields
| throwError "'cases' tactic failed, unexpected new hypothesis"
let #[Expr.fvar f₂ ..] pure s₂.fields
| throwError "'cases' tactic failed, unexpected new hypothesis"
return ((s₁.mvarId, f₁), (s₂.mvarId, f₂))
/--
Helpful error message when omega cannot find a solution
-/
@@ -628,33 +610,36 @@ mutual
Split a disjunction in a `MetaProblem`, and if we find a new usable fact
call `omegaImpl` in both branches.
-/
partial def splitDisjunction (m : MetaProblem) (g : MVarId) : OmegaM Unit := g.withContext do
partial def splitDisjunction (m : MetaProblem) : OmegaM Expr := do
match m.disjunctions with
| [] => throwError "omega could not prove the goal:\n{← formatErrorMessage m.problem}"
| h :: t =>
trace[omega] "Case splitting on {← inferType h}"
let ctx getMCtx
let (g₁, h₁, g₂, h₂) cases₂ g h
trace[omega] "Adding facts:\n{← g₁.withContext <| inferType (.fvar h₁)}"
let m₁ := { m with facts := [.fvar h₁], disjunctions := t }
let r withoutModifyingState do
let (m₁, n) g₁.withContext m₁.processFacts
| h :: t => do
let hType whnfD ( inferType h)
trace[omega] "Case splitting on {hType}"
let_expr Or hType₁ hType₂ := hType | throwError "Unexpected disjunction {hType}"
let p?₁ withoutModifyingState do withLocalDeclD `h₁ hType₁ fun h₁ => do
withTraceNode `omega (msg := fun _ => do pure m!"Assuming fact:{indentExpr hType₁}") do
let m₁ := { m with facts := [h₁], disjunctions := t }
let (m₁, n) m₁.processFacts
if 0 < n then
omegaImpl m₁ g₁
pure true
let p₁ omegaImpl m₁
let p₁ mkLambdaFVars #[h₁] p₁
return some p₁
else
pure false
if r then
trace[omega] "Adding facts:\n{← g₂.withContext <| inferType (.fvar h₂)}"
let m₂ := { m with facts := [.fvar h₂], disjunctions := t }
omegaImpl m₂ g₂
return none
if let some p₁ := p?₁ then
withLocalDeclD `h₂ hType₂ fun h₂ => do
withTraceNode `omega (msg := fun _ => do pure m!"Assuming fact:{indentExpr hType₂}") do
let m₂ := { m with facts := [h₂], disjunctions := t }
let p₂ omegaImpl m₂
let p₂ mkLambdaFVars #[h₂] p₂
return mkApp6 (mkConst ``Or.elim) hType₁ hType₂ (mkConst ``False) h p₁ p₂
else
trace[omega] "No new facts found."
setMCtx ctx
splitDisjunction { m with disjunctions := t } g
splitDisjunction { m with disjunctions := t }
/-- Implementation of the `omega` algorithm, and handling disjunctions. -/
partial def omegaImpl (m : MetaProblem) (g : MVarId) : OmegaM Unit := g.withContext do
partial def omegaImpl (m : MetaProblem) : OmegaM Expr := do
let (m, _) m.processFacts
guard m.facts.isEmpty
let p := m.problem
@@ -663,12 +648,12 @@ partial def omegaImpl (m : MetaProblem) (g : MVarId) : OmegaM Unit := g.withCont
trace[omega] "After elimination:\nAtoms: {← atomsList}\n{p'}"
match p'.possible, p'.proveFalse?, p'.proveFalse?_spec with
| true, _, _ =>
splitDisjunction m g
splitDisjunction m
| false, .some prf, _ =>
trace[omega] "Justification:\n{p'.explanation?.get}"
let prf instantiateMVars ( prf)
trace[omega] "omega found a contradiction, proving {← inferType prf}"
g.assign prf
return prf
end
@@ -677,7 +662,9 @@ Given a collection of facts, try prove `False` using the omega algorithm,
and close the goal using that.
-/
def omega (facts : List Expr) (g : MVarId) (cfg : OmegaConfig := {}) : MetaM Unit :=
OmegaM.run (omegaImpl { facts } g) cfg
g.withContext do
let prf OmegaM.run (omegaImpl { facts }) cfg
g.assign prf
open Lean Elab Tactic Parser.Tactic

View File

@@ -91,7 +91,7 @@ def elabSimpConfig (optConfig : Syntax) (kind : SimpKind) : TacticM Meta.Simp.Co
| .simpAll => return ( elabSimpConfigCtxCore optConfig).toConfig
| .dsimp => return { ( elabDSimpConfigCore optConfig) with }
private def addDeclToUnfoldOrTheorem (thms : SimpTheorems) (id : Origin) (e : Expr) (post : Bool) (inv : Bool) (kind : SimpKind) : MetaM SimpTheorems := do
private def addDeclToUnfoldOrTheorem (config : Meta.ConfigWithKey) (thms : SimpTheorems) (id : Origin) (e : Expr) (post : Bool) (inv : Bool) (kind : SimpKind) : MetaM SimpTheorems := do
if e.isConst then
let declName := e.constName!
let info getConstInfo declName
@@ -108,7 +108,7 @@ private def addDeclToUnfoldOrTheorem (thms : SimpTheorems) (id : Origin) (e : Ex
let fvarId := e.fvarId!
let decl fvarId.getDecl
if ( isProp decl.type) then
thms.add id #[] e (post := post) (inv := inv)
thms.add id #[] e (post := post) (inv := inv) (config := config)
else if !decl.isLet then
throwError "invalid argument, variable is not a proposition or let-declaration"
else if inv then
@@ -116,9 +116,9 @@ private def addDeclToUnfoldOrTheorem (thms : SimpTheorems) (id : Origin) (e : Ex
else
return thms.addLetDeclToUnfold fvarId
else
thms.add id #[] e (post := post) (inv := inv)
thms.add id #[] e (post := post) (inv := inv) (config := config)
private def addSimpTheorem (thms : SimpTheorems) (id : Origin) (stx : Syntax) (post : Bool) (inv : Bool) : TermElabM SimpTheorems := do
private def addSimpTheorem (config : Meta.ConfigWithKey) (thms : SimpTheorems) (id : Origin) (stx : Syntax) (post : Bool) (inv : Bool) : TermElabM SimpTheorems := do
let thm? Term.withoutModifyingElabMetaStateWithInfo <| withRef stx do
let e Term.elabTerm stx none
Term.synthesizeSyntheticMVars (postpone := .no) (ignoreStuckTC := true)
@@ -132,7 +132,7 @@ private def addSimpTheorem (thms : SimpTheorems) (id : Origin) (stx : Syntax) (p
else
return some (#[], e)
if let some (levelParams, proof) := thm? then
thms.add id levelParams proof (post := post) (inv := inv)
thms.add id levelParams proof (post := post) (inv := inv) (config := config)
else
return thms
@@ -212,7 +212,7 @@ def elabSimpArgs (stx : Syntax) (ctx : Simp.Context) (simprocs : Simp.SimprocsAr
match ( resolveSimpIdTheorem? term) with
| .expr e =>
let name mkFreshId
thms addDeclToUnfoldOrTheorem thms (.stx name arg) e post inv kind
thms addDeclToUnfoldOrTheorem ctx.indexConfig thms (.stx name arg) e post inv kind
| .simproc declName =>
simprocs simprocs.add declName post
| .ext (some ext₁) (some ext₂) _ =>
@@ -224,7 +224,7 @@ def elabSimpArgs (stx : Syntax) (ctx : Simp.Context) (simprocs : Simp.SimprocsAr
simprocs := simprocs.push ( ext₂.getSimprocs)
| .none =>
let name mkFreshId
thms addSimpTheorem thms (.stx name arg) term post inv
thms addSimpTheorem ctx.indexConfig thms (.stx name arg) term post inv
else if arg.getKind == ``Lean.Parser.Tactic.simpStar then
starArg := true
else
@@ -234,7 +234,7 @@ def elabSimpArgs (stx : Syntax) (ctx : Simp.Context) (simprocs : Simp.SimprocsAr
logException ex
else
throw ex
return { ctx := { ctx with simpTheorems := thmsArray.set! 0 thms }, simprocs, starArg }
return { ctx := ctx.setSimpTheorems (thmsArray.set! 0 thms), simprocs, starArg }
-- If recovery is disabled, then we want simp argument elaboration failures to be exceptions.
-- This affects `addSimpTheorem`.
if ( read).recover then
@@ -311,10 +311,11 @@ def mkSimpContext (stx : Syntax) (eraseLocal : Bool) (kind := SimpKind.simp)
simpTheorems
let simprocs if simpOnly then pure {} else Simp.getSimprocs
let congrTheorems getSimpCongrTheorems
let r elabSimpArgs stx[4] (eraseLocal := eraseLocal) (kind := kind) (simprocs := #[simprocs]) {
config := ( elabSimpConfig stx[1] (kind := kind))
simpTheorems := #[simpTheorems], congrTheorems
}
let ctx Simp.mkContext
(config := ( elabSimpConfig stx[1] (kind := kind)))
(simpTheorems := #[simpTheorems])
congrTheorems
let r elabSimpArgs stx[4] (eraseLocal := eraseLocal) (kind := kind) (simprocs := #[simprocs]) ctx
if !r.starArg || ignoreStarArg then
return { r with dischargeWrapper }
else
@@ -328,8 +329,8 @@ def mkSimpContext (stx : Syntax) (eraseLocal : Bool) (kind := SimpKind.simp)
let hs getPropHyps
for h in hs do
unless simpTheorems.isErased (.fvar h) do
simpTheorems simpTheorems.addTheorem (.fvar h) ( h.getDecl).toExpr
let ctx := { ctx with simpTheorems }
simpTheorems simpTheorems.addTheorem (.fvar h) ( h.getDecl).toExpr (config := ctx.indexConfig)
let ctx := ctx.setSimpTheorems simpTheorems
return { ctx, simprocs, dischargeWrapper }
register_builtin_option tactic.simp.trace : Bool := {

View File

@@ -36,9 +36,9 @@ deriving instance Repr for UseImplicitLambdaResult
let stx `(tactic| simp $cfg:optConfig $(disch)? $[only%$only]? $[[$args,*]]?)
let { ctx, simprocs, dischargeWrapper }
withMainContext <| mkSimpContext stx (eraseLocal := false)
let ctx := if unfold.isSome then { ctx with config.autoUnfold := true } else ctx
let ctx := if unfold.isSome then ctx.setAutoUnfold else ctx
-- TODO: have `simpa` fail if it doesn't use `simp`.
let ctx := { ctx with config := { ctx.config with failIfUnchanged := false } }
let ctx := ctx.setFailIfUnchanged false
dischargeWrapper.with fun discharge? => do
let (some (_, g), stats) simpGoal ( getMainGoal) ctx (simprocs := simprocs)
(simplifyTarget := true) (discharge? := discharge?)

View File

@@ -25,7 +25,7 @@ def elabSimprocPattern (stx : Syntax) : MetaM Expr := do
def elabSimprocKeys (stx : Syntax) : MetaM (Array Meta.SimpTheoremKey) := do
let pattern elabSimprocPattern stx
DiscrTree.mkPath pattern simpDtConfig
withSimpGlobalConfig <| DiscrTree.mkPath pattern
def checkSimprocType (declName : Name) : CoreM Bool := do
let decl getConstInfo declName

View File

@@ -1298,13 +1298,20 @@ def isTacticOrPostponedHole? (e : Expr) : TermElabM (Option MVarId) := do
| _ => return none
| _ => pure none
def mkTermInfo (elaborator : Name) (stx : Syntax) (e : Expr) (expectedType? : Option Expr := none) (lctx? : Option LocalContext := none) (isBinder := false) : TermElabM (Sum Info MVarId) := do
def mkTermInfo (elaborator : Name) (stx : Syntax) (e : Expr) (expectedType? : Option Expr := none)
(lctx? : Option LocalContext := none) (isBinder := false) :
TermElabM (Sum Info MVarId) := do
match ( isTacticOrPostponedHole? e) with
| some mvarId => return Sum.inr mvarId
| none =>
let e := removeSaveInfoAnnotation e
return Sum.inl <| Info.ofTermInfo { elaborator, lctx := lctx?.getD ( getLCtx), expr := e, stx, expectedType?, isBinder }
def mkPartialTermInfo (elaborator : Name) (stx : Syntax) (expectedType? : Option Expr := none)
(lctx? : Option LocalContext := none) :
TermElabM Info := do
return Info.ofPartialTermInfo { elaborator, lctx := lctx?.getD ( getLCtx), stx, expectedType? }
/--
Pushes a new leaf node to the info tree associating the expression `e` to the syntax `stx`.
As a result, when the user hovers over `stx` they will see the type of `e`, and if `e`
@@ -1326,41 +1333,54 @@ def addTermInfo (stx : Syntax) (e : Expr) (expectedType? : Option Expr := none)
if ( read).inPattern && !force then
return mkPatternWithRef e stx
else
withInfoContext' (pure ()) (fun _ => mkTermInfo elaborator stx e expectedType? lctx? isBinder) |> discard
discard <| withInfoContext'
(pure ())
(fun _ => mkTermInfo elaborator stx e expectedType? lctx? isBinder)
(mkPartialTermInfo elaborator stx expectedType? lctx?)
return e
def addTermInfo' (stx : Syntax) (e : Expr) (expectedType? : Option Expr := none) (lctx? : Option LocalContext := none) (elaborator := Name.anonymous) (isBinder := false) : TermElabM Unit :=
discard <| addTermInfo stx e expectedType? lctx? elaborator isBinder
def withInfoContext' (stx : Syntax) (x : TermElabM Expr) (mkInfo : Expr TermElabM (Sum Info MVarId)) : TermElabM Expr := do
def withInfoContext' (stx : Syntax) (x : TermElabM Expr)
(mkInfo : Expr TermElabM (Sum Info MVarId)) (mkInfoOnError : TermElabM Info) :
TermElabM Expr := do
if ( read).inPattern then
let e x
return mkPatternWithRef e stx
else
Elab.withInfoContext' x mkInfo
Elab.withInfoContext' x mkInfo mkInfoOnError
/-- Info node capturing `def/let rec` bodies, used by the unused variables linter. -/
structure BodyInfo where
/-- The body as a fully elaborated term. -/
value : Expr
/-- The body as a fully elaborated term. `none` if the body failed to elaborate. -/
value? : Option Expr
deriving TypeName
/-- Creates an `Info.ofCustomInfo` node backed by a `BodyInfo`. -/
def mkBodyInfo (stx : Syntax) (value : Expr) : Info :=
.ofCustomInfo { stx, value := .mk { value : BodyInfo } }
def mkBodyInfo (stx : Syntax) (value? : Option Expr) : Info :=
.ofCustomInfo { stx, value := .mk { value? : BodyInfo } }
/-- Extracts a `BodyInfo` custom info. -/
def getBodyInfo? : Info Option BodyInfo
| .ofCustomInfo { value, .. } => value.get? BodyInfo
| _ => none
def withTermInfoContext' (elaborator : Name) (stx : Syntax) (x : TermElabM Expr)
(expectedType? : Option Expr := none) (lctx? : Option LocalContext := none)
(isBinder : Bool := false) :
TermElabM Expr :=
withInfoContext' stx x
(mkTermInfo elaborator stx (expectedType? := expectedType?) (lctx? := lctx?) (isBinder := isBinder))
(mkPartialTermInfo elaborator stx (expectedType? := expectedType?) (lctx? := lctx?))
/--
Postpone the elaboration of `stx`, return a metavariable that acts as a placeholder, and
ensures the info tree is updated and a hole id is introduced.
When `stx` is elaborated, new info nodes are created and attached to the new hole id in the info tree.
-/
def postponeElabTerm (stx : Syntax) (expectedType? : Option Expr) : TermElabM Expr := do
withInfoContext' stx (mkInfo := mkTermInfo .anonymous (expectedType? := expectedType?) stx) do
withTermInfoContext' .anonymous stx (expectedType? := expectedType?) do
postponeElabTermCore stx expectedType?
/--
@@ -1372,7 +1392,7 @@ private def elabUsingElabFnsAux (s : SavedState) (stx : Syntax) (expectedType? :
| (elabFn::elabFns) =>
try
-- record elaborator in info tree, but only when not backtracking to other elaborators (outer `try`)
withInfoContext' stx (mkInfo := mkTermInfo elabFn.declName (expectedType? := expectedType?) stx)
withTermInfoContext' elabFn.declName stx (expectedType? := expectedType?)
(try
elabFn.value stx expectedType?
catch ex => match ex with
@@ -1755,7 +1775,7 @@ private partial def elabTermAux (expectedType? : Option Expr) (catchExPostpone :
let result match ( liftMacroM (expandMacroImpl? env stx)) with
| some (decl, stxNew?) =>
let stxNew liftMacroM <| liftExcept stxNew?
withInfoContext' stx (mkInfo := mkTermInfo decl (expectedType? := expectedType?) stx) <|
withTermInfoContext' decl stx (expectedType? := expectedType?) <|
withMacroExpansion stx stxNew <|
withRef stxNew <|
elabTermAux expectedType? catchExPostpone implicitLambda stxNew

View File

@@ -599,17 +599,20 @@ def geq (u v : Level) : Bool :=
where
go (u v : Level) : Bool :=
u == v ||
let k := fun () =>
match v with
| imax v₁ v₂ => go u v₁ && go u v₂
| _ =>
let v' := v.getLevelOffset
(u.getLevelOffset == v' || v'.isZero)
&& u.getOffset v.getOffset
match u, v with
| _, zero => true
| u, max v₁ v₂ => go u v₁ && go u v₂
| max u₁ u₂, v => go u₁ v || go u₂ v
| u, imax v₁ v₂ => go u v && go u v
| imax _ u₂, v => go u v
| succ u, succ v => go u v
| _, _ =>
let v' := v.getLevelOffset
(u.getLevelOffset == v' || v'.isZero)
&& u.getOffset v.getOffset
| _, zero => true
| u, max v₁ v₂ => go u v₁ && go u v₂
| max u₁ u₂, v => go u₁ v || go u₂ v || k ()
| imax _ u₂, v => go u v
| succ u, succ v => go u v
| _, _ => k ()
termination_by (u, v)
end Level

View File

@@ -393,16 +393,17 @@ where
| .ofCustomInfo ti =>
if !linter.unusedVariables.analyzeTactics.get ci.options then
if let some bodyInfo := ti.value.get? Elab.Term.BodyInfo then
-- the body is the only `Expr` we will analyze in this case
-- NOTE: we include it even if no tactics are present as at least for parameters we want
-- to lint only truly unused binders
let (e, _) := instantiateMVarsCore ci.mctx bodyInfo.value
modify fun s => { s with
assignments := s.assignments.push (.insert {} .anonymous e) }
let tacticsPresent := children.any (·.findInfo? (· matches .ofTacticInfo ..) |>.isSome)
withReader (· || tacticsPresent) do
go children.toArray ci
return false
if let some value := bodyInfo.value? then
-- the body is the only `Expr` we will analyze in this case
-- NOTE: we include it even if no tactics are present as at least for parameters we want
-- to lint only truly unused binders
let (e, _) := instantiateMVarsCore ci.mctx value
modify fun s => { s with
assignments := s.assignments.push (.insert {} .anonymous e) }
let tacticsPresent := children.any (·.findInfo? (· matches .ofTacticInfo ..) |>.isSome)
withReader (· || tacticsPresent) do
go children.toArray ci
return false
| .ofTermInfo ti =>
if ignored then return true
match ti.expr with

View File

@@ -116,7 +116,7 @@ variable (p : Name → Bool) in
/-- Returns true when the message contains a `MessageData.tagged tag ..` constructor where `p tag`
is true.
This does not descend into lazily generated subtress (`.ofLazy`); message tags
This does not descend into lazily generated subtrees (`.ofLazy`); message tags
of interest (like those added by `logLinter`) are expected to be near the root
of the `MessageData`, and not hidden inside `.ofLazy`.
-/
@@ -130,6 +130,19 @@ partial def hasTag : MessageData → Bool
| trace data msg msgs => p data.cls || hasTag msg || msgs.any hasTag
| _ => false
/--
Returns the top-level tag of the message.
If none, returns `Name.anonymous`.
This does not descend into message subtrees (e.g., `.compose`, `.ofLazy`).
The message kind is expected to describe the whole message.
-/
def kind : MessageData Name
| withContext _ msg => kind msg
| withNamingContext _ msg => kind msg
| tagged n _ => n
| _ => .anonymous
/-- An empty message. -/
def nil : MessageData :=
ofFormat Format.nil
@@ -315,7 +328,7 @@ structure BaseMessage (α : Type u) where
endPos : Option Position := none
/-- If `true`, report range as given; see `msgToInteractiveDiagnostic`. -/
keepFullRange : Bool := false
severity : MessageSeverity := MessageSeverity.error
severity : MessageSeverity := .error
caption : String := ""
/-- The content of the message. -/
data : α
@@ -328,7 +341,10 @@ abbrev Message := BaseMessage MessageData
/-- A `SerialMessage` is a `Message` whose `MessageData` has been eagerly
serialized and is thus appropriate for use in pure contexts where the effectful
`MessageData.toString` cannot be used. -/
abbrev SerialMessage := BaseMessage String
structure SerialMessage extends BaseMessage String where
/-- The message kind (i.e., the top-level tag). -/
kind : Name
deriving ToJson, FromJson
namespace SerialMessage
@@ -354,8 +370,12 @@ end SerialMessage
namespace Message
@[inherit_doc MessageData.kind] abbrev kind (msg : Message) :=
msg.data.kind
/-- Serializes the message, converting its data into a string and saving its kind. -/
@[inline] def serialize (msg : Message) : IO SerialMessage := do
return {msg with data := msg.data.toString}
return {msg with kind := msg.kind, data := msg.data.toString}
protected def toString (msg : Message) (includeEndPos := false) : IO String := do
-- Remark: The inline here avoids a new message allocation when `msg` is shared

View File

@@ -32,6 +32,9 @@ inductive ReduceMode where
| reduceSimpleOnly
| none
private def config : ConfigWithKey :=
{ transparency := .reducible, iota := false, proj := .no : Config }.toConfigWithKey
mutual
/--
@@ -61,8 +64,8 @@ where
-- Drawback: cost.
return e
else match mode with
| .reduce => DiscrTree.reduce e {}
| .reduceSimpleOnly => DiscrTree.reduce e { iota := false, proj := .no }
| .reduce => DiscrTree.reduce e
| .reduceSimpleOnly => withConfigWithKey config <| DiscrTree.reduce e
| .none => return e
lt (a b : Expr) : MetaM Bool := do

View File

@@ -196,13 +196,13 @@ where
let packedArg := Unary.pack packedDomain args
return e.beta #[packedArg]
| [n] => do
withLocalDecl n .default domain fun x => do
withLocalDeclD n domain fun x => do
let dummy := Expr.const ``Unit []
mkLambdaFVars #[x] ( go packedDomain dummy (args.push x) [])
| n :: ns =>
match_expr domain with
| PSigma a b =>
withLocalDecl n .default a fun x => do
withLocalDeclD n a fun x => do
mkLambdaFVars #[x] ( go packedDomain (b.beta #[x]) (args.push x) ns)
| _ => throwError "curryPSigma: Expected PSigma type, got {domain}"
@@ -319,7 +319,7 @@ def uncurryType (types : Array Expr) : MetaM Expr := do
unless type.isForall do
throwError "Mutual.uncurryType: Expected forall type, got {type}"
let domain packType (types.map (·.bindingDomain!))
withLocalDeclD `x domain fun x => do
withLocalDeclD ( mkFreshUserName `x) domain fun x => do
let codomain Mutual.mkCodomain types x
mkForallFVars #[x] codomain
@@ -485,13 +485,14 @@ projects to the `i`th function of type,
-/
def curryProj (argsPacker : ArgsPacker) (e : Expr) (i : Nat) : MetaM Expr := do
let n := argsPacker.numFuncs
let packedDomain := ( inferType e).bindingDomain!
let t inferType e
let packedDomain := t.bindingDomain!
let unaryTypes Mutual.unpackType n packedDomain
unless i < unaryTypes.length do
throwError "curryProj: index out of range"
let unaryType := unaryTypes[i]!
-- unary : (x : a ⊗ b) → e[inl x]
let unary withLocalDecl `x .default unaryType fun x => do
let unary withLocalDeclD t.bindingName! unaryType fun x => do
let packedArg Mutual.pack unaryTypes.length packedDomain i x
mkLambdaFVars #[x] (e.beta #[packedArg])
-- nary : (x : a) → (y : b) → e[inl (x,y)]

View File

@@ -27,6 +27,51 @@ namespace Lean.Meta
builtin_initialize isDefEqStuckExceptionId : InternalExceptionId registerInternalExceptionId `isDefEqStuck
def TransparencyMode.toUInt64 : TransparencyMode UInt64
| .all => 0
| .default => 1
| .reducible => 2
| .instances => 3
def EtaStructMode.toUInt64 : EtaStructMode UInt64
| .all => 0
| .notClasses => 1
| .none => 2
/--
Configuration for projection reduction. See `whnfCore`.
-/
inductive ProjReductionKind where
/-- Projections `s.i` are not reduced at `whnfCore`. -/
| no
/--
Projections `s.i` are reduced at `whnfCore`, and `whnfCore` is used at `s` during the process.
Recall that `whnfCore` does not perform `delta` reduction (i.e., it will not unfold constant declarations).
-/
| yes
/--
Projections `s.i` are reduced at `whnfCore`, and `whnf` is used at `s` during the process.
Recall that `whnfCore` does not perform `delta` reduction (i.e., it will not unfold constant declarations), but `whnf` does.
-/
| yesWithDelta
/--
Projections `s.i` are reduced at `whnfCore`, and `whnfAtMostI` is used at `s` during the process.
Recall that `whnfAtMostI` is like `whnf` but uses transparency at most `instances`.
This option is stronger than `yes`, but weaker than `yesWithDelta`.
We use this option to ensure we reduce projections to prevent expensive defeq checks when unifying TC operations.
When unifying e.g. `(@Field.toNeg α inst1).1 =?= (@Field.toNeg α inst2).1`,
we only want to unify negation (and not all other field operations as well).
Unifying the field instances slowed down unification: https://github.com/leanprover/lean4/issues/1986
-/
| yesWithDeltaI
deriving DecidableEq, Inhabited, Repr
def ProjReductionKind.toUInt64 : ProjReductionKind UInt64
| .no => 0
| .yes => 1
| .yesWithDelta => 2
| .yesWithDeltaI => 3
/--
Configuration flags for the `MetaM` monad.
Many of them are used to control the `isDefEq` function that checks whether two terms are definitionally equal or not.
@@ -118,9 +163,64 @@ structure Config where
- `max u w =?= mav u ?v` is solved with `?v := w` ignoring the solution `?v := max u w`
-/
univApprox : Bool := true
/-- If `true`, reduce recursor/matcher applications, e.g., `Nat.rec true (fun _ _ => false) Nat.zero` reduces to `true` -/
iota : Bool := true
/-- If `true`, reduce terms such as `(fun x => t[x]) a` into `t[a]` -/
beta : Bool := true
/-- Control projection reduction at `whnfCore`. -/
proj : ProjReductionKind := .yesWithDelta
/--
Zeta reduction: `let x := v; e[x]` reduces to `e[v]`.
We say a let-declaration `let x := v; e` is non dependent if it is equivalent to `(fun x => e) v`.
Recall that
```
fun x : BitVec 5 => let n := 5; fun y : BitVec n => x = y
```
is type correct, but
```
fun x : BitVec 5 => (fun n => fun y : BitVec n => x = y) 5
```
is not.
-/
zeta : Bool := true
/--
Zeta-delta reduction: given a local context containing entry `x : t := e`, free variable `x` reduces to `e`.
-/
zetaDelta : Bool := true
deriving Inhabited
/-- Convert `isDefEq` and `WHNF` relevant parts into a key for caching results -/
private def Config.toKey (c : Config) : UInt64 :=
c.transparency.toUInt64 |||
(c.foApprox.toUInt64 <<< 2) |||
(c.ctxApprox.toUInt64 <<< 3) |||
(c.quasiPatternApprox.toUInt64 <<< 4) |||
(c.constApprox.toUInt64 <<< 5) |||
(c.isDefEqStuckEx.toUInt64 <<< 6) |||
(c.unificationHints.toUInt64 <<< 7) |||
(c.proofIrrelevance.toUInt64 <<< 8) |||
(c.assignSyntheticOpaque.toUInt64 <<< 9) |||
(c.offsetCnstrs.toUInt64 <<< 10) |||
(c.iota.toUInt64 <<< 11) |||
(c.beta.toUInt64 <<< 12) |||
(c.zeta.toUInt64 <<< 13) |||
(c.zetaDelta.toUInt64 <<< 14) |||
(c.univApprox.toUInt64 <<< 15) |||
(c.etaStruct.toUInt64 <<< 16) |||
(c.proj.toUInt64 <<< 18)
/-- Configuration with key produced by `Config.toKey`. -/
structure ConfigWithKey where
private mk ::
config : Config
key : UInt64
deriving Inhabited
def Config.toConfigWithKey (c : Config) : ConfigWithKey :=
{ config := c, key := c.toKey }
/--
Function parameter information cache.
Function parameter information cache.
-/
structure ParamInfo where
/-- The binder annotation for the parameter. -/
@@ -178,7 +278,6 @@ def ParamInfo.isStrictImplicit (p : ParamInfo) : Bool :=
def ParamInfo.isExplicit (p : ParamInfo) : Bool :=
p.binderInfo == BinderInfo.default
/--
Function information cache. See `ParamInfo`.
-/
@@ -192,11 +291,12 @@ structure FunInfo where
resultDeps : Array Nat := #[]
/--
Key for the function information cache.
Key for the function information cache.
-/
structure InfoCacheKey where
/-- The transparency mode used to compute the `FunInfo`. -/
transparency : TransparencyMode
private mk ::
/-- key produced using `Config.toKey`. -/
configKey : UInt64
/-- The function being cached information about. It is quite often an `Expr.const`. -/
expr : Expr
/--
@@ -207,11 +307,10 @@ structure InfoCacheKey where
nargs? : Option Nat
deriving Inhabited, BEq
namespace InfoCacheKey
instance : Hashable InfoCacheKey :=
fun transparency, expr, nargs => mixHash (hash transparency) <| mixHash (hash expr) (hash nargs)
end InfoCacheKey
instance : Hashable InfoCacheKey where
hash := fun { configKey, expr, nargs? } => mixHash (hash configKey) <| mixHash (hash expr) (hash nargs?)
-- Remark: we don't need to store `Config.toKey` because typeclass resolution uses a fixed configuration.
structure SynthInstanceCacheKey where
localInsts : LocalInstances
type : Expr
@@ -231,38 +330,50 @@ structure AbstractMVarsResult where
abbrev SynthInstanceCache := PersistentHashMap SynthInstanceCacheKey (Option AbstractMVarsResult)
abbrev InferTypeCache := PersistentExprStructMap Expr
-- Key for `InferType` and `WHNF` caches
structure ExprConfigCacheKey where
private mk ::
expr : Expr
configKey : UInt64
deriving Inhabited
instance : BEq ExprConfigCacheKey where
beq a b :=
Expr.equal a.expr b.expr &&
a.configKey == b.configKey
instance : Hashable ExprConfigCacheKey where
hash := fun { expr, configKey } => mixHash (hash expr) (hash configKey)
abbrev InferTypeCache := PersistentHashMap ExprConfigCacheKey Expr
abbrev FunInfoCache := PersistentHashMap InfoCacheKey FunInfo
abbrev WhnfCache := PersistentExprStructMap Expr
abbrev WhnfCache := PersistentHashMap ExprConfigCacheKey Expr
structure DefEqCacheKey where
private mk ::
lhs : Expr
rhs : Expr
configKey : UInt64
deriving Inhabited, BEq
instance : Hashable DefEqCacheKey where
hash := fun { lhs, rhs, configKey } => mixHash (hash lhs) <| mixHash (hash rhs) (hash configKey)
/--
A mapping `(s, t) ↦ isDefEq s t` per transparency level.
TODO: consider more efficient representations (e.g., a proper set) and caching policies (e.g., imperfect cache).
We should also investigate the impact on memory consumption. -/
structure DefEqCache where
reducible : PersistentHashMap (Expr × Expr) Bool := {}
instances : PersistentHashMap (Expr × Expr) Bool := {}
default : PersistentHashMap (Expr × Expr) Bool := {}
all : PersistentHashMap (Expr × Expr) Bool := {}
deriving Inhabited
/--
A cache for `inferType` at transparency levels `.default` an `.all`.
A mapping `(s, t) ↦ isDefEq s t`.
TODO: consider more efficient representations (e.g., a proper set) and caching policies (e.g., imperfect cache).
We should also investigate the impact on memory consumption.
-/
structure InferTypeCaches where
default : InferTypeCache
all : InferTypeCache
deriving Inhabited
abbrev DefEqCache := PersistentHashMap DefEqCacheKey Bool
/--
Cache datastructures for type inference, type class resolution, whnf, and definitional equality.
Cache datastructures for type inference, type class resolution, whnf, and definitional equality.
-/
structure Cache where
inferType : InferTypeCaches := {}, {}
inferType : InferTypeCache := {}
funInfo : FunInfoCache := {}
synthInstance : SynthInstanceCache := {}
whnfDefault : WhnfCache := {} -- cache for closed terms and `TransparencyMode.default`
whnfAll : WhnfCache := {} -- cache for closed terms and `TransparencyMode.all`
whnf : WhnfCache := {}
defEqTrans : DefEqCache := {} -- transient cache for terms containing mvars or using nonstandard configuration options, it is frequently reset.
defEqPerm : DefEqCache := {} -- permanent cache for terms not containing mvars and using standard configuration options
deriving Inhabited
@@ -332,7 +443,8 @@ register_builtin_option maxSynthPendingDepth : Nat := {
Contextual information for the `MetaM` monad.
-/
structure Context where
config : Config := {}
private config : Config := {}
private configKey : UInt64 := config.toKey
/-- Local context -/
lctx : LocalContext := {}
/-- Local instances in `lctx`. -/
@@ -483,17 +595,27 @@ variable [MonadControlT MetaM n] [Monad n]
@[inline] def modifyCache (f : Cache Cache) : MetaM Unit :=
modify fun { mctx, cache, zetaDeltaFVarIds, postponed, diag } => { mctx, cache := f cache, zetaDeltaFVarIds, postponed, diag }
@[inline] def modifyInferTypeCacheDefault (f : InferTypeCache InferTypeCache) : MetaM Unit :=
modifyCache fun icd, ica, c1, c2, c3, c4, c5, c6 => f icd, ica, c1, c2, c3, c4, c5, c6
@[inline] def modifyInferTypeCacheAll (f : InferTypeCache InferTypeCache) : MetaM Unit :=
modifyCache fun icd, ica, c1, c2, c3, c4, c5, c6 => icd, f ica, c1, c2, c3, c4, c5, c6
@[inline] def modifyInferTypeCache (f : InferTypeCache InferTypeCache) : MetaM Unit :=
modifyCache fun ic, c1, c2, c3, c4, c5 => f ic, c1, c2, c3, c4, c5
@[inline] def modifyDefEqTransientCache (f : DefEqCache DefEqCache) : MetaM Unit :=
modifyCache fun c1, c2, c3, c4, c5, defeqTrans, c6 => c1, c2, c3, c4, c5, f defeqTrans, c6
modifyCache fun c1, c2, c3, c4, defeqTrans, c5 => c1, c2, c3, c4, f defeqTrans, c5
@[inline] def modifyDefEqPermCache (f : DefEqCache DefEqCache) : MetaM Unit :=
modifyCache fun c1, c2, c3, c4, c5, c6, defeqPerm => c1, c2, c3, c4, c5, c6, f defeqPerm
modifyCache fun c1, c2, c3, c4, c5, defeqPerm => c1, c2, c3, c4, c5, f defeqPerm
def mkExprConfigCacheKey (expr : Expr) : MetaM ExprConfigCacheKey :=
return { expr, configKey := ( read).configKey }
def mkDefEqCacheKey (lhs rhs : Expr) : MetaM DefEqCacheKey := do
let configKey := ( read).configKey
if Expr.quickLt lhs rhs then
return { lhs, rhs, configKey }
else
return { lhs := rhs, rhs := lhs, configKey }
def mkInfoCacheKey (expr : Expr) (nargs? : Option Nat) : MetaM InfoCacheKey :=
return { expr, nargs?, configKey := ( read).configKey }
@[inline] def resetDefEqPermCaches : MetaM Unit :=
modifyDefEqPermCache fun _ => {}
@@ -538,6 +660,9 @@ def getLocalInstances : MetaM LocalInstances :=
def getConfig : MetaM Config :=
return ( read).config
def getConfigWithKey : MetaM ConfigWithKey :=
return ( getConfig).toConfigWithKey
def resetZetaDeltaFVarIds : MetaM Unit :=
modify fun s => { s with zetaDeltaFVarIds := {} }
@@ -941,7 +1066,25 @@ def elimMVarDeps (xs : Array Expr) (e : Expr) (preserveOrder : Bool := false) :
/-- `withConfig f x` executes `x` using the updated configuration object obtained by applying `f`. -/
@[inline] def withConfig (f : Config Config) : n α n α :=
mapMetaM <| withReader (fun ctx => { ctx with config := f ctx.config })
mapMetaM <| withReader fun ctx =>
let config := f ctx.config
let configKey := config.toKey
{ ctx with config, configKey }
@[inline] def withConfigWithKey (c : ConfigWithKey) : n α n α :=
mapMetaM <| withReader fun ctx =>
let config := c.config
let configKey := c.key
{ ctx with config, configKey }
@[inline] def withCanUnfoldPred (p : Config ConstantInfo CoreM Bool) : n α n α :=
mapMetaM <| withReader (fun ctx => { ctx with canUnfold? := p })
@[inline] def withIncSynthPending : n α n α :=
mapMetaM <| withReader (fun ctx => { ctx with synthPendingDepth := ctx.synthPendingDepth + 1 })
@[inline] def withInTypeClassResolution : n α n α :=
mapMetaM <| withReader (fun ctx => { ctx with inTypeClassResolution := true })
/--
Executes `x` tracking zetaDelta reductions `Config.trackZetaDelta := true`
@@ -952,8 +1095,15 @@ Executes `x` tracking zetaDelta reductions `Config.trackZetaDelta := true`
@[inline] def withoutProofIrrelevance (x : n α) : n α :=
withConfig (fun cfg => { cfg with proofIrrelevance := false }) x
@[inline] private def Context.setTransparency (ctx : Context) (transparency : TransparencyMode) : Context :=
let config := { ctx.config with transparency }
-- Recall that `transparency` is stored in the first 2 bits
let configKey : UInt64 := ((ctx.configKey >>> (2 : UInt64)) <<< 2) ||| transparency.toUInt64
{ ctx with config, configKey }
@[inline] def withTransparency (mode : TransparencyMode) : n α n α :=
withConfig (fun config => { config with transparency := mode })
-- We avoid `withConfig` for performance reasons.
mapMetaM <| withReader (·.setTransparency mode)
/-- `withDefault x` executes `x` using the default transparency setting. -/
@[inline] def withDefault (x : n α) : n α :=
@@ -974,13 +1124,10 @@ or type class instances are unfolded.
Execute `x` ensuring the transparency setting is at least `mode`.
Recall that `.all > .default > .instances > .reducible`.
-/
@[inline] def withAtLeastTransparency (mode : TransparencyMode) (x : n α) : n α :=
withConfig
(fun config =>
let oldMode := config.transparency
let mode := if oldMode.lt mode then mode else oldMode
{ config with transparency := mode })
x
@[inline] def withAtLeastTransparency (mode : TransparencyMode) : n α n α :=
mapMetaM <| withReader fun ctx =>
let modeOld := ctx.config.transparency
ctx.setTransparency <| if modeOld.lt mode then mode else modeOld
/-- Execute `x` allowing `isDefEq` to assign synthetic opaque metavariables. -/
@[inline] def withAssignableSyntheticOpaque (x : n α) : n α :=
@@ -1002,8 +1149,8 @@ def getTheoremInfo (info : ConstantInfo) : MetaM (Option ConstantInfo) := do
private def getDefInfoTemp (info : ConstantInfo) : MetaM (Option ConstantInfo) := do
match ( getTransparency) with
| TransparencyMode.all => return some info
| TransparencyMode.default => return some info
| .all => return some info
| .default => return some info
| _ =>
if ( isReducible info.name) then
return some info
@@ -1422,6 +1569,14 @@ def withLocalDecl (name : Name) (bi : BinderInfo) (type : Expr) (k : Expr → n
def withLocalDeclD (name : Name) (type : Expr) (k : Expr n α) : n α :=
withLocalDecl name BinderInfo.default type k
/--
Similar to `withLocalDecl`, but it does **not** check whether the new variable is a local instance or not.
-/
def withLocalDeclNoLocalInstanceUpdate (name : Name) (bi : BinderInfo) (type : Expr) (x : Expr MetaM α) : MetaM α := do
let fvarId mkFreshFVarId
withReader (fun ctx => { ctx with lctx := ctx.lctx.mkLocalDecl fvarId name type bi }) do
x (mkFVar fvarId)
/-- Append an array of free variables `xs` to the local context and execute `k xs`.
`declInfos` takes the form of an array consisting of:
- the name of the variable
@@ -1538,11 +1693,11 @@ def withReplaceFVarId {α} (fvarId : FVarId) (e : Expr) : MetaM α → MetaM α
localInstances := ctx.localInstances.erase fvarId }
/--
`withNewMCtxDepth k` executes `k` with a higher metavariable context depth,
where metavariables created outside the `withNewMCtxDepth` (with a lower depth) cannot be assigned.
If `allowLevelAssignments` is set to true, then the level metavariable depth
is not increased, and level metavariables from the outer scope can be
assigned. (This is used by TC synthesis.)
`withNewMCtxDepth k` executes `k` with a higher metavariable context depth,
where metavariables created outside the `withNewMCtxDepth` (with a lower depth) cannot be assigned.
If `allowLevelAssignments` is set to true, then the level metavariable depth
is not increased, and level metavariables from the outer scope can be
assigned. (This is used by TC synthesis.)
-/
def withNewMCtxDepth (k : n α) (allowLevelAssignments := false) : n α :=
mapMetaM (withNewMCtxDepthImp allowLevelAssignments) k
@@ -1552,13 +1707,20 @@ private def withLocalContextImp (lctx : LocalContext) (localInsts : LocalInstanc
x
/--
`withLCtx lctx localInsts k` replaces the local context and local instances, and then executes `k`.
The local context and instances are restored after executing `k`.
This method assumes that the local instances in `localInsts` are in the local context `lctx`.
`withLCtx lctx localInsts k` replaces the local context and local instances, and then executes `k`.
The local context and instances are restored after executing `k`.
This method assumes that the local instances in `localInsts` are in the local context `lctx`.
-/
def withLCtx (lctx : LocalContext) (localInsts : LocalInstances) : n α n α :=
mapMetaM <| withLocalContextImp lctx localInsts
/--
Simpler version of `withLCtx` which just updates the local context. It is the resposability of the
caller ensure the local instances are also properly updated.
-/
def withLCtx' (lctx : LocalContext) : n α n α :=
mapMetaM <| withReader (fun ctx => { ctx with lctx })
/--
Runs `k` in a local environment with the `fvarIds` erased.
-/

View File

@@ -91,7 +91,15 @@ private partial def mkKey (e : Expr) : CanonM UInt64 := do
let eNew instantiateMVars e
unless eNew == e do
return ( mkKey eNew)
let info getFunInfo f
let info if f.hasLooseBVars then
-- If `f` has loose bound variables, `getFunInfo` will fail.
-- This can only happen if `f` contains local variables.
-- Instead we use an empty `FunInfo`, which results in the
-- `i < info.paramInfo.size` check below failing for all indices,
-- and hence mixing in the hash for all arguments.
pure {}
else
getFunInfo f
let mut k mkKey f
for i in [:e.getAppNumArgs] do
if h : i < info.paramInfo.size then
@@ -101,10 +109,13 @@ private partial def mkKey (e : Expr) : CanonM UInt64 := do
else
k := mixHash k ( mkKey (e.getArg! i))
return k
| .lam _ t b _
| .forallE _ t b _ =>
| .lam n t b bi
| .forallE n t b bi =>
-- Note that we do not use `withLocalDecl` here, for performance reasons.
-- Instead we have a guard for loose bound variables in the `.app` case above.
return mixHash ( mkKey t) ( mkKey b)
| .letE _ _ v b _ =>
| .letE n t v b _ =>
-- Similarly, we do not use `withLetDecl` here.
return mixHash ( mkKey v) ( mkKey b)
| .proj _ i s =>
return mixHash i.toUInt64 ( mkKey s)
@@ -124,11 +135,11 @@ def canon (e : Expr) : CanonM Expr := do
if ( isDefEq e e') then
return e'
-- `e` is not definitionally equal to any expression in `es'`. We claim this should be rare.
unsafe modify fun { cache, keyToExprs } => { cache, keyToExprs := keyToExprs.insert k (e :: es') }
modify fun { cache, keyToExprs } => { cache, keyToExprs := keyToExprs.insert k (e :: es') }
return e
else
-- `e` is the first expression we found with key `k`.
unsafe modify fun { cache, keyToExprs } => { cache, keyToExprs := keyToExprs.insert k [e] }
modify fun { cache, keyToExprs } => { cache, keyToExprs := keyToExprs.insert k [e] }
return e
end Canonicalizer

View File

@@ -157,9 +157,11 @@ def coerceMonadLift? (e expectedType : Expr) : MetaM (Option Expr) := do
let eType instantiateMVars ( inferType e)
let some (n, β) isTypeApp? expectedType | return none
let some (m, α) isTypeApp? eType | return none
-- Need to save and restore the state in case `m` and `n` are defeq but not monads to prevent this procedure from having side effects.
let saved saveState
if ( isDefEq m n) then
let some monadInst isMonad? n | return none
try expandCoe ( mkAppOptM ``Lean.Internal.coeM #[m, α, β, none, monadInst, e]) catch _ => return none
let some monadInst isMonad? n | restoreState saved; return none
try expandCoe ( mkAppOptM ``Lean.Internal.coeM #[m, α, β, none, monadInst, e]) catch _ => restoreState saved; return none
else if autoLift.get ( getOptions) then
try
-- Construct lift from `m` to `n`

View File

@@ -305,16 +305,13 @@ def hasNoindexAnnotation (e : Expr) : Bool :=
/--
Reduction procedure for the discrimination tree indexing.
The parameter `config` controls how aggressively the term is reduced.
The parameter at type `DiscrTree` controls this value.
See comment at `DiscrTree`.
-/
partial def reduce (e : Expr) (config : WhnfCoreConfig) : MetaM Expr := do
let e whnfCore e config
partial def reduce (e : Expr) : MetaM Expr := do
let e whnfCore e
match ( unfoldDefinition? e) with
| some e => reduce e config
| some e => reduce e
| none => match e.etaExpandedStrict? with
| some e => reduce e config
| some e => reduce e
| none => return e
/--
@@ -333,24 +330,24 @@ private def isBadKey (fn : Expr) : Bool :=
| _ => true
/--
Reduce `e` until we get an irreducible term (modulo current reducibility setting) or the resulting term
is a bad key (see comment at `isBadKey`).
We use this method instead of `reduce` for root terms at `pushArgs`. -/
private partial def reduceUntilBadKey (e : Expr) (config : WhnfCoreConfig) : MetaM Expr := do
Reduce `e` until we get an irreducible term (modulo current reducibility setting) or the resulting term
is a bad key (see comment at `isBadKey`).
We use this method instead of `reduce` for root terms at `pushArgs`. -/
private partial def reduceUntilBadKey (e : Expr) : MetaM Expr := do
let e step e
match e.etaExpandedStrict? with
| some e => reduceUntilBadKey e config
| some e => reduceUntilBadKey e
| none => return e
where
step (e : Expr) := do
let e whnfCore e config
let e whnfCore e
match ( unfoldDefinition? e) with
| some e' => if isBadKey e'.getAppFn then return e else step e'
| none => return e
/-- whnf for the discrimination tree module -/
def reduceDT (e : Expr) (root : Bool) (config : WhnfCoreConfig) : MetaM Expr :=
if root then reduceUntilBadKey e config else reduce e config
def reduceDT (e : Expr) (root : Bool) : MetaM Expr :=
if root then reduceUntilBadKey e else reduce e
/- Remark: we use `shouldAddAsStar` only for nested terms, and `root == false` for nested terms -/
@@ -372,11 +369,11 @@ In this issue, we have a local hypotheses `(h : ∀ p : α × β, f p p.2 = p.2)
For example, it was introduced by another tactic. Thus, when populating the discrimination tree explicit arguments provided to `simp` (e.g., `simp [h]`),
we use `noIndexAtArgs := true`. See comment: https://github.com/leanprover/lean4/issues/2670#issuecomment-1758889365
-/
private def pushArgs (root : Bool) (todo : Array Expr) (e : Expr) (config : WhnfCoreConfig) (noIndexAtArgs : Bool) : MetaM (Key × Array Expr) := do
private def pushArgs (root : Bool) (todo : Array Expr) (e : Expr) (noIndexAtArgs : Bool) : MetaM (Key × Array Expr) := do
if hasNoindexAnnotation e then
return (.star, todo)
else
let e reduceDT e root config
let e reduceDT e root
let fn := e.getAppFn
let push (k : Key) (nargs : Nat) (todo : Array Expr): MetaM (Key × Array Expr) := do
let info getFunInfoNArgs fn nargs
@@ -422,23 +419,23 @@ private def pushArgs (root : Bool) (todo : Array Expr) (e : Expr) (config : Whnf
| _ => return (.other, todo)
@[inherit_doc pushArgs]
partial def mkPathAux (root : Bool) (todo : Array Expr) (keys : Array Key) (config : WhnfCoreConfig) (noIndexAtArgs : Bool) : MetaM (Array Key) := do
partial def mkPathAux (root : Bool) (todo : Array Expr) (keys : Array Key) (noIndexAtArgs : Bool) : MetaM (Array Key) := do
if todo.isEmpty then
return keys
else
let e := todo.back!
let todo := todo.pop
let (k, todo) pushArgs root todo e config noIndexAtArgs
mkPathAux false todo (keys.push k) config noIndexAtArgs
let (k, todo) pushArgs root todo e noIndexAtArgs
mkPathAux false todo (keys.push k) noIndexAtArgs
private def initCapacity := 8
@[inherit_doc pushArgs]
def mkPath (e : Expr) (config : WhnfCoreConfig) (noIndexAtArgs := false) : MetaM (Array Key) := do
def mkPath (e : Expr) (noIndexAtArgs := false) : MetaM (Array Key) := do
withReducible do
let todo : Array Expr := .mkEmpty initCapacity
let keys : Array Key := .mkEmpty initCapacity
mkPathAux (root := true) (todo.push e) keys config noIndexAtArgs
mkPathAux (root := true) (todo.push e) keys noIndexAtArgs
private partial def createNodes (keys : Array Key) (v : α) (i : Nat) : Trie α :=
if h : i < keys.size then
@@ -492,23 +489,23 @@ def insertCore [BEq α] (d : DiscrTree α) (keys : Array Key) (v : α) : DiscrTr
let c := insertAux keys v 1 c
{ root := d.root.insert k c }
def insert [BEq α] (d : DiscrTree α) (e : Expr) (v : α) (config : WhnfCoreConfig) (noIndexAtArgs := false) : MetaM (DiscrTree α) := do
let keys mkPath e config noIndexAtArgs
def insert [BEq α] (d : DiscrTree α) (e : Expr) (v : α) (noIndexAtArgs := false) : MetaM (DiscrTree α) := do
let keys mkPath e noIndexAtArgs
return d.insertCore keys v
/--
Inserts a value into a discrimination tree,
but only if its key is not of the form `#[*]` or `#[=, *, *, *]`.
-/
def insertIfSpecific [BEq α] (d : DiscrTree α) (e : Expr) (v : α) (config : WhnfCoreConfig) (noIndexAtArgs := false) : MetaM (DiscrTree α) := do
let keys mkPath e config noIndexAtArgs
def insertIfSpecific [BEq α] (d : DiscrTree α) (e : Expr) (v : α) (noIndexAtArgs := false) : MetaM (DiscrTree α) := do
let keys mkPath e noIndexAtArgs
return if keys == #[Key.star] || keys == #[Key.const `Eq 3, Key.star, Key.star, Key.star] then
d
else
d.insertCore keys v
private def getKeyArgs (e : Expr) (isMatch root : Bool) (config : WhnfCoreConfig) : MetaM (Key × Array Expr) := do
let e reduceDT e root config
private def getKeyArgs (e : Expr) (isMatch root : Bool) : MetaM (Key × Array Expr) := do
let e reduceDT e root
unless root do
-- See pushArgs
if let some v := toNatLit? e then
@@ -553,8 +550,8 @@ private def getKeyArgs (e : Expr) (isMatch root : Bool) (config : WhnfCoreConfig
if isMatch then
return (.other, #[])
else do
let ctx read
if ctx.config.isDefEqStuckEx then
let cfg getConfig
if cfg.isDefEqStuckEx then
/-
When the configuration flag `isDefEqStuckEx` is set to true,
we want `isDefEq` to throw an exception whenever it tries to assign
@@ -580,11 +577,11 @@ private def getKeyArgs (e : Expr) (isMatch root : Bool) (config : WhnfCoreConfig
| .forallE _ d _ _ => return (.arrow, #[d])
| _ => return (.other, #[])
private abbrev getMatchKeyArgs (e : Expr) (root : Bool) (config : WhnfCoreConfig) : MetaM (Key × Array Expr) :=
getKeyArgs e (isMatch := true) (root := root) (config := config)
private abbrev getMatchKeyArgs (e : Expr) (root : Bool) : MetaM (Key × Array Expr) :=
getKeyArgs e (isMatch := true) (root := root)
private abbrev getUnifyKeyArgs (e : Expr) (root : Bool) (config : WhnfCoreConfig) : MetaM (Key × Array Expr) :=
getKeyArgs e (isMatch := false) (root := root) (config := config)
private abbrev getUnifyKeyArgs (e : Expr) (root : Bool) : MetaM (Key × Array Expr) :=
getKeyArgs e (isMatch := false) (root := root)
private def getStarResult (d : DiscrTree α) : Array α :=
let result : Array α := .mkEmpty initCapacity
@@ -595,7 +592,7 @@ private def getStarResult (d : DiscrTree α) : Array α :=
private abbrev findKey (cs : Array (Key × Trie α)) (k : Key) : Option (Key × Trie α) :=
cs.binSearch (k, default) (fun a b => a.1 < b.1)
private partial def getMatchLoop (todo : Array Expr) (c : Trie α) (result : Array α) (config : WhnfCoreConfig) : MetaM (Array α) := do
private partial def getMatchLoop (todo : Array Expr) (c : Trie α) (result : Array α) : MetaM (Array α) := do
match c with
| .node vs cs =>
if todo.isEmpty then
@@ -606,48 +603,48 @@ private partial def getMatchLoop (todo : Array Expr) (c : Trie α) (result : Arr
let e := todo.back!
let todo := todo.pop
let first := cs[0]! /- Recall that `Key.star` is the minimal key -/
let (k, args) getMatchKeyArgs e (root := false) config
let (k, args) getMatchKeyArgs e (root := false)
/- We must always visit `Key.star` edges since they are wildcards.
Thus, `todo` is not used linearly when there is `Key.star` edge
and there is an edge for `k` and `k != Key.star`. -/
let visitStar (result : Array α) : MetaM (Array α) :=
if first.1 == .star then
getMatchLoop todo first.2 result config
getMatchLoop todo first.2 result
else
return result
let visitNonStar (k : Key) (args : Array Expr) (result : Array α) : MetaM (Array α) :=
match findKey cs k with
| none => return result
| some c => getMatchLoop (todo ++ args) c.2 result config
| some c => getMatchLoop (todo ++ args) c.2 result
let result visitStar result
match k with
| .star => return result
| _ => visitNonStar k args result
private def getMatchRoot (d : DiscrTree α) (k : Key) (args : Array Expr) (result : Array α) (config : WhnfCoreConfig) : MetaM (Array α) :=
private def getMatchRoot (d : DiscrTree α) (k : Key) (args : Array Expr) (result : Array α) : MetaM (Array α) :=
match d.root.find? k with
| none => return result
| some c => getMatchLoop args c result config
| some c => getMatchLoop args c result
private def getMatchCore (d : DiscrTree α) (e : Expr) (config : WhnfCoreConfig) : MetaM (Key × Array α) :=
private def getMatchCore (d : DiscrTree α) (e : Expr) : MetaM (Key × Array α) :=
withReducible do
let result := getStarResult d
let (k, args) getMatchKeyArgs e (root := true) config
let (k, args) getMatchKeyArgs e (root := true)
match k with
| .star => return (k, result)
| _ => return (k, ( getMatchRoot d k args result config))
| _ => return (k, ( getMatchRoot d k args result))
/--
Find values that match `e` in `d`.
-/
def getMatch (d : DiscrTree α) (e : Expr) (config : WhnfCoreConfig) : MetaM (Array α) :=
return ( getMatchCore d e config).2
def getMatch (d : DiscrTree α) (e : Expr) : MetaM (Array α) :=
return ( getMatchCore d e).2
/--
Similar to `getMatch`, but returns solutions that are prefixes of `e`.
We store the number of ignored arguments in the result.-/
partial def getMatchWithExtra (d : DiscrTree α) (e : Expr) (config : WhnfCoreConfig) : MetaM (Array (α × Nat)) := do
let (k, result) getMatchCore d e config
partial def getMatchWithExtra (d : DiscrTree α) (e : Expr) : MetaM (Array (α × Nat)) := do
let (k, result) getMatchCore d e
let result := result.map (·, 0)
if !e.isApp then
return result
@@ -669,7 +666,7 @@ where
| _ => return false
go (e : Expr) (numExtra : Nat) (result : Array (α × Nat)) : MetaM (Array (α × Nat)) := do
let result := result ++ ( getMatchCore d e config).2.map (., numExtra)
let result := result ++ ( getMatchCore d e).2.map (., numExtra)
if e.isApp then
go e.appFn! (numExtra + 1) result
else
@@ -678,8 +675,8 @@ where
/--
Return the root symbol for `e`, and the number of arguments after `reduceDT`.
-/
def getMatchKeyRootFor (e : Expr) (config : WhnfCoreConfig) : MetaM (Key × Nat) := do
let e reduceDT e (root := true) config
def getMatchKeyRootFor (e : Expr) : MetaM (Key × Nat) := do
let e reduceDT e (root := true)
let numArgs := e.getAppNumArgs
let key := match e.getAppFn with
| .lit v => .lit v
@@ -716,17 +713,17 @@ We use this method to simulate Lean 3's indexing.
The natural number in the result is the number of arguments in `e` after `reduceDT`.
-/
def getMatchLiberal (d : DiscrTree α) (e : Expr) (config : WhnfCoreConfig) : MetaM (Array α × Nat) := do
def getMatchLiberal (d : DiscrTree α) (e : Expr) : MetaM (Array α × Nat) := do
withReducible do
let result := getStarResult d
let (k, numArgs) getMatchKeyRootFor e config
let (k, numArgs) getMatchKeyRootFor e
match k with
| .star => return (result, numArgs)
| _ => return (getAllValuesForKey d k result, numArgs)
partial def getUnify (d : DiscrTree α) (e : Expr) (config : WhnfCoreConfig) : MetaM (Array α) :=
partial def getUnify (d : DiscrTree α) (e : Expr) : MetaM (Array α) :=
withReducible do
let (k, args) getUnifyKeyArgs e (root := true) config
let (k, args) getUnifyKeyArgs e (root := true)
match k with
| .star => d.root.foldlM (init := #[]) fun result k c => process k.arity #[] c result
| _ =>
@@ -750,7 +747,7 @@ where
else
let e := todo.back!
let todo := todo.pop
let (k, args) getUnifyKeyArgs e (root := false) config
let (k, args) getUnifyKeyArgs e (root := false)
let visitStar (result : Array α) : MetaM (Array α) :=
let first := cs[0]!
if first.1 == .star then

View File

@@ -364,7 +364,7 @@ private partial def isDefEqBindingAux (lctx : LocalContext) (fvars : Array Expr)
| Expr.forallE n d₁ b₁ _, Expr.forallE _ d₂ b₂ _ => process n d₁ d₂ b₁ b₂
| Expr.lam n d₁ b₁ _, Expr.lam _ d₂ b₂ _ => process n d₁ d₂ b₁ b₂
| _, _ =>
withReader (fun ctx => { ctx with lctx := lctx }) do
withLCtx' lctx do
isDefEqBindingDomain fvars ds₂ do
Meta.isExprDefEqAux (e₁.instantiateRev fvars) (e₂.instantiateRev fvars)
@@ -758,8 +758,8 @@ mutual
if mvarDecl.depth != ( getMCtx).depth || mvarDecl.kind.isSyntheticOpaque then
traceM `Meta.isDefEq.assign.readOnlyMVarWithBiggerLCtx <| addAssignmentInfo (mkMVar mvarId)
throwCheckAssignmentFailure
let ctxMeta readThe Meta.Context
unless ctxMeta.config.ctxApprox && ctx.mvarDecl.lctx.isSubPrefixOf mvarDecl.lctx do
let cfg getConfig
unless cfg.ctxApprox && ctx.mvarDecl.lctx.isSubPrefixOf mvarDecl.lctx do
traceM `Meta.isDefEq.assign.readOnlyMVarWithBiggerLCtx <| addAssignmentInfo (mkMVar mvarId)
throwCheckAssignmentFailure
/- Create an auxiliary metavariable with a smaller context and "checked" type.
@@ -814,8 +814,8 @@ mutual
partial def checkApp (e : Expr) : CheckAssignmentM Expr :=
e.withApp fun f args => do
let ctxMeta readThe Meta.Context
if f.isMVar && ctxMeta.config.ctxApprox && args.all Expr.isFVar then
let cfg getConfig
if f.isMVar && cfg.ctxApprox && args.all Expr.isFVar then
let f check f
catchInternalId outOfScopeExceptionId
(do
@@ -1387,15 +1387,21 @@ private abbrev unfold (e : Expr) (failK : MetaM α) (successK : Expr → MetaM
/-- Auxiliary method for isDefEqDelta -/
private def unfoldBothDefEq (fn : Name) (t s : Expr) : MetaM LBool := do
match t, s with
| Expr.const _ ls₁, Expr.const _ ls₂ => isListLevelDefEq ls₁ ls₂
| Expr.app _ _, Expr.app _ _ =>
| .const _ ls₁, .const _ ls₂ =>
match ( isListLevelDefEq ls₁ ls₂) with
| .true => return .true
| _ =>
unfold t (pure .undef) fun t =>
unfold s (pure .undef) fun s =>
isDefEqLeftRight fn t s
| .app _ _, .app _ _ =>
if ( tryHeuristic t s) then
pure LBool.true
return .true
else
unfold t
(unfold s (pure LBool.undef) (fun s => isDefEqRight fn t s))
(unfold s (pure .undef) fun s => isDefEqRight fn t s)
(fun t => unfold s (isDefEqLeft fn t s) (fun s => isDefEqLeftRight fn t s))
| _, _ => pure LBool.false
| _, _ => return .false
private def sameHeadSymbol (t s : Expr) : Bool :=
match t.getAppFn, s.getAppFn with
@@ -1674,11 +1680,12 @@ private partial def isDefEqQuick (t s : Expr) : MetaM LBool :=
-- | Expr.mdata _ t _, s => isDefEqQuick t s
-- | t, Expr.mdata _ s _ => isDefEqQuick t s
| .fvar fvarId₁, .fvar fvarId₂ => do
if ( fvarId₁.isLetVar <||> fvarId₂.isLetVar) then
return LBool.undef
else if fvarId₁ == fvarId₂ then
return LBool.true
if fvarId₁ == fvarId₂ then
return .true
else if ( fvarId₁.isLetVar <||> fvarId₂.isLetVar) then
return .undef
else
-- If `t` and `s` are not proofs or let-variables, we still return `.undef` and let other rules (e.g., unit-like) kick in.
isDefEqProofIrrel t s
| t, s =>
isDefEqQuickOther t s
@@ -1794,8 +1801,8 @@ private partial def isDefEqQuickOther (t s : Expr) : MetaM LBool := do
| LBool.true => return LBool.true
| LBool.false => return LBool.false
| _ =>
let ctx read
if ctx.config.isDefEqStuckEx then do
let cfg getConfig
if cfg.isDefEqStuckEx then do
trace[Meta.isDefEq.stuck] "{t} =?= {s}"
Meta.throwIsDefEqStuck
else
@@ -1834,7 +1841,7 @@ end
let e instantiateMVars e
successK e
else
if ( read).config.isDefEqStuckEx then
if ( getConfig).isDefEqStuckEx then
/-
When `isDefEqStuckEx := true` and `mvar` was created in a previous level,
we should throw an exception. See issue #2736 for a situation where this can happen.
@@ -2079,50 +2086,37 @@ Structure for storing defeq cache key information.
-/
structure DefEqCacheKeyInfo where
kind : DefEqCacheKind
key : Expr × Expr
key : DefEqCacheKey
private def mkCacheKey (t s : Expr) : MetaM DefEqCacheKeyInfo := do
let kind getDefEqCacheKind t s
let key := if Expr.quickLt t s then (t, s) else (s, t)
let key mkDefEqCacheKey t s
return { key, kind }
private def getCachedResult (keyInfo : DefEqCacheKeyInfo) : MetaM LBool := do
let cache match keyInfo.kind with
| .transient => pure ( get).cache.defEqTrans
| .permanent => pure ( get).cache.defEqPerm
let cache := match ( getTransparency) with
| .reducible => cache.reducible
| .instances => cache.instances
| .default => cache.default
| .all => cache.all
match cache.find? keyInfo.key with
| some val => return val.toLBool
| none => return .undef
def DefEqCache.update (cache : DefEqCache) (mode : TransparencyMode) (key : Expr × Expr) (result : Bool) : DefEqCache :=
match mode with
| .reducible => { cache with reducible := cache.reducible.insert key result }
| .instances => { cache with instances := cache.instances.insert key result }
| .default => { cache with default := cache.default.insert key result }
| .all => { cache with all := cache.all.insert key result }
private def cacheResult (keyInfo : DefEqCacheKeyInfo) (result : Bool) : MetaM Unit := do
let mode getTransparency
let key := keyInfo.key
match keyInfo.kind with
| .permanent => modifyDefEqPermCache fun c => c.update mode key result
| .permanent => modifyDefEqPermCache fun c => c.insert key result
| .transient =>
/-
We must ensure that all assigned metavariables in the key are replaced by their current assignments.
Otherwise, the key is invalid after the assignment is "backtracked".
See issue #1870 for an example.
-/
let key := ( instantiateMVars key.1, instantiateMVars key.2)
modifyDefEqTransientCache fun c => c.update mode key result
let key mkDefEqCacheKey ( instantiateMVars key.lhs) ( instantiateMVars key.rhs)
modifyDefEqTransientCache fun c => c.insert key result
private def whnfCoreAtDefEq (e : Expr) : MetaM Expr := do
if backward.isDefEq.lazyWhnfCore.get ( getOptions) then
whnfCore e (config := { proj := .yesWithDeltaI })
withConfig (fun ctx => { ctx with proj := .yesWithDeltaI }) <| whnfCore e
else
whnfCore e

View File

@@ -10,13 +10,13 @@ import Lean.Meta.InferType
namespace Lean.Meta
@[inline] private def checkFunInfoCache (fn : Expr) (maxArgs? : Option Nat) (k : MetaM FunInfo) : MetaM FunInfo := do
let t getTransparency
match ( get).cache.funInfo.find? t, fn, maxArgs? with
| some finfo => pure finfo
let key mkInfoCacheKey fn maxArgs?
match ( get).cache.funInfo.find? key with
| some finfo => return finfo
| none => do
let finfo k
modify fun s => { s with cache := { s.cache with funInfo := s.cache.funInfo.insert t, fn, maxArgs? finfo } }
pure finfo
modify fun s => { s with cache := { s.cache with funInfo := s.cache.funInfo.insert key finfo } }
return finfo
@[inline] private def whenHasVar {α} (e : Expr) (deps : α) (k : α α) : α :=
if e.hasFVar then k deps else deps

View File

@@ -22,10 +22,11 @@ private def canUnfoldDefault (cfg : Config) (info : ConstantInfo) : CoreM Bool :
def canUnfold (info : ConstantInfo) : MetaM Bool := do
let ctx read
let cfg getConfig
if let some f := ctx.canUnfold? then
f ctx.config info
f cfg info
else
canUnfoldDefault ctx.config info
canUnfoldDefault cfg info
/--
Look up a constant name, returning the `ConstantInfo`

View File

@@ -97,8 +97,8 @@ private def inferConstType (c : Name) (us : List Level) : MetaM Expr := do
private def inferProjType (structName : Name) (idx : Nat) (e : Expr) : MetaM Expr := do
let structType inferType e
let structType whnf structType
let failed {α} : Unit MetaM α := fun _ =>
throwError "invalid projection{indentExpr (mkProj structName idx e)} from type {structType}"
let failed {α} : Unit MetaM α := fun _ => do
throwError "invalid projection{indentExpr (mkProj structName idx e)}\nfrom type{indentExpr structType}"
matchConstStructure structType.getAppFn failed fun structVal structLvls ctorVal =>
let structTypeArgs := structType.getAppArgs
if structVal.numParams + structVal.numIndices != structTypeArgs.size then
@@ -165,24 +165,27 @@ private def inferFVarType (fvarId : FVarId) : MetaM Expr := do
| none => fvarId.throwUnknown
@[inline] private def checkInferTypeCache (e : Expr) (inferType : MetaM Expr) : MetaM Expr := do
match ( getTransparency) with
| .default =>
match ( get).cache.inferType.default.find? e with
if e.hasMVar then
inferType
else
let key mkExprConfigCacheKey e
match ( get).cache.inferType.find? key with
| some type => return type
| none =>
let type inferType
unless e.hasMVar || type.hasMVar do
modifyInferTypeCacheDefault fun c => c.insert e type
unless type.hasMVar do
modifyInferTypeCache fun c => c.insert key type
return type
| .all =>
match ( get).cache.inferType.all.find? e with
| some type => return type
| none =>
let type inferType
unless e.hasMVar || type.hasMVar do
modifyInferTypeCacheAll fun c => c.insert e type
return type
| _ => panic! "checkInferTypeCache: transparency mode not default or all"
private def defaultConfig : ConfigWithKey :=
{ : Config }.toConfigWithKey
private def allConfig : ConfigWithKey :=
{ transparency := .all : Config }.toConfigWithKey
@[inline] def withInferTypeConfig (x : MetaM α) : MetaM α := do
let cfg := if ( getTransparency) == .all then allConfig else defaultConfig
withConfigWithKey cfg x
@[export lean_infer_type]
def inferTypeImp (e : Expr) : MetaM Expr :=
@@ -201,7 +204,7 @@ def inferTypeImp (e : Expr) : MetaM Expr :=
| .forallE .. => checkInferTypeCache e (inferForallType e)
| .lam .. => checkInferTypeCache e (inferLambdaType e)
| .letE .. => checkInferTypeCache e (inferLambdaType e)
withIncRecDepth <| withAtLeastTransparency TransparencyMode.default (infer e)
withIncRecDepth <| withInferTypeConfig (infer e)
/--
Return `LBool.true` if given level is always equivalent to universe level zero.
@@ -382,11 +385,6 @@ def isType (e : Expr) : MetaM Bool := do
| .sort .. => return true
| _ => return false
@[inline] private def withLocalDecl' {α} (name : Name) (bi : BinderInfo) (type : Expr) (x : Expr MetaM α) : MetaM α := do
let fvarId mkFreshFVarId
withReader (fun ctx => { ctx with lctx := ctx.lctx.mkLocalDecl fvarId name type bi }) do
x (mkFVar fvarId)
def typeFormerTypeLevelQuick : Expr Option Level
| .forallE _ _ b _ => typeFormerTypeLevelQuick b
| .sort l => some l
@@ -403,7 +401,7 @@ where
go (type : Expr) (xs : Array Expr) : MetaM (Option Level) := do
match type with
| .sort l => return some l
| .forallE n d b c => withLocalDecl' n c (d.instantiateRev xs) fun x => go b (xs.push x)
| .forallE n d b c => withLocalDeclNoLocalInstanceUpdate n c (d.instantiateRev xs) fun x => go b (xs.push x)
| _ =>
let type whnfD (type.instantiateRev xs)
match type with

View File

@@ -72,9 +72,6 @@ structure Instances where
erased : PHashSet Name := {}
deriving Inhabited
/-- Configuration for the discrimination tree module -/
def tcDtConfig : WhnfCoreConfig := {}
def addInstanceEntry (d : Instances) (e : InstanceEntry) : Instances :=
match e.globalName? with
| some n => { d with discrTree := d.discrTree.insertCore e.keys e, instanceNames := d.instanceNames.insert n e, erased := d.erased.erase n }
@@ -98,7 +95,7 @@ private def mkInstanceKey (e : Expr) : MetaM (Array InstanceKey) := do
let type inferType e
withNewMCtxDepth do
let (_, _, type) forallMetaTelescopeReducing type
DiscrTree.mkPath type tcDtConfig
DiscrTree.mkPath type
/--
Compute the order the arguments of `inst` should be synthesized.

View File

@@ -184,9 +184,9 @@ private def elimLooseBVarsByBeta (e : Expr) : CoreM Expr :=
else
return .continue)
private def getKeyArgs (e : Expr) (isMatch root : Bool) (config : WhnfCoreConfig) :
private def getKeyArgs (e : Expr) (isMatch root : Bool) :
MetaM (Key × Array Expr) := do
let e DiscrTree.reduceDT e root config
let e DiscrTree.reduceDT e root
unless root do
-- See pushArgs
if let some v := toNatLit? e then
@@ -222,8 +222,8 @@ private def getKeyArgs (e : Expr) (isMatch root : Bool) (config : WhnfCoreConfig
if isMatch then
return (.other, #[])
else do
let ctx read
if ctx.config.isDefEqStuckEx then
let cfg getConfig
if cfg.isDefEqStuckEx then
/-
When the configuration flag `isDefEqStuckEx` is set to true,
we want `isDefEq` to throw an exception whenever it tries to assign
@@ -259,9 +259,9 @@ private def getKeyArgs (e : Expr) (isMatch root : Bool) (config : WhnfCoreConfig
/-
Given an expression we are looking for patterns that match, return the key and sub-expressions.
-/
private abbrev getMatchKeyArgs (e : Expr) (root : Bool) (config : WhnfCoreConfig) :
private abbrev getMatchKeyArgs (e : Expr) (root : Bool) :
MetaM (Key × Array Expr) :=
getKeyArgs e (isMatch := true) (root := root) (config := config)
getKeyArgs e (isMatch := true) (root := root)
end MatchClone
@@ -313,8 +313,6 @@ discriminator key is computed and processing the remaining
terms is deferred until demanded by a match.
-/
structure LazyDiscrTree (α : Type) where
/-- Configuration for normalization. -/
config : Lean.Meta.WhnfCoreConfig := {}
/-- Backing array of trie entries. Should be owned by this trie. -/
tries : Array (LazyDiscrTree.Trie α) := #[default]
/-- Map from discriminator trie roots to the index. -/
@@ -332,12 +330,12 @@ open Lean.Meta.DiscrTree (mkNoindexAnnotation hasNoindexAnnotation reduceDT)
/--
Specialization of Lean.Meta.DiscrTree.pushArgs
-/
private def pushArgs (root : Bool) (todo : Array Expr) (e : Expr) (config : WhnfCoreConfig) :
private def pushArgs (root : Bool) (todo : Array Expr) (e : Expr) :
MetaM (Key × Array Expr) := do
if hasNoindexAnnotation e then
return (.star, todo)
else
let e reduceDT e root config
let e reduceDT e root
let fn := e.getAppFn
let push (k : Key) (nargs : Nat) (todo : Array Expr) : MetaM (Key × Array Expr) := do
let info getFunInfoNArgs fn nargs
@@ -389,8 +387,8 @@ private def initCapacity := 8
/--
Get the root key and rest of terms of an expression using the specified config.
-/
private def rootKey (cfg: WhnfCoreConfig) (e : Expr) : MetaM (Key × Array Expr) :=
pushArgs true (Array.mkEmpty initCapacity) e cfg
private def rootKey (e : Expr) : MetaM (Key × Array Expr) :=
pushArgs true (Array.mkEmpty initCapacity) e
private partial def buildPath (op : Bool Array Expr Expr MetaM (Key × Array Expr)) (root : Bool) (todo : Array Expr) (keys : Array Key) : MetaM (Array Key) := do
if todo.isEmpty then
@@ -407,9 +405,9 @@ Create a key path from an expression using the function used for patterns.
This differs from Lean.Meta.DiscrTree.mkPath and targetPath in that the expression
should uses free variables rather than meta-variables for holes.
-/
def patternPath (e : Expr) (config : WhnfCoreConfig) : MetaM (Array Key) := do
def patternPath (e : Expr) : MetaM (Array Key) := do
let todo : Array Expr := .mkEmpty initCapacity
let op root todo e := pushArgs root todo e config
let op root todo e := pushArgs root todo e
buildPath op (root := true) (todo.push e) (.mkEmpty initCapacity)
/--
@@ -417,21 +415,21 @@ Create a key path from an expression we are matching against.
This should have mvars instantiated where feasible.
-/
def targetPath (e : Expr) (config : WhnfCoreConfig) : MetaM (Array Key) := do
def targetPath (e : Expr) : MetaM (Array Key) := do
let todo : Array Expr := .mkEmpty initCapacity
let op root todo e := do
let (k, args) MatchClone.getMatchKeyArgs e root config
let (k, args) MatchClone.getMatchKeyArgs e root
pure (k, todo ++ args)
buildPath op (root := true) (todo.push e) (.mkEmpty initCapacity)
/- Monad for finding matches while resolving deferred patterns. -/
@[reducible]
private def MatchM α := ReaderT WhnfCoreConfig (StateRefT (Array (Trie α)) MetaM)
private def MatchM α := StateRefT (Array (Trie α)) MetaM
private def runMatch (d : LazyDiscrTree α) (m : MatchM α β) : MetaM (β × LazyDiscrTree α) := do
let { config := c, tries := a, roots := r } := d
let (result, a) withReducible $ (m.run c).run a
pure (result, { config := c, tries := a, roots := r})
let { tries := a, roots := r } := d
let (result, a) withReducible <| m.run a
return (result, { tries := a, roots := r})
private def setTrie (i : TrieIndex) (v : Trie α) : MatchM α Unit :=
modify (·.set! i v)
@@ -444,7 +442,7 @@ private def newTrie [Monad m] [MonadState (Array (Trie α)) m] (e : LazyEntry α
private def addLazyEntryToTrie (i:TrieIndex) (e : LazyEntry α) : MatchM α Unit :=
modify (·.modify i (·.pushPending e))
private def evalLazyEntry (config : WhnfCoreConfig)
private def evalLazyEntry
(p : Array α × TrieIndex × Std.HashMap Key TrieIndex)
(entry : LazyEntry α)
: MatchM α (Array α × TrieIndex × Std.HashMap Key TrieIndex) := do
@@ -456,7 +454,7 @@ private def evalLazyEntry (config : WhnfCoreConfig)
else
let e := todo.back!
let todo := todo.pop
let (k, todo) withLCtx lctx.1 lctx.2 $ pushArgs false todo e config
let (k, todo) withLCtx lctx.1 lctx.2 <| pushArgs false todo e
if k == .star then
if starIdx = 0 then
let starIdx newTrie (todo, lctx, v)
@@ -477,26 +475,25 @@ private def evalLazyEntry (config : WhnfCoreConfig)
This evaluates all lazy entries in a trie and updates `values`, `starIdx`, and `children`
accordingly.
-/
private partial def evalLazyEntries (config : WhnfCoreConfig)
private partial def evalLazyEntries
(values : Array α) (starIdx : TrieIndex) (children : Std.HashMap Key TrieIndex)
(entries : Array (LazyEntry α)) :
MatchM α (Array α × TrieIndex × Std.HashMap Key TrieIndex) := do
let mut values := values
let mut starIdx := starIdx
let mut children := children
entries.foldlM (init := (values, starIdx, children)) (evalLazyEntry config)
entries.foldlM (init := (values, starIdx, children)) evalLazyEntry
private def evalNode (c : TrieIndex) :
MatchM α (Array α × TrieIndex × Std.HashMap Key TrieIndex) := do
let .node vs star cs pending := (get).get! c
if pending.size = 0 then
pure (vs, star, cs)
return (vs, star, cs)
else
let config read
setTrie c default
let (vs, star, cs) evalLazyEntries config vs star cs pending
let (vs, star, cs) evalLazyEntries vs star cs pending
setTrie c <| .node vs star cs #[]
pure (vs, star, cs)
return (vs, star, cs)
def dropKeyAux (next : TrieIndex) (rest : List Key) :
MatchM α Unit :=
@@ -723,11 +720,11 @@ private def push (d : PreDiscrTree α) (k : Key) (e : LazyEntry α) : PreDiscrTr
d.modifyAt k (·.push e)
/-- Convert a pre-discrimination tree to a lazy discrimination tree. -/
private def toLazy (d : PreDiscrTree α) (config : WhnfCoreConfig := {}) : LazyDiscrTree α :=
private def toLazy (d : PreDiscrTree α) : LazyDiscrTree α :=
let { roots, tries } := d
-- Adjust trie indices so the first value is reserved (so 0 is never a valid trie index)
let roots := roots.fold (init := roots) (fun m k n => m.insert k (n+1))
{ config, roots, tries := #[default] ++ tries.map (.node {} 0 {}) }
{ roots, tries := #[default] ++ tries.map (.node {} 0 {}) }
/-- Merge two discrimination trees. -/
protected def append (x y : PreDiscrTree α) : PreDiscrTree α :=
@@ -756,12 +753,12 @@ namespace InitEntry
/--
Constructs an initial entry from an expression and value.
-/
def fromExpr (expr : Expr) (value : α) (config : WhnfCoreConfig := {}) : MetaM (InitEntry α) := do
def fromExpr (expr : Expr) (value : α) : MetaM (InitEntry α) := do
let lctx getLCtx
let linst getLocalInstances
let lctx := (lctx, linst)
let (key, todo) LazyDiscrTree.rootKey config expr
pure <| { key, entry := (todo, lctx, value) }
let (key, todo) LazyDiscrTree.rootKey expr
return { key, entry := (todo, lctx, value) }
/--
Creates an entry for a subterm of an initial entry.
@@ -769,11 +766,11 @@ Creates an entry for a subterm of an initial entry.
This is slightly more efficient than using `fromExpr` on subterms since it avoids a redundant call
to `whnf`.
-/
def mkSubEntry (e : InitEntry α) (idx : Nat) (value : α) (config : WhnfCoreConfig := {}) :
def mkSubEntry (e : InitEntry α) (idx : Nat) (value : α) :
MetaM (InitEntry α) := do
let (todo, lctx, _) := e.entry
let (key, todo) LazyDiscrTree.rootKey config todo[idx]!
pure <| { key, entry := (todo, lctx, value) }
let (key, todo) LazyDiscrTree.rootKey todo[idx]!
return { key, entry := (todo, lctx, value) }
end InitEntry

View File

@@ -149,8 +149,8 @@ mutual
if r != LBool.undef then
return r == LBool.true
else if !( hasAssignableLevelMVar lhs <||> hasAssignableLevelMVar rhs) then
let ctx read
if ctx.config.isDefEqStuckEx && (lhs.isMVar || rhs.isMVar) then do
let cfg getConfig
if cfg.isDefEqStuckEx && (lhs.isMVar || rhs.isMVar) then do
trace[Meta.isLevelDefEq.stuck] "{lhs} =?= {rhs}"
Meta.throwIsDefEqStuck
else

View File

@@ -162,7 +162,7 @@ def refineThrough? (matcherApp : MatcherApp) (e : Expr) :
private def withUserNamesImpl {α} (fvars : Array Expr) (names : Array Name) (k : MetaM α) : MetaM α := do
let lctx := (Array.zip fvars names).foldl (init := (getLCtx)) fun lctx (fvar, name) =>
lctx.setUserName fvar.fvarId! name
withTheReader Meta.Context (fun ctx => { ctx with lctx }) k
withLCtx' lctx k
/--
Sets the user name of the FVars in the local context according to the given array of names.

View File

@@ -207,7 +207,7 @@ def getInstances (type : Expr) : MetaM (Array Instance) := do
| none => throwError "type class instance expected{indentExpr type}"
| some className =>
let globalInstances getGlobalInstancesIndex
let result globalInstances.getUnify type tcDtConfig
let result globalInstances.getUnify type
-- Using insertion sort because it is stable and the array `result` should be mostly sorted.
-- Most instances have default priority.
let result := result.insertionSort fun e₁ e₂ => e₁.priority < e₂.priority
@@ -782,7 +782,7 @@ def synthInstance? (type : Expr) (maxResultSize? : Option Nat := none) : MetaM (
(return m!"{exceptOptionEmoji ·} {← instantiateMVars type}") do
withConfig (fun config => { config with isDefEqStuckEx := true, transparency := TransparencyMode.instances,
foApprox := true, ctxApprox := true, constApprox := false, univApprox := false }) do
withReader (fun ctx => { ctx with inTypeClassResolution := true }) do
withInTypeClassResolution do
let localInsts getLocalInstances
let type instantiateMVars type
let type preprocess type
@@ -839,7 +839,7 @@ private def synthPendingImp (mvarId : MVarId) : MetaM Bool := withIncRecDepth <|
recordSynthPendingFailure mvarDecl.type
return false
else
withReader (fun ctx => { ctx with synthPendingDepth := ctx.synthPendingDepth + 1 }) do
withIncSynthPending do
trace[Meta.synthPending] "synthPending {mkMVar mvarId}"
let val? catchInternalId isDefEqStuckExceptionId (synthInstance? mvarDecl.type (maxResultSize? := none)) (fun _ => pure none)
match val? with

View File

@@ -188,12 +188,10 @@ def post (e : Expr) : SimpM Simp.Step := do
| e, _ => return Simp.Step.done { expr := e }
def rewriteUnnormalized (mvarId : MVarId) : MetaM MVarId := do
let simpCtx :=
{
simpTheorems := {}
congrTheorems := ( getSimpCongrTheorems)
config := Simp.neutralConfig
}
let simpCtx Simp.mkContext
(simpTheorems := {})
(congrTheorems := ( getSimpCongrTheorems))
(config := Simp.neutralConfig)
let tgt instantiateMVars ( mvarId.getType)
let (res, _) Simp.main tgt simpCtx (methods := { post })
applySimpResultToTarget mvarId tgt res
@@ -207,12 +205,10 @@ def rewriteUnnormalizedRefl (goal : MVarId) : MetaM Unit := do
def acNfHypMeta (goal : MVarId) (fvarId : FVarId) : MetaM (Option MVarId) := do
goal.withContext do
let simpCtx :=
{
simpTheorems := {}
congrTheorems := ( getSimpCongrTheorems)
config := Simp.neutralConfig
}
let simpCtx Simp.mkContext
(simpTheorems := {})
(congrTheorems := ( getSimpCongrTheorems))
(config := Simp.neutralConfig)
let tgt instantiateMVars ( fvarId.getType)
let (res, _) Simp.main tgt simpCtx (methods := { post })
return ( applySimpResultToLocalDecl goal fvarId res false).map (·.snd)

View File

@@ -38,7 +38,10 @@ where
let sizeOfEq mkLT sizeOf_lhs sizeOf_rhs
let hlt mkFreshExprSyntheticOpaqueMVar sizeOfEq
-- TODO: we only need the `sizeOf` simp theorems
match ( simpTarget hlt.mvarId! { config.arith := true, simpTheorems := #[ ( getSimpTheorems) ] } {}).1 with
let ctx Simp.mkContext
(config := { arith := true })
(simpTheorems := #[ ( getSimpTheorems) ])
match ( simpTarget hlt.mvarId! ctx {}).1 with
| some _ => return false
| none =>
let heq mkCongrArg sizeOf_lhs.appFn! ( mkEqSymm h)

View File

@@ -254,10 +254,6 @@ Apply `And.intro` as much as possible to goal `mvarId`.
abbrev splitAnd (mvarId : MVarId) : MetaM (List MVarId) :=
splitAndCore mvarId
@[deprecated splitAnd (since := "2024-03-17")]
def _root_.Lean.Meta.splitAnd (mvarId : MVarId) : MetaM (List MVarId) :=
mvarId.splitAnd
def exfalso (mvarId : MVarId) : MetaM MVarId :=
mvarId.withContext do
mvarId.checkNotAssigned `exfalso

Some files were not shown because too many files have changed in this diff Show More