/-
# Tactics

Tactics are Lean programs that manipulate a custom state. All tactics are, in
the end, of type `TacticM Unit`. This has the type:

```lean
-- from Lean/Elab/Tactic/Basic.lean
TacticM = ReaderT Context $ StateRefT State TermElabM
```

But before demonstrating how to use `TacticM`, we shall explore macro-based
tactics.

## Tactics by Macro Expansion

Just like many other parts of the Lean 4 infrastructure, tactics too can be
declared by lightweight macro expansion.

For example, we build an example of a `custom_sorry_macro` that elaborates into
a `sorry`. We write this as a macro expansion, which expands the piece of syntax
`custom_sorry_macro` into the piece of syntax `sorry`:
-/

import Lean.Elab.Tactic

macro "custom_sorry_macro" : tactic => `(tactic| sorry)

example : 1 = 42 := by
  custom_sorry_macro

/-
### Implementing `trivial`: Extensible Tactics by Macro Expansion

As more complex examples, we can write a tactic such as `custom_tactic`, which
is initially completely unimplemented, and can be extended with more tactics.
We start by simply declaring the tactic with no implementation:
-/

syntax "custom_tactic" : tactic

example : 42 = 42 := by
  custom_tactic
-- tactic 'tacticCustom_tactic' has not been implemented
  sorry

/-
We will now add the `rfl` tactic into `custom_tactic`, which will allow us to
prove the previous theorem
-/

macro_rules
| `(tactic| custom_tactic) => `(tactic| rfl)

example : 42 = 42 := by
   custom_tactic
-- Goals accomplished 🎉

/-
We can now try a harder problem, that cannot be immediately dispatched by `rfl`:
-/

example : 43 = 43 ∧ 42 = 42:= by
  custom_tactic
-- tactic 'rfl' failed, equality expected
--   43 = 43 ∧ 42 = 42
-- ⊢ 43 = 43 ∧ 42 = 42

/-
We extend the `custom_tactic` tactic with a tactic that tries to break `And`
down with `apply And.intro`, and then (recursively (!)) applies `custom_tactic`
to the two cases with `(<;> trivial)` to solve the generated subcases `43 = 43`,
`42 = 42`.
-/

macro_rules
| `(tactic| custom_tactic) => `(tactic| apply And.intro <;> custom_tactic)

/-
The above declaration uses `<;>` which is a *tactic combinator*. Here, `a <;> b`
means "run tactic `a`, and apply "b" to each goal produced by `a`". Thus,
`And.intro <;> custom_tactic` means "run `And.intro`, and then run
`custom_tactic` on each goal". We test it out on our previous theorem and see
that we dispatch the theorem.
-/

example : 43 = 43 ∧ 42 = 42 := by
  custom_tactic
-- Goals accomplished 🎉

/-
In summary, we declared an extensible tactic called `custom_tactic`. It
initially had no elaboration at all. We added the `rfl` as an elaboration of
`custom_tactic`, which allowed it to solve the goal `42 = 42`. We then tried a
harder theorem, `43 = 43 ∧ 42 = 42` which `custom_tactic` was unable to solve.
We were then able to enrich `custom_tactic` to split "and" with `And.intro`, and
also *recursively* call `custom_tactic` in the two subcases.

### Implementing `<;>`: Tactic Combinators by Macro Expansion

Recall that in the previous section, we said that `a <;> b` meant "run `a`, and
then run `b` for all goals". In fact, `<;>` itself is a tactic macro. In this
section, we will implement the syntax `a and_then b` which will stand for
"run `a`, and then run `b` for all goals".
-/

-- 1. We declare the syntax `and_then`
syntax tactic " and_then " tactic : tactic

-- 2. We write the expander that expands the tactic
--    into running `a`, and then running `b` on all goals produced by `a`.
macro_rules
| `(tactic| $a:tactic and_then $b:tactic) =>
    `(tactic| $a:tactic; all_goals $b:tactic)

-- 3. We test this tactic.
theorem test_and_then: 1 = 1 ∧ 2 = 2 := by
  apply And.intro and_then rfl

#print test_and_then
-- theorem test_and_then : 1 = 1 ∧ 2 = 2 :=
-- { left := Eq.refl 1, right := Eq.refl 2 }

/-
## Exploring `TacticM`

### The simplest tactic: `sorry`

In this section, we wish to write a tactic that fills the proof with sorry:

```lean
example : 1 = 2 := by
  custom_sorry
```

We begin by declaring such a tactic:
-/

elab "custom_sorry_0" : tactic => do
  return

example : 1 = 2 := by
  custom_sorry_0
-- unsolved goals: ⊢ 1 = 2

/-
This defines a syntax extension to Lean, where we are naming the piece of syntax
`custom_sorry_0` as living in `tactic` syntax category. This informs the
elaborator that, in the context of elaborating `tactic`s, the piece of syntax
`custom_sorry_0` must be elaborated as what we write to the right-hand-side of
the `=>` (the actual implementation of the tactic).

Next, we write a term in `TacticM Unit` to fill in the goal with `sorryAx α`,
which can synthesize an artificial term of type `α`. To do this, we first access
the goal with `Lean.Elab.Tactic.getMainGoal : Tactic MVarId`, which returns the
main goal, represented as a metavariable. Recall that under
types-as-propositions, the type of our goal must be the proposition that `1 = 2`.
We check this by printing the type of `goal`.

But first we need to start our tactic with `Lean.Elab.Tactic.withMainContext`,
which computes in `TacticM` with an updated context.
-/

elab "custom_sorry_1" : tactic =>
  Lean.Elab.Tactic.withMainContext do
    let goal ← Lean.Elab.Tactic.getMainGoal
    let goalDecl ← goal.getDecl
    let goalType := goalDecl.type
    dbg_trace f!"goal type: {goalType}"

example : 1 = 2 := by
  custom_sorry_1
-- goal type: Eq.{1} Nat (OfNat.ofNat.{0} Nat 1 (instOfNatNat 1)) (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2))
-- unsolved goals: ⊢ 1 = 2

/-
To `sorry` the goal, we can use the helper `Lean.Elab.admitGoal`:
-/

elab "custom_sorry_2" : tactic =>
  Lean.Elab.Tactic.withMainContext do
    let goal ← Lean.Elab.Tactic.getMainGoal
    Lean.Elab.admitGoal goal

theorem test_custom_sorry : 1 = 2 := by
  custom_sorry_2

#print test_custom_sorry
-- theorem test_custom_sorry : 1 = 2 :=
-- sorryAx (1 = 2) true

/-
And we no longer have the error `unsolved goals: ⊢ 1 = 2`.

### The `custom_assump` tactic: Accessing Hypotheses

In this section, we will learn how to access the hypotheses to prove a goal. In
particular, we shall attempt to implement a tactic `custom_assump`, which looks
for an exact match of the goal among the hypotheses, and solves the theorem if
possible.

In the example below, we expect `custom_assump` to use `(H2 : 2 = 2)` to solve
the goal `(2 = 2)`:

```lean
theorem assump_correct (H1 : 1 = 1) (H2 : 2 = 2) : 2 = 2 := by
  custom_assump

#print assump_correct
-- theorem assump_correct : 1 = 1 → 2 = 2 → 2 = 2 :=
-- fun H1 H2 => H2
```

When we do not have a matching hypothesis to the goal, we expect the tactic
`custom_assump` to throw an error, telling us that we cannot find a hypothesis
of the type we are looking for:

```lean
theorem assump_wrong (H1 : 1 = 1) : 2 = 2 := by
  custom_assump

#print assump_wrong
-- tactic 'custom_assump' failed, unable to find matching hypothesis of type (2 = 2)
-- H1 : 1 = 1
-- ⊢ 2 = 2
```

We begin by accessing the goal and the type of the goal so we know what we
are trying to prove. The `goal` variable will soon be used to help us create
error messages.
-/

elab "custom_assump_0" : tactic =>
  Lean.Elab.Tactic.withMainContext do
    let goalType ← Lean.Elab.Tactic.getMainTarget
    dbg_trace f!"goal type: {goalType}"

example (H1 : 1 = 1) (H2 : 2 = 2): 2 = 2 := by
  custom_assump_0
-- goal type: Eq.{1} Nat (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2)) (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2))
-- unsolved goals
-- H1 : 1 = 1
-- H2 : 2 = 2
-- ⊢ 2 = 2

example (H1 : 1 = 1): 2 = 2 := by
  custom_assump_0
-- goal type: Eq.{1} Nat (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2)) (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2))
-- unsolved goals
-- H1 : 1 = 1
-- ⊢ 2 = 2

/-
Next, we access the list of hypotheses, which are stored in a data structure
called `LocalContext`. This is accessed via `Lean.MonadLCtx.getLCtx`. The
`LocalContext` contains `LocalDeclaration`s, from which we can extract
information such as the name that is given to declarations (`.userName`), the
expression of the declaration (`.toExpr`). Let's write a tactic called
`list_local_decls` that prints the local declarations:
-/

elab "list_local_decls_1" : tactic =>
  Lean.Elab.Tactic.withMainContext do
    let ctx ← Lean.MonadLCtx.getLCtx -- get the local context.
    ctx.forM fun decl: Lean.LocalDecl => do
      let declExpr := decl.toExpr -- Find the expression of the declaration.
      let declName := decl.userName -- Find the name of the declaration.
      dbg_trace f!"+ local decl: name: {declName} | expr: {declExpr}"

example (H1 : 1 = 1) (H2 : 2 = 2): 1 = 1 := by
  list_local_decls_1
-- + local decl: name: test_list_local_decls_1 | expr: _uniq.3339
-- + local decl: name: H1 | expr: _uniq.3340
-- + local decl: name: H2 | expr: _uniq.3341
  rfl

/-
Recall that we are looking for a local declaration that has the same type as the
hypothesis. We get the type of `LocalDecl` by calling
`Lean.Meta.inferType` on the local declaration's expression.
-/

elab "list_local_decls_2" : tactic =>
  Lean.Elab.Tactic.withMainContext do
    let ctx ← Lean.MonadLCtx.getLCtx -- get the local context.
    ctx.forM fun decl: Lean.LocalDecl => do
      let declExpr := decl.toExpr -- Find the expression of the declaration.
      let declName := decl.userName -- Find the name of the declaration.
      let declType ← Lean.Meta.inferType declExpr -- **NEW:** Find the type.
      dbg_trace f!"+ local decl: name: {declName} | expr: {declExpr} | type: {declType}"

example (H1 : 1 = 1) (H2 : 2 = 2): 1 = 1 := by
  list_local_decls_2
  -- + local decl: name: test_list_local_decls_2 | expr: _uniq.4263 | type: (Eq.{1} Nat ...)
  -- + local decl: name: H1 | expr: _uniq.4264 | type: Eq.{1} Nat ...)
  -- + local decl: name: H2 | expr: _uniq.4265 | type: Eq.{1} Nat ...)
  rfl

/-
We check if the type of the `LocalDecl` is equal to the goal type with
`Lean.Meta.isExprDefEq`. See that we check if the types are equal at `eq?`, and
we print that `H1` has the same type as the goal
(`local decl[EQUAL? true]: name: H1`), and we print that `H2` does not have the
same type (`local decl[EQUAL? false]: name: H2 `):
-/

elab "list_local_decls_3" : tactic =>
  Lean.Elab.Tactic.withMainContext do
    let goalType ← Lean.Elab.Tactic.getMainTarget
    let ctx ← Lean.MonadLCtx.getLCtx -- get the local context.
    ctx.forM fun decl: Lean.LocalDecl => do
      let declExpr := decl.toExpr -- Find the expression of the declaration.
      let declName := decl.userName -- Find the name of the declaration.
      let declType ← Lean.Meta.inferType declExpr -- Find the type.
      let eq? ← Lean.Meta.isExprDefEq declType goalType -- **NEW** Check if type equals goal type.
      dbg_trace f!"+ local decl[EQUAL? {eq?}]: name: {declName}"

example (H1 : 1 = 1) (H2 : 2 = 2): 1 = 1 := by
  list_local_decls_3
-- + local decl[EQUAL? false]: name: test_list_local_decls_3
-- + local decl[EQUAL? true]: name: H1
-- + local decl[EQUAL? false]: name: H2
  rfl

/-
Finally, we put all of these parts together to write a tactic that loops over
all declarations and finds one with the correct type. We loop over declarations
with `lctx.findDeclM?`. We infer the type of declarations with
`Lean.Meta.inferType`. We check that the declaration has the same type as the
goal with `Lean.Meta.isExprDefEq`:
-/

elab "custom_assump_1" : tactic =>
  Lean.Elab.Tactic.withMainContext do
    let goalType ← Lean.Elab.Tactic.getMainTarget
    let lctx ← Lean.MonadLCtx.getLCtx
    -- Iterate over the local declarations...
    let option_matching_expr ← lctx.findDeclM? fun ldecl: Lean.LocalDecl => do
      let declExpr := ldecl.toExpr -- Find the expression of the declaration.
      let declType ← Lean.Meta.inferType declExpr -- Find the type.
      if (← Lean.Meta.isExprDefEq declType goalType) -- Check if type equals goal type.
      then return some declExpr -- If equal, success!
      else return none          -- Not found.
    dbg_trace f!"matching_expr: {option_matching_expr}"

example (H1 : 1 = 1) (H2 : 2 = 2) : 2 = 2 := by
  custom_assump_1
-- matching_expr: some _uniq.6241
  rfl

example (H1 : 1 = 1) : 2 = 2 := by
  custom_assump_1
-- matching_expr: none
  rfl

/-
Now that we are able to find the matching expression, we need to close the
theorem by using the match. We do this with `Lean.Elab.Tactic.closeMainGoal`.
When we do not have a matching expression, we throw an error with
`Lean.Meta.throwTacticEx`, which allows us to report an error corresponding to a
given goal. When throwing this error, we format the error using `m!"..."` which
builds a `MessageData`. This provides nicer error messages than using `f!"..."`
which builds a `Format`. This is because `MessageData` also runs *delaboration*,
which allows it to convert raw Lean terms like
`(Eq.{1} Nat (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2)) (OfNat.ofNat.{0} Nat 2 (instOfNatNat 2)))`
into readable strings like`(2 = 2)`. The full code listing given below shows how
to do this:
-/

elab "custom_assump_2" : tactic =>
  Lean.Elab.Tactic.withMainContext do
    let goal ← Lean.Elab.Tactic.getMainGoal
    let goalType ← Lean.Elab.Tactic.getMainTarget
    let ctx ← Lean.MonadLCtx.getLCtx
    let option_matching_expr ← ctx.findDeclM? fun decl: Lean.LocalDecl => do
      let declExpr := decl.toExpr
      let declType ← Lean.Meta.inferType declExpr
      if ← Lean.Meta.isExprDefEq declType goalType
        then return Option.some declExpr
        else return Option.none
    match option_matching_expr with
    | some e => Lean.Elab.Tactic.closeMainGoal e
    | none =>
      Lean.Meta.throwTacticEx `custom_assump_2 goal
        (m!"unable to find matching hypothesis of type ({goalType})")

example (H1 : 1 = 1) (H2 : 2 = 2) : 2 = 2 := by
  custom_assump_2

example (H1 : 1 = 1): 2 = 2 := by
  custom_assump_2
-- tactic 'custom_assump_2' failed, unable to find matching hypothesis of type (2 = 2)
-- H1 : 1 = 1
-- ⊢ 2 = 2

/-
### Tweaking the context

Until now, we've only performed read-like operations with the context. But what
if we want to change it? In this section we will see how to change the order of
goals and how to add content to it (new hypotheses).

Then, after elaborating our terms, we will need to use the helper function
`Lean.Elab.Tactic.liftMetaTactic`, which allows us to run computations in
`MetaM` while also giving us the goal `MVarId` for us to play with. In the end
of our computation, `liftMetaTactic` expects us to return a `List MVarId` as the
resulting list of goals.

The only substantial difference between `custom_let` and `custom_have` is that
the former uses `Lean.MVarId.define` and the later uses `Lean.MVarId.assert`:
-/

open Lean.Elab.Tactic in
elab "custom_let " n:ident " : " t:term " := " v:term : tactic =>
  withMainContext do
    let t ← elabTerm t none
    let v ← elabTermEnsuringType v t
    liftMetaTactic fun mvarId => do
      let mvarIdNew ← mvarId.define n.getId t v
      let (_, mvarIdNew) ← mvarIdNew.intro1P
      return [mvarIdNew]

open Lean.Elab.Tactic in
elab "custom_have " n:ident " : " t:term " := " v:term : tactic =>
  withMainContext do
    let t ← elabTerm t none
    let v ← elabTermEnsuringType v t
    liftMetaTactic fun mvarId => do
      let mvarIdNew ← mvarId.assert n.getId t v
      let (_, mvarIdNew) ← mvarIdNew.intro1P
      return [mvarIdNew]

theorem test_faq_have : True := by
  custom_let n : Nat := 5
  custom_have h : n = n := rfl
-- n : Nat := 5
-- h : n = n
-- ⊢ True
  trivial

/-
### "Getting" and "Setting" the list of goals

To illustrate these, let's build a tactic that can reverse the list of goals.
We can use `Lean.Elab.Tactic.getGoals` and `Lean.Elab.Tactic.setGoals`:
-/

elab "reverse_goals" : tactic =>
  Lean.Elab.Tactic.withMainContext do
    let goals : List Lean.MVarId ← Lean.Elab.Tactic.getGoals
    Lean.Elab.Tactic.setGoals goals.reverse

theorem test_reverse_goals : (1 = 2 ∧ 3 = 4) ∧ 5 = 6 := by
  constructor
  constructor
-- case left.left
-- ⊢ 1 = 2
-- case left.right
-- ⊢ 3 = 4
-- case right
-- ⊢ 5 = 6
  reverse_goals
-- case right
-- ⊢ 5 = 6
-- case left.right
-- ⊢ 3 = 4
-- case left.left
-- ⊢ 1 = 2

/-
## FAQ

In this section, we collect common patterns that are used during writing tactics,
to make it easy to find common patterns.

**Q: How do I use goals?**

A: Goals are represented as metavariables. The module `Lean.Elab.Tactic.Basic`
has many functions to add new goals, switch goals, etc.

**Q: How do I get the main goal?**

A: Use `Lean.Elab.Tactic.getMainGoal`.
-/

elab "faq_main_goal" : tactic =>
  Lean.Elab.Tactic.withMainContext do
    let goal ← Lean.Elab.Tactic.getMainGoal
    dbg_trace f!"goal: {goal.name}"

example : 1 = 1 := by
  faq_main_goal
-- goal: _uniq.9298
  rfl

/-
**Q: How do I get the list of goals?**

A: Use `getGoals`.
-/

elab "faq_get_goals" : tactic =>
  Lean.Elab.Tactic.withMainContext do
    let goals ← Lean.Elab.Tactic.getGoals
    goals.forM $ fun goal => do
      let goalType ← goal.getType
      dbg_trace f!"goal: {goal.name} | type: {goalType}"

example (b : Bool) : b = true := by
  cases b
  faq_get_goals
-- goal: _uniq.10067 | type: Eq.{1} Bool Bool.false Bool.true
-- goal: _uniq.10078 | type: Eq.{1} Bool Bool.true Bool.true
  sorry
  rfl

/-
**Q: How do I get the current hypotheses for a goal?**

A: Use `Lean.MonadLCtx.getLCtx` which provides the local context, and then
iterate on the `LocalDeclaration`s of the `LocalContext` with accessors such as
`foldlM` and `forM`.
-/

elab "faq_get_hypotheses" : tactic =>
  Lean.Elab.Tactic.withMainContext do
  let ctx ← Lean.MonadLCtx.getLCtx -- get the local context.
  ctx.forM (fun (decl : Lean.LocalDecl) => do
    let declExpr := decl.toExpr -- Find the expression of the declaration.
    let declType := decl.type -- Find the type of the declaration.
    let declName := decl.userName -- Find the name of the declaration.
    dbg_trace f!" local decl: name: {declName} | expr: {declExpr} | type: {declType}"
  )

example (H1 : 1 = 1) (H2 : 2 = 2): 3 = 3 := by
  faq_get_hypotheses
  -- local decl: name: _example | expr: _uniq.10814 | type: ...
  -- local decl: name: H1 | expr: _uniq.10815 | type: ...
  -- local decl: name: H2 | expr: _uniq.10816 | type: ...
  rfl

/-
**Q: How do I evaluate a tactic?**

A: Use `Lean.Elab.Tactic.evalTactic: Syntax → TacticM Unit` which evaluates a
given tactic syntax. One can create tactic syntax using the macro
`` `(tactic| ⋯)``.

For example, one could call `try rfl` with the piece of code:

```lean
Lean.Elab.Tactic.evalTactic (← `(tactic| try rfl))
```

**Q: How do I check if two expressions are equal?**

A: Use `Lean.Meta.isExprDefEq <expr-1> <expr-2>`.
-/

#check Lean.Meta.isExprDefEq
-- Lean.Meta.isExprDefEq : Lean.Expr → Lean.Expr → Lean.MetaM Bool

/-
**Q: How do I throw an error from a tactic?**

A: Use `throwTacticEx <tactic-name> <goal-mvar> <error>`.
-/

elab "faq_throw_error" : tactic =>
  Lean.Elab.Tactic.withMainContext do
    let goal ← Lean.Elab.Tactic.getMainGoal
    Lean.Meta.throwTacticEx `faq_throw_error goal "throwing an error at the current goal"

example (b : Bool): b = true := by
  cases b;
  faq_throw_error
  -- case true
  -- ⊢ true = true
  -- tactic 'faq_throw_error' failed, throwing an error at the current goal
  -- case false
  -- ⊢ false = true

/-
**Q: What is the difference between `Lean.Elab.Tactic.*` and `Lean.Meta.Tactic.*`?**

A: `Lean.Meta.Tactic.*` contains low level code that uses the `Meta` monad to
implement basic features such as rewriting. `Lean.Elab.Tactic.*` contains
high-level code that connects the low level development in `Lean.Meta` to the
tactic infrastructure and the parsing front-end.
-/


import Lean.Elab.Tactic.ElabTerm
import Mathlib.Tactic.RunCmd

open Lean Elab Tactic

example : True := by
  run_tac
    evalApplyLikeTactic MVarId.apply (← `(True.intro))

example : True := by_elab
  Term.elabTerm (← `(True.intro)) none


/-
Copyright (c) 2019 Zhouhang Zhou. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Zhouhang Zhou, Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.measure_theory.l1_space
import Mathlib.PostPort

universes u_1 u_2 u_3 u_4

namespace Mathlib

/-!
# Density of simple functions

Show that each Borel measurable function can be approximated,
both pointwise and in `L¹` norm, by a sequence of simple functions.

## Main definitions

* `measure_theory.simple_func.nearest_pt (e : ℕ → α) (N : ℕ) : α →ₛ ℕ`: the `simple_func` sending
  each `x : α` to the point `e k` which is the nearest to `x` among `e 0`, ..., `e N`.
* `measure_theory.simple_func.approx_on (f : β → α) (hf : measurable f) (s : set α) (y₀ : α)
  (h₀ : y₀ ∈ s) [separable_space s] (n : ℕ) : β →ₛ α` : a simple function that takes values in `s`
  and approximates `f`. If `f x ∈ s`, then `measure_theory.simple_func.approx_on f hf s y₀ h₀ n x`
  tends to `f x` as `n` tends to `∞`. If `α` is a `normed_group`, `f x - y₀`
  is `measure_theory.integrable`, and `f x ∈ s` for a.e. `x`, then
  `simple_func.approx_on f hf s y₀ h₀ n` tends to `f` in `L₁`. The main use case is `s = univ`,
  `y₀ = 0`.

## Notations

* `α →ₛ β` (local notation): the type of simple functions `α → β`.
-/

namespace measure_theory

namespace simple_func

/-- `nearest_pt_ind e N x` is the index `k` such that `e k` is the nearest point to `x` among the
points `e 0`, ..., `e N`. If more than one point are at the same distance from `x`, then
`nearest_pt_ind e N x` returns the least of their indexes. -/
def nearest_pt_ind {α : Type u_1} [measurable_space α] [emetric_space α] [opens_measurable_space α]
    (e : ℕ → α) : ℕ → simple_func α ℕ :=
  sorry

/-- `nearest_pt e N x` is the nearest point to `x` among the points `e 0`, ..., `e N`. If more than
one point are at the same distance from `x`, then `nearest_pt e N x` returns the point with the
least possible index. -/
def nearest_pt {α : Type u_1} [measurable_space α] [emetric_space α] [opens_measurable_space α]
    (e : ℕ → α) (N : ℕ) : simple_func α α :=
  map e (nearest_pt_ind e N)

@[simp] theorem nearest_pt_ind_zero {α : Type u_1} [measurable_space α] [emetric_space α]
    [opens_measurable_space α] (e : ℕ → α) : nearest_pt_ind e 0 = const α 0 :=
  rfl

@[simp] theorem nearest_pt_zero {α : Type u_1} [measurable_space α] [emetric_space α]
    [opens_measurable_space α] (e : ℕ → α) : nearest_pt e 0 = const α (e 0) :=
  rfl

theorem nearest_pt_ind_succ {α : Type u_1} [measurable_space α] [emetric_space α]
    [opens_measurable_space α] (e : ℕ → α) (N : ℕ) (x : α) :
    coe_fn (nearest_pt_ind e (N + 1)) x =
        ite (∀ (k : ℕ), k ≤ N → edist (e (N + 1)) x < edist (e k) x) (N + 1)
          (coe_fn (nearest_pt_ind e N) x) :=
  sorry

theorem nearest_pt_ind_le {α : Type u_1} [measurable_space α] [emetric_space α]
    [opens_measurable_space α] (e : ℕ → α) (N : ℕ) (x : α) : coe_fn (nearest_pt_ind e N) x ≤ N :=
  sorry

theorem edist_nearest_pt_le {α : Type u_1} [measurable_space α] [emetric_space α]
    [opens_measurable_space α] (e : ℕ → α) (x : α) {k : ℕ} {N : ℕ} (hk : k ≤ N) :
    edist (coe_fn (nearest_pt e N) x) x ≤ edist (e k) x :=
  sorry

theorem tendsto_nearest_pt {α : Type u_1} [measurable_space α] [emetric_space α]
    [opens_measurable_space α] {e : ℕ → α} {x : α} (hx : x ∈ closure (set.range e)) :
    filter.tendsto (fun (N : ℕ) => coe_fn (nearest_pt e N) x) filter.at_top (nhds x) :=
  sorry

/-- Approximate a measurable function by a sequence of simple functions `F n` such that
`F n x ∈ s`. -/
def approx_on {α : Type u_1} {β : Type u_2} [measurable_space α] [emetric_space α]
    [opens_measurable_space α] [measurable_space β] (f : β → α) (hf : measurable f) (s : set α)
    (y₀ : α) (h₀ : y₀ ∈ s) [topological_space.separable_space ↥s] (n : ℕ) : simple_func β α :=
  comp (nearest_pt (fun (k : ℕ) => nat.cases_on k y₀ (coe ∘ topological_space.dense_seq ↥s)) n) f hf

@[simp] theorem approx_on_zero {α : Type u_1} {β : Type u_2} [measurable_space α] [emetric_space α]
    [opens_measurable_space α] [measurable_space β] {f : β → α} (hf : measurable f) {s : set α}
    {y₀ : α} (h₀ : y₀ ∈ s) [topological_space.separable_space ↥s] (x : β) :
    coe_fn (approx_on f hf s y₀ h₀ 0) x = y₀ :=
  rfl

theorem approx_on_mem {α : Type u_1} {β : Type u_2} [measurable_space α] [emetric_space α]
    [opens_measurable_space α] [measurable_space β] {f : β → α} (hf : measurable f) {s : set α}
    {y₀ : α} (h₀ : y₀ ∈ s) [topological_space.separable_space ↥s] (n : ℕ) (x : β) :
    coe_fn (approx_on f hf s y₀ h₀ n) x ∈ s :=
  (fun (n_1 : ℕ) =>
      nat.cases_on n_1 h₀ fun (n : ℕ) => subtype.mem (topological_space.dense_seq (↥s) n))
    (coe_fn
      (nearest_pt_ind (fun (k : ℕ) => nat.cases_on k y₀ (coe ∘ topological_space.dense_seq ↥s)) n)
      (f x))

@[simp] theorem approx_on_comp {α : Type u_1} {β : Type u_2} [measurable_space α] [emetric_space α]
    [opens_measurable_space α] [measurable_space β] {γ : Type u_3} [measurable_space γ] {f : β → α}
    (hf : measurable f) {g : γ → β} (hg : measurable g) {s : set α} {y₀ : α} (h₀ : y₀ ∈ s)
    [topological_space.separable_space ↥s] (n : ℕ) :
    approx_on (f ∘ g) (measurable.comp hf hg) s y₀ h₀ n = comp (approx_on f hf s y₀ h₀ n) g hg :=
  rfl

theorem tendsto_approx_on {α : Type u_1} {β : Type u_2} [measurable_space α] [emetric_space α]
    [opens_measurable_space α] [measurable_space β] {f : β → α} (hf : measurable f) {s : set α}
    {y₀ : α} (h₀ : y₀ ∈ s) [topological_space.separable_space ↥s] {x : β} (hx : f x ∈ closure s) :
    filter.tendsto (fun (n : ℕ) => coe_fn (approx_on f hf s y₀ h₀ n) x) filter.at_top
        (nhds (f x)) :=
  sorry

theorem edist_approx_on_le {α : Type u_1} {β : Type u_2} [measurable_space α] [emetric_space α]
    [opens_measurable_space α] [measurable_space β] {f : β → α} (hf : measurable f) {s : set α}
    {y₀ : α} (h₀ : y₀ ∈ s) [topological_space.separable_space ↥s] (x : β) (n : ℕ) :
    edist (coe_fn (approx_on f hf s y₀ h₀ n) x) (f x) ≤ edist y₀ (f x) :=
  id
    (edist_nearest_pt_le (Nat.rec y₀ fun (n : ℕ) (ih : α) => ↑(topological_space.dense_seq (↥s) n))
      (f x) (zero_le n))

theorem edist_approx_on_y0_le {α : Type u_1} {β : Type u_2} [measurable_space α] [emetric_space α]
    [opens_measurable_space α] [measurable_space β] {f : β → α} (hf : measurable f) {s : set α}
    {y₀ : α} (h₀ : y₀ ∈ s) [topological_space.separable_space ↥s] (x : β) (n : ℕ) :
    edist y₀ (coe_fn (approx_on f hf s y₀ h₀ n) x) ≤ edist y₀ (f x) + edist y₀ (f x) :=
  le_trans (edist_triangle_right y₀ (coe_fn (approx_on f hf s y₀ h₀ n) x) (f x))
    (add_le_add_left (edist_approx_on_le hf h₀ x n) (edist y₀ (f x)))

theorem norm_approx_on_zero_le {β : Type u_2} {E : Type u_4} [measurable_space β]
    [measurable_space E] [normed_group E] [opens_measurable_space E] {f : β → E} (hf : measurable f)
    {s : set E} (h₀ : 0 ∈ s) [topological_space.separable_space ↥s] (x : β) (n : ℕ) :
    norm (coe_fn (approx_on f hf s 0 h₀ n) x) ≤ norm (f x) + norm (f x) :=
  sorry

theorem tendsto_approx_on_l1_edist {β : Type u_2} {E : Type u_4} [measurable_space β]
    [measurable_space E] [normed_group E] [opens_measurable_space E] {f : β → E} (hf : measurable f)
    {s : set E} {y₀ : E} (h₀ : y₀ ∈ s) [topological_space.separable_space ↥s] {μ : measure β}
    (hμ : filter.eventually (fun (x : β) => f x ∈ closure s) (measure.ae μ))
    (hi : has_finite_integral fun (x : β) => f x - y₀) :
    filter.tendsto
        (fun (n : ℕ) =>
          lintegral μ fun (x : β) => edist (coe_fn (approx_on f hf s y₀ h₀ n) x) (f x))
        filter.at_top (nhds 0) :=
  sorry

theorem integrable_approx_on {β : Type u_2} {E : Type u_4} [measurable_space β] [measurable_space E]
    [normed_group E] [borel_space E] {f : β → E} {μ : measure β} (fmeas : measurable f)
    (hf : integrable f) {s : set E} {y₀ : E} (h₀ : y₀ ∈ s) [topological_space.separable_space ↥s]
    (hi₀ : integrable fun (x : β) => y₀) (n : ℕ) : integrable ⇑(approx_on f fmeas s y₀ h₀ n) :=
  sorry

theorem tendsto_approx_on_univ_l1_edist {β : Type u_2} {E : Type u_4} [measurable_space β]
    [measurable_space E] [normed_group E] [opens_measurable_space E]
    [topological_space.second_countable_topology E] {f : β → E} {μ : measure β}
    (fmeas : measurable f) (hf : integrable f) :
    filter.tendsto
        (fun (n : ℕ) =>
          lintegral μ
            fun (x : β) => edist (coe_fn (approx_on f fmeas set.univ 0 trivial n) x) (f x))
        filter.at_top (nhds 0) :=
  sorry

theorem integrable_approx_on_univ {β : Type u_2} {E : Type u_4} [measurable_space β]
    [measurable_space E] [normed_group E] [borel_space E]
    [topological_space.second_countable_topology E] {f : β → E} {μ : measure β}
    (fmeas : measurable f) (hf : integrable f) (n : ℕ) :
    integrable ⇑(approx_on f fmeas set.univ 0 trivial n) :=
  integrable_approx_on fmeas hf trivial (integrable_zero β E μ) n

theorem tendsto_approx_on_univ_l1 {β : Type u_2} {E : Type u_4} [measurable_space β]
    [measurable_space E] [normed_group E] [borel_space E]
    [topological_space.second_countable_topology E] {f : β → E} {μ : measure β}
    (fmeas : measurable f) (hf : integrable f) :
    filter.tendsto
        (fun (n : ℕ) =>
          l1.of_fun (⇑(approx_on f fmeas set.univ 0 trivial n))
            (integrable_approx_on_univ fmeas hf n))
        filter.at_top (nhds (l1.of_fun f hf)) :=
  iff.mpr tendsto_iff_edist_tendsto_0 (tendsto_approx_on_univ_l1_edist fmeas hf)

end Mathlib


/-
Copyright (c) 2018 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Expr

namespace Lean
/--
Reducibility hints are used in the convertibility checker.
When trying to solve a constraint such a

           (f ...) =?= (g ...)

where f and g are definitions, the checker has to decide which one will be unfolded.
  If      f (g) is opaque,     then g (f) is unfolded if it is also not marked as opaque,
  Else if f (g) is abbrev,     then f (g) is unfolded if g (f) is also not marked as abbrev,
  Else if f and g are regular, then we unfold the one with the biggest definitional height.
  Otherwise both are unfolded.

The arguments of the `regular` Constructor are: the definitional height and the flag `selfOpt`.

The definitional height is by default computed by the kernel. It only takes into account
other regular definitions used in a definition. When creating declarations using meta-programming,
we can specify the definitional depth manually.

Remark: the hint only affects performance. None of the hints prevent the kernel from unfolding a
declaration during Type checking.

Remark: the ReducibilityHints are not related to the attributes: reducible/irrelevance/semireducible.
These attributes are used by the Elaborator. The ReducibilityHints are used by the kernel (and Elaborator).
Moreover, the ReducibilityHints cannot be changed after a declaration is added to the kernel. -/
inductive ReducibilityHints where
  | opaque  : ReducibilityHints
  | abbrev  : ReducibilityHints
  | regular : UInt32 → ReducibilityHints
  deriving Inhabited

@[export lean_mk_reducibility_hints_regular]
def mkReducibilityHintsRegularEx (h : UInt32) : ReducibilityHints :=
  ReducibilityHints.regular h

@[export lean_reducibility_hints_get_height]
def ReducibilityHints.getHeightEx (h : ReducibilityHints) : UInt32 :=
  match h with
  | ReducibilityHints.regular h => h
  | _ => 0

namespace ReducibilityHints

def lt : ReducibilityHints → ReducibilityHints → Bool
  | .abbrev,     .abbrev     => false
  | .abbrev,     _           => true
  | .regular d₁, .regular d₂ => d₁ < d₂
  | .regular _,  .opaque     => true
  | _,           _           => false

def isAbbrev : ReducibilityHints → Bool
  | .abbrev => true
  | _       => false

def isRegular : ReducibilityHints → Bool
  | regular .. => true
  | _          => false

end ReducibilityHints

/-- Base structure for `AxiomVal`, `DefinitionVal`, `TheoremVal`, `InductiveVal`, `ConstructorVal`, `RecursorVal` and `QuotVal`. -/
structure ConstantVal where
  name : Name
  levelParams : List Name
  type : Expr
  deriving Inhabited

structure AxiomVal extends ConstantVal where
  isUnsafe : Bool
  deriving Inhabited

@[export lean_mk_axiom_val]
def mkAxiomValEx (name : Name) (levelParams : List Name) (type : Expr) (isUnsafe : Bool) : AxiomVal := {
  name := name,
  levelParams := levelParams,
  type := type,
  isUnsafe := isUnsafe
}

@[export lean_axiom_val_is_unsafe] def AxiomVal.isUnsafeEx (v : AxiomVal) : Bool :=
  v.isUnsafe

inductive DefinitionSafety where
  | «unsafe» | safe | «partial»
  deriving Inhabited, BEq, Repr

structure DefinitionVal extends ConstantVal where
  value  : Expr
  hints  : ReducibilityHints
  safety : DefinitionSafety
  /--
    List of all (including this one) declarations in the same mutual block.
    Note that this information is not used by the kernel, and is only used
    to save the information provided by the user when using mutual blocks.
    Recall that the Lean kernel does not support recursive definitions and they
    are compiled using recursors and `WellFounded.fix`.
  -/
  all : List Name := [name]
  deriving Inhabited

@[export lean_mk_definition_val]
def mkDefinitionValEx (name : Name) (levelParams : List Name) (type : Expr) (value : Expr) (hints : ReducibilityHints) (safety : DefinitionSafety) (all : List Name) : DefinitionVal := {
  name, levelParams, type, hints, safety, value, all
}

@[export lean_definition_val_get_safety] def DefinitionVal.getSafetyEx (v : DefinitionVal) : DefinitionSafety :=
  v.safety

structure TheoremVal extends ConstantVal where
  value : Expr
  /--
    List of all (including this one) declarations in the same mutual block.
    See comment at `DefinitionVal.all`. -/
  all : List Name := [name]
  deriving Inhabited

/-- Value for an opaque constant declaration `opaque x : t := e` -/
structure OpaqueVal extends ConstantVal where
  value : Expr
  isUnsafe : Bool
  /--
    List of all (including this one) declarations in the same mutual block.
    See comment at `DefinitionVal.all`. -/
  all : List Name := [name]
  deriving Inhabited

@[export lean_mk_opaque_val]
def mkOpaqueValEx (name : Name) (levelParams : List Name) (type : Expr) (value : Expr) (isUnsafe : Bool) (all : List Name) : OpaqueVal := {
  name, levelParams, type, value, isUnsafe, all
}

@[export lean_opaque_val_is_unsafe] def OpaqueVal.isUnsafeEx (v : OpaqueVal) : Bool :=
  v.isUnsafe

structure Constructor where
  name : Name
  type : Expr
  deriving Inhabited

structure InductiveType where
  name : Name
  type : Expr
  ctors : List Constructor
  deriving Inhabited

/-- Declaration object that can be sent to the kernel. -/
inductive Declaration where
  | axiomDecl       (val : AxiomVal)
  | defnDecl        (val : DefinitionVal)
  | thmDecl         (val : TheoremVal)
  | opaqueDecl      (val : OpaqueVal)
  | quotDecl
  | mutualDefnDecl  (defns : List DefinitionVal) -- All definitions must be marked as `unsafe` or `partial`
  | inductDecl      (lparams : List Name) (nparams : Nat) (types : List InductiveType) (isUnsafe : Bool)
  deriving Inhabited

@[export lean_mk_inductive_decl]
def mkInductiveDeclEs (lparams : List Name) (nparams : Nat) (types : List InductiveType) (isUnsafe : Bool) : Declaration :=
  Declaration.inductDecl lparams nparams types isUnsafe

@[export lean_is_unsafe_inductive_decl]
def Declaration.isUnsafeInductiveDeclEx : Declaration → Bool
  | Declaration.inductDecl _ _ _ isUnsafe => isUnsafe
  | _ => false

@[specialize] def Declaration.foldExprM {α} {m : Type → Type} [Monad m] (d : Declaration) (f : α → Expr → m α) (a : α) : m α :=
  match d with
  | Declaration.quotDecl                                        => pure a
  | Declaration.axiomDecl { type := type, .. }                  => f a type
  | Declaration.defnDecl { type := type, value := value, .. }   => do let a ← f a type; f a value
  | Declaration.opaqueDecl { type := type, value := value, .. } => do let a ← f a type; f a value
  | Declaration.thmDecl { type := type, value := value, .. }    => do let a ← f a type; f a value
  | Declaration.mutualDefnDecl vals                             => vals.foldlM (fun a v => do let a ← f a v.type; f a v.value) a
  | Declaration.inductDecl _ _ inductTypes _                    =>
    inductTypes.foldlM
      (fun a inductType => do
        let a ← f a inductType.type
        inductType.ctors.foldlM (fun a ctor => f a ctor.type) a)
      a

@[inline] def Declaration.forExprM {m : Type → Type} [Monad m] (d : Declaration) (f : Expr → m Unit) : m Unit :=
  d.foldExprM (fun _ a => f a) ()

/-- The kernel compiles (mutual) inductive declarations (see `inductiveDecls`) into a set of
    - `Declaration.inductDecl` (for each inductive datatype in the mutual Declaration),
    - `Declaration.ctorDecl` (for each Constructor in the mutual Declaration),
    - `Declaration.recDecl` (automatically generated recursors).

    This data is used to implement iota-reduction efficiently and compile nested inductive
    declarations.

    A series of checks are performed by the kernel to check whether a `inductiveDecls`
    is valid or not. -/
structure InductiveVal extends ConstantVal where
  /-- Number of parameters. A parameter is an argument to the defined type that is fixed over constructors.
  An example of this is the `α : Type` argument in the vector constructors
  `nil : Vector α 0` and `cons : α → Vector α n → Vector α (n+1)`.

  The intuition is that the inductive type must exhibit _parametric polymorphism_ over the inductive
  parameter, as opposed to _ad-hoc polymorphism_.
  -/
  numParams : Nat
  /-- Number of indices. An index is an argument that varies over constructors.

  An example of this is the `n : Nat` argument in the vector constructor `cons : α → Vector α n → Vector α (n+1)`.
  -/
  numIndices : Nat
  /-- List of all (including this one) inductive datatypes in the mutual declaration containing this one -/
  all : List Name
  /-- List of the names of the constructors for this inductive datatype. -/
  ctors : List Name
  /-- `true` when recursive (that is, the inductive type appears as an argument in a constructor). -/
  isRec : Bool
  /-- Whether the definition is flagged as unsafe. -/
  isUnsafe : Bool
  /-- An inductive type is called reflexive if it has at least one constructor that takes as an argument a function returning the
  same type we are defining.
  Consider the type:
  ```
  inductive WideTree where
  | branch: (Nat -> WideTree) -> WideTree
  | leaf: WideTree
  ```
  this is reflexive due to the presence of the `branch : (Nat -> WideTree) -> WideTree` constructor.

  See also: 'Inductive Definitions in the system Coq Rules and Properties' by Christine Paulin-Mohring
  Section 2.2, Definition 3
  -/
  isReflexive : Bool
  /-- An inductive definition `T` is nested when there is a constructor with an argument `x : F T`,
   where `F : Type → Type` is some suitably behaved (ie strictly positive) function (Eg `Array T`, `List T`, `T × T`, ...). -/
  isNested : Bool
  deriving Inhabited

@[export lean_mk_inductive_val]
def mkInductiveValEx (name : Name) (levelParams : List Name) (type : Expr) (numParams numIndices : Nat)
    (all ctors : List Name) (isRec isUnsafe isReflexive isNested : Bool) : InductiveVal := {
  name := name
  levelParams := levelParams
  type := type
  numParams := numParams
  numIndices := numIndices
  all := all
  ctors := ctors
  isRec := isRec
  isUnsafe := isUnsafe
  isReflexive := isReflexive
  isNested := isNested
}

@[export lean_inductive_val_is_rec] def InductiveVal.isRecEx (v : InductiveVal) : Bool := v.isRec
@[export lean_inductive_val_is_unsafe] def InductiveVal.isUnsafeEx (v : InductiveVal) : Bool := v.isUnsafe
@[export lean_inductive_val_is_reflexive] def InductiveVal.isReflexiveEx (v : InductiveVal) : Bool := v.isReflexive
@[export lean_inductive_val_is_nested] def InductiveVal.isNestedEx (v : InductiveVal) : Bool := v.isNested

def InductiveVal.numCtors (v : InductiveVal) : Nat := v.ctors.length

structure ConstructorVal extends ConstantVal where
  /-- Inductive type this constructor is a member of -/
  induct  : Name
  /-- Constructor index (i.e., Position in the inductive declaration) -/
  cidx    : Nat
  /-- Number of parameters in inductive datatype. -/
  numParams : Nat
  /-- Number of fields (i.e., arity - nparams) -/
  numFields : Nat
  isUnsafe : Bool
  deriving Inhabited

@[export lean_mk_constructor_val]
def mkConstructorValEx (name : Name) (levelParams : List Name) (type : Expr) (induct : Name) (cidx numParams numFields : Nat) (isUnsafe : Bool) : ConstructorVal := {
  name := name,
  levelParams := levelParams,
  type := type,
  induct := induct,
  cidx := cidx,
  numParams := numParams,
  numFields := numFields,
  isUnsafe := isUnsafe
}

@[export lean_constructor_val_is_unsafe] def ConstructorVal.isUnsafeEx (v : ConstructorVal) : Bool := v.isUnsafe

/-- Information for reducing a recursor -/
structure RecursorRule where
  /-- Reduction rule for this Constructor -/
  ctor : Name
  /-- Number of fields (i.e., without counting inductive datatype parameters) -/
  nfields : Nat
  /-- Right hand side of the reduction rule -/
  rhs : Expr
  deriving Inhabited

structure RecursorVal extends ConstantVal where
  /-- List of all inductive datatypes in the mutual declaration that generated this recursor -/
  all : List Name
  /-- Number of parameters -/
  numParams : Nat
  /-- Number of indices -/
  numIndices : Nat
  /-- Number of motives -/
  numMotives : Nat
  /-- Number of minor premises -/
  numMinors : Nat
  /-- A reduction for each Constructor -/
  rules : List RecursorRule
  /-- It supports K-like reduction.
  A recursor is said to support K-like reduction if one can assume it behaves
  like `Eq` under axiom `K` --- that is, it has one constructor, the constructor has 0 arguments,
  and it is an inductive predicate (ie, it lives in Prop).

  Examples of inductives with K-like reduction is `Eq`, `Acc`, and `And.intro`.
  Non-examples are `exists` (where the constructor has arguments) and
    `Or.intro` (which has multiple constructors).
  -/
  k : Bool
  isUnsafe : Bool
  deriving Inhabited

@[export lean_mk_recursor_val]
def mkRecursorValEx (name : Name) (levelParams : List Name) (type : Expr) (all : List Name) (numParams numIndices numMotives numMinors : Nat)
    (rules : List RecursorRule) (k isUnsafe : Bool) : RecursorVal := {
  name := name, levelParams := levelParams, type := type, all := all, numParams := numParams, numIndices := numIndices,
  numMotives := numMotives, numMinors := numMinors, rules := rules, k := k, isUnsafe := isUnsafe
}

@[export lean_recursor_k] def RecursorVal.kEx (v : RecursorVal) : Bool := v.k
@[export lean_recursor_is_unsafe] def RecursorVal.isUnsafeEx (v : RecursorVal) : Bool := v.isUnsafe

def RecursorVal.getMajorIdx (v : RecursorVal) : Nat :=
  v.numParams + v.numMotives + v.numMinors + v.numIndices

def RecursorVal.getFirstIndexIdx (v : RecursorVal) : Nat :=
  v.numParams + v.numMotives + v.numMinors

def RecursorVal.getFirstMinorIdx (v : RecursorVal) : Nat :=
  v.numParams + v.numMotives

def RecursorVal.getInduct (v : RecursorVal) : Name :=
  v.name.getPrefix

inductive QuotKind where
  | type  -- `Quot`
  | ctor  -- `Quot.mk`
  | lift  -- `Quot.lift`
  | ind   -- `Quot.ind`
  deriving Inhabited

structure QuotVal extends ConstantVal where
  kind : QuotKind
  deriving Inhabited

@[export lean_mk_quot_val]
def mkQuotValEx (name : Name) (levelParams : List Name) (type : Expr) (kind : QuotKind) : QuotVal := {
  name := name, levelParams := levelParams, type := type, kind := kind
}

@[export lean_quot_val_kind] def QuotVal.kindEx (v : QuotVal) : QuotKind := v.kind

/-- Information associated with constant declarations. -/
inductive ConstantInfo where
  | axiomInfo    (val : AxiomVal)
  | defnInfo     (val : DefinitionVal)
  | thmInfo      (val : TheoremVal)
  | opaqueInfo   (val : OpaqueVal)
  | quotInfo     (val : QuotVal)
  | inductInfo   (val : InductiveVal)
  | ctorInfo     (val : ConstructorVal)
  | recInfo      (val : RecursorVal)
  deriving Inhabited

namespace ConstantInfo

def toConstantVal : ConstantInfo → ConstantVal
  | defnInfo     {toConstantVal := d, ..} => d
  | axiomInfo    {toConstantVal := d, ..} => d
  | thmInfo      {toConstantVal := d, ..} => d
  | opaqueInfo   {toConstantVal := d, ..} => d
  | quotInfo     {toConstantVal := d, ..} => d
  | inductInfo   {toConstantVal := d, ..} => d
  | ctorInfo     {toConstantVal := d, ..} => d
  | recInfo      {toConstantVal := d, ..} => d

def isUnsafe : ConstantInfo → Bool
  | defnInfo   v => v.safety == .unsafe
  | axiomInfo  v => v.isUnsafe
  | thmInfo    _ => false
  | opaqueInfo v => v.isUnsafe
  | quotInfo   _ => false
  | inductInfo v => v.isUnsafe
  | ctorInfo   v => v.isUnsafe
  | recInfo    v => v.isUnsafe

def isPartial : ConstantInfo → Bool
  | defnInfo v => v.safety == .partial
  | _ => false

def name (d : ConstantInfo) : Name :=
  d.toConstantVal.name

def levelParams (d : ConstantInfo) : List Name :=
  d.toConstantVal.levelParams

def numLevelParams (d : ConstantInfo) : Nat :=
  d.levelParams.length

def type (d : ConstantInfo) : Expr :=
  d.toConstantVal.type

def value? : ConstantInfo → Option Expr
  | defnInfo {value := r, ..} => some r
  | thmInfo  {value := r, ..} => some r
  | _                         => none

def hasValue : ConstantInfo → Bool
  | defnInfo _ => true
  | thmInfo  _ => true
  | _                         => false

def value! : ConstantInfo → Expr
  | defnInfo {value := r, ..} => r
  | thmInfo  {value := r, ..} => r
  | _                         => panic! "declaration with value expected"

def hints : ConstantInfo → ReducibilityHints
  | defnInfo {hints := r, ..} => r
  | _                         => ReducibilityHints.opaque

def isCtor : ConstantInfo → Bool
  | ctorInfo _ => true
  | _          => false

def isInductive : ConstantInfo → Bool
  | inductInfo _ => true
  | _            => false

/--
  List of all (including this one) declarations in the same mutual block.
-/
def all : ConstantInfo → List Name
  | inductInfo val => val.all
  | defnInfo val   => val.all
  | thmInfo val    => val.all
  | opaqueInfo val => val.all
  | info           => [info.name]

end ConstantInfo

def mkRecName (declName : Name) : Name :=
  Name.mkStr declName "rec"

end Lean


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Simon Hudon, Scott Morrison, Keeley Hoek
-/
import data.dlist.basic category.basic meta.expr meta.rb_map

namespace expr
open tactic

attribute [derive has_reflect] binder_info

protected meta def of_nat (α : expr) : ℕ → tactic expr :=
nat.binary_rec
  (tactic.mk_mapp ``has_zero.zero [some α, none])
  (λ b n tac, if n = 0 then mk_mapp ``has_one.one [some α, none] else
    do e ← tac, tactic.mk_app (cond b ``bit1 ``bit0) [e])

protected meta def of_int (α : expr) : ℤ → tactic expr
| (n : ℕ) := expr.of_nat α n
| -[1+ n] := do
  e ← expr.of_nat α (n+1),
  tactic.mk_app ``has_neg.neg [e]

/- only traverses the direct descendents -/
meta def {u} traverse {m : Type → Type u} [applicative m]
  {elab elab' : bool} (f : expr elab → m (expr elab')) :
  expr elab → m (expr elab')
 | (var v)  := pure $ var v
 | (sort l) := pure $ sort l
 | (const n ls) := pure $ const n ls
 | (mvar n n' e) := mvar n n' <$> f e
 | (local_const n n' bi e) := local_const n n' bi <$> f e
 | (app e₀ e₁) := app <$> f e₀ <*> f e₁
 | (lam n bi e₀ e₁) := lam n bi <$> f e₀ <*> f e₁
 | (pi n bi e₀ e₁) := pi n bi <$> f e₀ <*> f e₁
 | (elet n e₀ e₁ e₂) := elet n <$> f e₀ <*> f e₁ <*> f e₂
 | (macro mac es) := macro mac <$> list.traverse f es

meta def mfoldl {α : Type} {m} [monad m] (f : α → expr → m α) : α → expr → m α
| x e := prod.snd <$> (state_t.run (e.traverse $ λ e',
    (get >>= monad_lift ∘ flip f e' >>= put) $> e') x : m _)

end expr

namespace interaction_monad
open result

meta def get_result {σ α} (tac : interaction_monad σ α) :
  interaction_monad σ (interaction_monad.result σ α) | s :=
match tac s with
| r@(success _ s') := success r s'
| r@(exception _ _ s') := success r s'
end

end interaction_monad

namespace lean.parser
open lean interaction_monad.result

meta def of_tactic' {α} (tac : tactic α) : parser α :=
do r ← of_tactic (interaction_monad.get_result tac),
match r with
| (success a _) := return a
| (exception f pos _) := exception f pos
end

-- Override the builtin `lean.parser.of_tactic` coe, which is broken.
-- (See test/tactics.lean for a failure case.)
@[priority 2000]
meta instance has_coe' {α} : has_coe (tactic α) (parser α) :=
⟨of_tactic'⟩

meta def emit_command_here (str : string) : lean.parser string :=
do (_, left) ← with_input command_like str,
   return left

-- Emit a source code string at the location being parsed.
meta def emit_code_here : string → lean.parser unit
| str := do left ← emit_command_here str,
            if left.length = 0 then return ()
            else emit_code_here left

end lean.parser

namespace name

meta def head : name → string
| (mk_string s anonymous) := s
| (mk_string s p)         := head p
| (mk_numeral n p)        := head p
| anonymous               := "[anonymous]"

meta def is_private (n : name) : bool :=
n.head = "_private"

meta def last : name → string
| (mk_string s _)  := s
| (mk_numeral n _) := repr n
| anonymous        := "[anonymous]"

meta def length : name → ℕ
| (mk_string s anonymous) := s.length
| (mk_string s p)         := s.length + 1 + p.length
| (mk_numeral n p)        := p.length
| anonymous               := "[anonymous]".length

end name

namespace environment
meta def decl_filter_map {α : Type} (e : environment) (f : declaration → option α) : list α :=
  e.fold [] $ λ d l, match f d with
                     | some r := r :: l
                     | none := l
                     end

meta def decl_map {α : Type} (e : environment) (f : declaration → α) : list α :=
  e.decl_filter_map $ λ d, some (f d)

meta def get_decls (e : environment) : list declaration :=
  e.decl_map id

meta def get_trusted_decls (e : environment) : list declaration :=
  e.decl_filter_map (λ d, if d.is_trusted then some d else none)

meta def get_decl_names (e : environment) : list name :=
  e.decl_map declaration.to_name
end environment

namespace format

meta def intercalate (x : format) : list format → format :=
format.join ∘ list.intersperse x

end format

namespace tactic

meta def eval_expr' (α : Type*) [_inst_1 : reflected α] (e : expr) : tactic α :=
mk_app ``id [e] >>= eval_expr α

-- `mk_fresh_name` returns identifiers starting with underscores,
-- which are not legal when emitted by tactic programs. Turn the
-- useful source of random names provided by `mk_fresh_name` into
-- names which are usable by tactic programs.
--
-- The returned name has four components.
meta def mk_user_fresh_name : tactic name :=
do nm ← mk_fresh_name,
   return $ `user__ ++ nm.pop_prefix.sanitize_name ++ `user__

meta def is_simp_lemma : name → tactic bool :=
succeeds ∘ tactic.has_attribute `simp

meta def local_decls : tactic (name_map declaration) :=
do e ← tactic.get_env,
   let xs := e.fold native.mk_rb_map
     (λ d s, if environment.in_current_file' e d.to_name
             then s.insert d.to_name d else s),
   pure xs

meta def simp_lemmas_from_file : tactic name_set :=
do s ← local_decls,
   let s := s.map (expr.list_constant ∘ declaration.value),
   xs ← s.to_list.mmap ((<$>) name_set.of_list ∘ mfilter tactic.is_simp_lemma ∘ name_set.to_list ∘ prod.snd),
   return $ name_set.filter (λ x, ¬ s.contains x) (xs.foldl name_set.union mk_name_set)

meta def file_simp_attribute_decl (attr : name) : tactic unit :=
do s ← simp_lemmas_from_file,
   trace format!"run_cmd mk_simp_attr `{attr}",
   let lmms := format.join $ list.intersperse " " $ s.to_list.map to_fmt,
   trace format!"local attribute [{attr}] {lmms}"

meta def mk_local (n : name) : expr :=
expr.local_const n n binder_info.default (expr.const n [])

meta def local_def_value (e : expr) : tactic expr := do
do (v,_) ← solve_aux `(true) (do
         (expr.elet n t v _) ← (revert e >> target)
           | fail format!"{e} is not a local definition",
         return v),
   return v

meta def check_defn (n : name) (e : pexpr) : tactic unit :=
do (declaration.defn _ _ _ d _ _) ← get_decl n,
   e' ← to_expr e,
   guard (d =ₐ e') <|> trace d >> failed

-- meta def compile_eqn (n : name) (univ : list name) (args : list expr) (val : expr) (num : ℕ) : tactic unit :=
-- do let lhs := (expr.const n $ univ.map level.param).mk_app args,
--    stmt ← mk_app `eq [lhs,val],
--    let vs := stmt.list_local_const,
--    let stmt := stmt.pis vs,
--    (_,pr) ← solve_aux stmt (tactic.intros >> reflexivity),
--    add_decl $ declaration.thm (n <.> "equations" <.> to_string (format!"_eqn_{num}")) univ stmt (pure pr)

meta def to_implicit : expr → expr
| (expr.local_const uniq n bi t) := expr.local_const uniq n binder_info.implicit t
| e := e

meta def pis : list expr → expr → tactic expr
| (e@(expr.local_const uniq pp info _) :: es) f := do
  t ← infer_type e,
  f' ← pis es f,
  pure $ expr.pi pp info t (expr.abstract_local f' uniq)
| _ f := pure f

meta def lambdas : list expr → expr → tactic expr
| (e@(expr.local_const uniq pp info _) :: es) f := do
  t ← infer_type e,
  f' ← lambdas es f,
  pure $ expr.lam pp info t (expr.abstract_local f' uniq)
| _ f := pure f

meta def extract_def (n : name) (trusted : bool) (elab_def : tactic unit) : tactic unit :=
do cxt ← list.map to_implicit <$> local_context,
   t ← target,
   (eqns,d) ← solve_aux t elab_def,
   d ← instantiate_mvars d,
   t' ← pis cxt t,
   d' ← lambdas cxt d,
   let univ := t'.collect_univ_params,
   add_decl $ declaration.defn n univ t' d' (reducibility_hints.regular 1 tt) trusted,
   applyc n

meta def exact_dec_trivial : tactic unit := `[exact dec_trivial]

/-- Runs a tactic for a result, reverting the state after completion -/
meta def retrieve {α} (tac : tactic α) : tactic α :=
λ s, result.cases_on (tac s)
 (λ a s', result.success a s)
 result.exception

/-- Repeat a tactic at least once, calling it recursively on all subgoals,
  until it fails. This tactic fails if the first invocation fails. -/
meta def repeat1 (t : tactic unit) : tactic unit := t; repeat t

/-- `iterate_range m n t`: Repeat the given tactic at least `m` times and
  at most `n` times or until `t` fails. Fails if `t` does not run at least m times. -/
meta def iterate_range : ℕ → ℕ → tactic unit → tactic unit
| 0 0     t := skip
| 0 (n+1) t := try (t >> iterate_range 0 n t)
| (m+1) n t := t >> iterate_range m (n-1) t

meta def replace_at (tac : expr → tactic (expr × expr)) (hs : list expr) (tgt : bool) : tactic bool :=
do to_remove ← hs.mfilter $ λ h, do {
    h_type ← infer_type h,
    succeeds $ do
      (new_h_type, pr) ← tac h_type,
      assert h.local_pp_name new_h_type,
      mk_eq_mp pr h >>= tactic.exact },
  goal_simplified ← succeeds $ do {
    guard tgt,
    (new_t, pr) ← target >>= tac,
    replace_target new_t pr },
  to_remove.mmap' (λ h, try (clear h)),
  return (¬ to_remove.empty ∨ goal_simplified)

meta def simp_bottom_up' (post : expr → tactic (expr × expr)) (e : expr) (cfg : simp_config := {}) : tactic (expr × expr) :=
prod.snd <$> simplify_bottom_up () (λ _, (<$>) (prod.mk ()) ∘ post) e cfg

meta structure instance_cache :=
(α : expr)
(univ : level)
(inst : name_map expr)

meta def mk_instance_cache (α : expr) : tactic instance_cache :=
do u ← mk_meta_univ,
   infer_type α >>= unify (expr.sort (level.succ u)),
   u ← get_univ_assignment u,
   return ⟨α, u, mk_name_map⟩

namespace instance_cache

meta def get (c : instance_cache) (n : name) : tactic (instance_cache × expr) :=
match c.inst.find n with
| some i := return (c, i)
| none := do e ← mk_app n [c.α] >>= mk_instance,
  return (⟨c.α, c.univ, c.inst.insert n e⟩, e)
end

open expr
meta def append_typeclasses : expr → instance_cache → list expr →
  tactic (instance_cache × list expr)
| (pi _ binder_info.inst_implicit (app (const n _) (var _)) body) c l :=
  do (c, p) ← c.get n, return (c, p :: l)
| _ c l := return (c, l)

meta def mk_app (c : instance_cache) (n : name) (l : list expr) : tactic (instance_cache × expr) :=
do d ← get_decl n,
   (c, l) ← append_typeclasses d.type.binding_body c l,
   return (c, (expr.const n [c.univ]).mk_app (c.α :: l))

end instance_cache

/-- Reset the instance cache for the main goal. -/
meta def reset_instance_cache : tactic unit := unfreeze_local_instances

meta def match_head (e : expr) : expr → tactic unit
| e' :=
    unify e e'
<|> do `(_ → %%e') ← whnf e',
       v ← mk_mvar,
       match_head (e'.instantiate_var v)

meta def find_matching_head : expr → list expr → tactic (list expr)
| e []         := return []
| e (H :: Hs) :=
  do t ← infer_type H,
     ((::) H <$ match_head e t <|> pure id) <*> find_matching_head e Hs

meta def subst_locals (s : list (expr × expr)) (e : expr) : expr :=
(e.abstract_locals (s.map (expr.local_uniq_name ∘ prod.fst)).reverse).instantiate_vars (s.map prod.snd)

meta def set_binder : expr → list binder_info → expr
| e [] := e
| (expr.pi v _ d b) (bi :: bs) := expr.pi v bi d (set_binder b bs)
| e _ := e

meta def last_explicit_arg : expr → tactic expr
| (expr.app f e) :=
do t ← infer_type f >>= whnf,
   if t.binding_info = binder_info.default
     then pure e
     else last_explicit_arg f
| e := pure e

private meta def get_expl_pi_arity_aux : expr → tactic nat
| (expr.pi n bi d b) :=
  do m     ← mk_fresh_name,
     let l := expr.local_const m n bi d,
     new_b ← whnf (expr.instantiate_var b l),
     r     ← get_expl_pi_arity_aux new_b,
     if bi = binder_info.default then
       return (r + 1)
     else
       return r
| e := return 0

/-- Compute the arity of explicit arguments of the given (Pi-)type -/
meta def get_expl_pi_arity (type : expr) : tactic nat :=
whnf type >>= get_expl_pi_arity_aux

/-- Compute the arity of explicit arguments of the given function -/
meta def get_expl_arity (fn : expr) : tactic nat :=
infer_type fn >>= get_expl_pi_arity

/-- variation on `assert` where a (possibly incomplete)
    proof of the assertion is provided as a parameter.

    ``(h,gs) ← local_proof `h p tac`` creates a local `h : p` and
    use `tac` to (partially) construct a proof for it. `gs` is the
    list of remaining goals in the proof of `h`.

    The benefits over assert are:
    - unlike with ``h ← assert `h p, tac`` , `h` cannot be used by `tac`;
    - when `tac` does not complete the proof of `h`, returning the list
      of goals allows one to write a tactic using `h` and with the confidence
      that a proof will not boil over to goals left over from the proof of `h`,
      unlike what would be the case when using `tactic.swap`.
-/
meta def local_proof (h : name) (p : expr) (tac₀ : tactic unit) :
  tactic (expr × list expr) :=
focus1 $
do h' ← assert h p,
   [g₀,g₁] ← get_goals,
   set_goals [g₀], tac₀,
   gs ← get_goals,
   set_goals [g₁],
   return (h', gs)

meta def var_names : expr → list name
| (expr.pi n _ _ b) := n :: var_names b
| _ := []

meta def drop_binders : expr → tactic expr
| (expr.pi n bi t b) := b.instantiate_var <$> mk_local' n bi t >>= drop_binders
| e := pure e

meta def subobject_names (struct_n : name) : tactic (list name × list name) :=
do env ← get_env,
   [c] ← pure $ env.constructors_of struct_n | fail "too many constructors",
   vs  ← var_names <$> (mk_const c >>= infer_type),
   fields ← env.structure_fields struct_n,
   return $ fields.partition (λ fn, ↑("_" ++ fn.to_string) ∈ vs)

meta def expanded_field_list' : name → tactic (dlist $ name × name) | struct_n :=
do (so,fs) ← subobject_names struct_n,
   ts ← so.mmap (λ n, do
     e ← mk_const (n.update_prefix struct_n) >>= infer_type >>= drop_binders,
     expanded_field_list' $ e.get_app_fn.const_name),
   return $ dlist.join ts ++ dlist.of_list (fs.map $ prod.mk struct_n)
open functor function

meta def expanded_field_list (struct_n : name) : tactic (list $ name × name) :=
dlist.to_list <$> expanded_field_list' struct_n

meta def get_classes (e : expr) : tactic (list name) :=
attribute.get_instances `class >>= list.mfilter (λ n,
  succeeds $ mk_app n [e] >>= mk_instance)

open nat

meta def mk_mvar_list : ℕ → tactic (list expr)
| 0 := pure []
| (succ n) := (::) <$> mk_mvar <*> mk_mvar_list n

/--`iterate_at_most_on_all_goals n t`: repeat the given tactic at most `n` times on all goals,
or until it fails. Always succeeds. -/
meta def iterate_at_most_on_all_goals : nat → tactic unit → tactic unit
| 0        tac := trace "maximal iterations reached"
| (succ n) tac := tactic.all_goals $ (do tac, iterate_at_most_on_all_goals n tac) <|> skip

/--`iterate_at_most_on_subgoals n t`: repeat the tactic `t` at most `n` times on the first
goal and on all subgoals thus produced, or until it fails. Fails iff `t` fails on
current goal. -/
meta def iterate_at_most_on_subgoals : nat → tactic unit → tactic unit
| 0        tac := trace "maximal iterations reached"
| (succ n) tac := focus1 (do tac, iterate_at_most_on_all_goals n tac)

/--`apply_list l`: try to apply the tactics in the list `l` on the first goal, and
fail if none succeeds -/
meta def apply_list_expr : list expr → tactic unit
| []     := fail "no matching rule"
| (h::t) := do interactive.concat_tags (apply h) <|> apply_list_expr t

/-- constructs a list of expressions given a list of p-expressions, as follows:
- if the p-expression is the name of a theorem, use `i_to_expr_for_apply` on it
- if the p-expression is a user attribute, add all the theorems with this attribute
  to the list.-/
meta def build_list_expr_for_apply : list pexpr → tactic (list expr)
| [] := return []
| (h::t) := do
  tail ← build_list_expr_for_apply t,
  a ← i_to_expr_for_apply h,
  (do l ← attribute.get_instances (expr.const_name a),
      m ← list.mmap mk_const l,
      return (m.append tail))
  <|> return (a::tail)

/--`apply_rules hs n`: apply the list of rules `hs` (given as pexpr) and `assumption` on the
first goal and the resulting subgoals, iteratively, at most `n` times -/
meta def apply_rules (hs : list pexpr) (n : nat) : tactic unit :=
do l ← build_list_expr_for_apply hs,
   iterate_at_most_on_subgoals n (assumption <|> apply_list_expr l)

meta def replace (h : name) (p : pexpr) : tactic unit :=
do h' ← get_local h,
   p ← to_expr p,
   note h none p,
   clear h'

/-- Auxiliary function for `iff_mp` and `iff_mpr`. Takes a name, which should be either `` `iff.mp``
or `` `iff.mpr``. If the passed expression is an iterated function type eventually producing an
`iff`, returns an expression with the `iff` converted to either the forwards or backwards
implication, as requested. -/
meta def mk_iff_mp_app (iffmp : name) : expr → (nat → expr) → option expr
| (expr.pi n bi e t) f := expr.lam n bi e <$> mk_iff_mp_app t (λ n, f (n+1) (expr.var n))
| `(%%a ↔ %%b) f := some $ @expr.const tt iffmp [] a b (f 0)
| _ f := none

meta def iff_mp_core (e ty: expr) : option expr :=
mk_iff_mp_app `iff.mp ty (λ_, e)

meta def iff_mpr_core (e ty: expr) : option expr :=
mk_iff_mp_app `iff.mpr ty (λ_, e)

/-- Given an expression whose type is (a possibly iterated function producing) an `iff`,
create the expression which is the forward implication. -/
meta def iff_mp (e : expr) : tactic expr :=
do t ← infer_type e,
   iff_mp_core e t <|> fail "Target theorem must have the form `Π x y z, a ↔ b`"

/-- Given an expression whose type is (a possibly iterated function producing) an `iff`,
create the expression which is the reverse implication. -/
meta def iff_mpr (e : expr) : tactic expr :=
do t ← infer_type e,
   iff_mpr_core e t <|> fail "Target theorem must have the form `Π x y z, a ↔ b`"

/--
Attempts to apply `e`, and if that fails, if `e` is an `iff`,
try applying both directions separately.
-/
meta def apply_iff (e : expr) : tactic (list (name × expr)) :=
let ap e := tactic.apply e {new_goals := new_goals.non_dep_only} in
ap e <|> (iff_mp e >>= ap) <|> (iff_mpr e >>= ap)

meta def symm_apply (e : expr) (cfg : apply_cfg := {}) : tactic (list (name × expr)) :=
tactic.apply e cfg <|> (symmetry >> tactic.apply e cfg)

meta def apply_assumption
  (asms : tactic (list expr) := local_context)
  (tac : tactic unit := skip) : tactic unit :=
do { ctx ← asms,
     ctx.any_of (λ H, symm_apply H >> tac) } <|>
do { exfalso,
     ctx ← asms,
     ctx.any_of (λ H, symm_apply H >> tac) }
<|> fail "assumption tactic failed"

meta def change_core (e : expr) : option expr → tactic unit
| none     := tactic.change e
| (some h) :=
  do num_reverted : ℕ ← revert h,
     expr.pi n bi d b ← target,
     tactic.change $ expr.pi n bi e b,
     intron num_reverted

/--
assuming olde and newe are defeq when elaborated, replaces occurences of olde with newe at hypothesis h.
-/
meta def change_with_at (olde newe : pexpr) (hyp : name) : tactic unit :=
do h ← get_local hyp,
   tp ← infer_type h,
   olde ← to_expr olde, newe ← to_expr newe,
   let repl_tp := tp.replace (λ a n, if a = olde then some newe else none),
   change_core repl_tp (some h)

open nat

meta def solve_by_elim_aux (discharger : tactic unit) (asms : tactic (list expr))  : ℕ → tactic unit
| 0 := done
| (succ n) := discharger <|> (apply_assumption asms $ solve_by_elim_aux n)

meta structure by_elim_opt :=
  (all_goals : bool := ff)
  (discharger : tactic unit := done)
  (assumptions : tactic (list expr) := local_context)
  (max_rep : ℕ := 3)

meta def solve_by_elim (opt : by_elim_opt := { }) : tactic unit :=
do
  tactic.fail_if_no_goals,
  (if opt.all_goals then id else focus1) $
    solve_by_elim_aux opt.discharger opt.assumptions opt.max_rep

meta def metavariables : tactic (list expr) :=
do r ← result,
   pure (r.list_meta_vars)

/-- Succeeds only if the current goal is a proposition. -/
meta def propositional_goal : tactic unit :=
do goals ← get_goals,
   p ← is_proof goals.head,
   guard p

meta def triv' : tactic unit := do c ← mk_const `trivial, exact c reducible

variable {α : Type}

private meta def iterate_aux (t : tactic α) : list α → tactic (list α)
| L := (do r ← t, iterate_aux (r :: L)) <|> return L

/-- Apply a tactic as many times as possible, collecting the results in a list. -/
meta def iterate' (t : tactic α) : tactic (list α) :=
list.reverse <$> iterate_aux t []

/-- Like iterate', but fail if the tactic does not succeed at least once. -/
meta def iterate1 (t : tactic α) : tactic (α × list α) :=
do r ← decorate_ex "iterate1 failed: tactic did not succeed" t,
   L ← iterate' t,
   return (r, L)

meta def intros1 : tactic (list expr) :=
iterate1 intro1 >>= λ p, return (p.1 :: p.2)

/-- `successes` invokes each tactic in turn, returning the list of successful results. -/
meta def successes (tactics : list (tactic α)) : tactic (list α) :=
list.filter_map id <$> monad.sequence (tactics.map (λ t, try_core t))

/-- Return target after instantiating metavars and whnf -/
private meta def target' : tactic expr :=
target >>= instantiate_mvars >>= whnf

/--
Just like `split`, `fsplit` applies the constructor when the type of the target is an inductive data type with one constructor.
However it does not reorder goals or invoke `auto_param` tactics.
-/
-- FIXME check if we can remove `auto_param := ff`
meta def fsplit : tactic unit :=
do [c] ← target' >>= get_constructors_for | tactic.fail "fsplit tactic failed, target is not an inductive datatype with only one constructor",
   mk_const c >>= λ e, apply e {new_goals := new_goals.all, auto_param := ff} >> skip

run_cmd add_interactive [`fsplit]

/-- Calls `injection` on each hypothesis, and then, for each hypothesis on which `injection`
    succeeds, clears the old hypothesis. -/
meta def injections_and_clear : tactic unit :=
do l ← local_context,
   results ← successes $ l.map $ λ e, injection e >> clear e,
   when (results.empty) (fail "could not use `injection` then `clear` on any hypothesis")

run_cmd add_interactive [`injections_and_clear]

meta def note_anon (e : expr) : tactic unit :=
do n ← get_unused_name "lh",
   note n none e, skip

/-- `find_local t` returns a local constant with type t, or fails if none exists. -/
meta def find_local (t : pexpr) : tactic expr :=
do t' ← to_expr t,
   prod.snd <$> solve_aux t' assumption

/-- `dependent_pose_core l`: introduce dependent hypothesis, where the proofs depend on the values
of the previous local constants. `l` is a list of local constants and their values. -/
meta def dependent_pose_core (l : list (expr × expr)) : tactic unit := do
  let lc := l.map prod.fst,
  let lm := l.map (λ⟨l, v⟩, (l.local_uniq_name, v)),
  t ← target,
  new_goal ← mk_meta_var (t.pis lc),
  old::other_goals ← get_goals,
  set_goals (old :: new_goal :: other_goals),
  exact ((new_goal.mk_app lc).instantiate_locals lm),
  return ()

/-- like `mk_local_pis` but translating into weak head normal form before checking if it is a Π. -/
meta def mk_local_pis_whnf : expr → tactic (list expr × expr) | e := do
(expr.pi n bi d b) ← whnf e | return ([], e),
p ← mk_local' n bi d,
(ps, r) ← mk_local_pis (expr.instantiate_var b p),
return ((p :: ps), r)

/-- Changes `(h : ∀xs, ∃a:α, p a) ⊢ g` to `(d : ∀xs, a) (s : ∀xs, p (d xs) ⊢ g` -/
meta def choose1 (h : expr) (data : name) (spec : name) : tactic expr := do
  t ← infer_type h,
  (ctxt, t) ← mk_local_pis_whnf t,
  `(@Exists %%α %%p) ← whnf t transparency.all | fail "expected a term of the shape ∀xs, ∃a, p xs a",
  α_t ← infer_type α,
  expr.sort u ← whnf α_t transparency.all,
  value ← mk_local_def data (α.pis ctxt),
  t' ← head_beta (p.app (value.mk_app ctxt)),
  spec ← mk_local_def spec (t'.pis ctxt),
  dependent_pose_core [
    (value, ((((expr.const `classical.some [u]).app α).app p).app (h.mk_app ctxt)).lambdas ctxt),
    (spec, ((((expr.const `classical.some_spec [u]).app α).app p).app (h.mk_app ctxt)).lambdas ctxt)],
  try (tactic.clear h),
  intro1,
  intro1

/-- Changes `(h : ∀xs, ∃as, p as) ⊢ g` to a list of functions `as`, an a final hypothesis on `p as` -/
meta def choose : expr → list name → tactic unit
| h [] := fail "expect list of variables"
| h [n] := do
  cnt ← revert h,
  intro n,
  intron (cnt - 1),
  return ()
| h (n::ns) := do
  v ← get_unused_name >>= choose1 h n,
  choose v ns

/-- This makes sure that the execution of the tactic does not change the tactic state.
    This can be helpful while using rewrite, apply, or expr munging.
    Remember to instantiate your metavariables before you're done! -/
meta def lock_tactic_state {α} (t : tactic α) : tactic α
| s := match t s with
       | result.success a s' := result.success a s
       | result.exception msg pos s' := result.exception msg pos s
end

/--
Hole command used to fill in a structure's field when specifying an instance.

In the following:

```
instance : monad id :=
{! !}
```

invoking hole command `Instance Stub` produces:

```
instance : monad id :=
{ map := _,
  map_const := _,
  pure := _,
  seq := _,
  seq_left := _,
  seq_right := _,
  bind := _ }
```
-/
@[hole_command] meta def instance_stub : hole_command :=
{ name := "Instance Stub",
  descr := "Generate a skeleton for the structure under construction.",
  action := λ _,
  do tgt ← target >>= whnf,
     let cl := tgt.get_app_fn.const_name,
     env ← get_env,
     fs ← expanded_field_list cl,
     let fs := fs.map prod.snd,
     let fs := format.intercalate (",\n  " : format) $ fs.map (λ fn, format!"{fn} := _"),
     let out := format.to_string format!"{{ {fs} }",
     return [(out,"")] }

meta def strip_prefix' (n : name) : list string → name → tactic name
| s name.anonymous := pure $ s.foldl (flip name.mk_string) name.anonymous
| s (name.mk_string a p) :=
  do let n' := s.foldl (flip name.mk_string) name.anonymous,
     do { n'' ← tactic.resolve_constant n',
          if n'' = n
            then pure n'
            else strip_prefix' (a :: s) p }
     <|> strip_prefix' (a :: s) p
| s (name.mk_numeral a p) := interaction_monad.failed

meta def strip_prefix : name → tactic name
| n@(name.mk_string a a_1) := strip_prefix' n [a] a_1
| _ := interaction_monad.failed

meta def is_default_local : expr → bool
| (expr.local_const _ _ binder_info.default _) := tt
| _ := ff

meta def mk_patterns (t : expr) : tactic (list format) :=
do let cl := t.get_app_fn.const_name,
   env ← get_env,
   let fs := env.constructors_of cl,
   fs.mmap $ λ f,
     do { (vs,_) ← mk_const f >>= infer_type >>= mk_local_pis,
          let vs := vs.filter (λ v, is_default_local v),
          vs ← vs.mmap (λ v,
            do v' ← get_unused_name v.local_pp_name,
               pose v' none `(()),
               pure v' ),
          vs.mmap' $ λ v, get_local v >>= clear,
          let args := list.intersperse (" " : format) $ vs.map to_fmt,
          f ← strip_prefix f,
          if args.empty
            then pure $ format!"| {f} := _\n"
            else pure format!"| ({f} {format.join args}) := _\n" }

/--
Hole command used to generate a `match` expression.

In the following:

```
meta def foo (e : expr) : tactic unit :=
{! e !}
```

invoking hole command `Match Stub` produces:

```
meta def foo (e : expr) : tactic unit :=
match e with
| (expr.var a) := _
| (expr.sort a) := _
| (expr.const a a_1) := _
| (expr.mvar a a_1 a_2) := _
| (expr.local_const a a_1 a_2 a_3) := _
| (expr.app a a_1) := _
| (expr.lam a a_1 a_2 a_3) := _
| (expr.pi a a_1 a_2 a_3) := _
| (expr.elet a a_1 a_2 a_3) := _
| (expr.macro a a_1) := _
end
```
-/
@[hole_command] meta def match_stub : hole_command :=
{ name := "Match Stub",
  descr := "Generate a list of equations for a `match` expression.",
  action := λ es,
  do [e] ← pure es | fail "expecting one expression",
     e ← to_expr e,
     t ← infer_type e >>= whnf,
     fs ← mk_patterns t,
     e ← pp e,
     let out := format.to_string format!"match {e} with\n{format.join fs}end\n",
     return [(out,"")] }

/--
Hole command used to generate a `match` expression.

In the following:

```
meta def foo : {! expr → tactic unit !} -- `:=` is omitted
```

invoking hole command `Equations Stub` produces:

```
meta def foo : expr → tactic unit
| (expr.var a) := _
| (expr.sort a) := _
| (expr.const a a_1) := _
| (expr.mvar a a_1 a_2) := _
| (expr.local_const a a_1 a_2 a_3) := _
| (expr.app a a_1) := _
| (expr.lam a a_1 a_2 a_3) := _
| (expr.pi a a_1 a_2 a_3) := _
| (expr.elet a a_1 a_2 a_3) := _
| (expr.macro a a_1) := _
```

A similar result can be obtained by invoking `Equations Stub` on the following:

```
meta def foo : expr → tactic unit := -- do not forget to write `:=`!!
{! !}
```

```
meta def foo : expr → tactic unit := -- don't forget to erase `:=`!!
| (expr.var a) := _
| (expr.sort a) := _
| (expr.const a a_1) := _
| (expr.mvar a a_1 a_2) := _
| (expr.local_const a a_1 a_2 a_3) := _
| (expr.app a a_1) := _
| (expr.lam a a_1 a_2 a_3) := _
| (expr.pi a a_1 a_2 a_3) := _
| (expr.elet a a_1 a_2 a_3) := _
| (expr.macro a a_1) := _
```

-/
@[hole_command] meta def eqn_stub : hole_command :=
{ name := "Equations Stub",
  descr := "Generate a list of equations for a recursive definition.",
  action := λ es,
  do t ← match es with
         | [t] := to_expr t
         | [] := target
         | _ := fail "expecting one type"
         end,
     e ← whnf t,
     (v :: _,_) ← mk_local_pis e | fail "expecting a Pi-type",
     t' ← infer_type v,
     fs ← mk_patterns t',
     t ← pp t,
     let out :=
         if es.empty then
           format.to_string format!"-- do not forget to erase `:=`!!\n{format.join fs}"
           else format.to_string format!"{t}\n{format.join fs}",
     return [(out,"")] }

/--
This command lists the constructors that can be used to satisfy the expected type.

When used in the following hole:

```
def foo : ℤ ⊕ ℕ :=
{! !}
```

the command will produce:

```
def foo : ℤ ⊕ ℕ :=
{! sum.inl, sum.inr !}
```

and will display:

```
sum.inl : ℤ → ℤ ⊕ ℕ

sum.inr : ℕ → ℤ ⊕ ℕ
```

-/
@[hole_command] meta def list_constructors_hole : hole_command :=
{ name := "List Constructors",
  descr := "Show the list of constructors of the expected type.",
  action := λ es,
  do t ← target >>= whnf,
     (_,t) ← mk_local_pis t,
     let cl := t.get_app_fn.const_name,
     let args := t.get_app_args,
     env ← get_env,
     let cs := env.constructors_of cl,
     ts ← cs.mmap $ λ c,
       do { e ← mk_const c,
            t ← infer_type (e.mk_app args) >>= pp,
            c ← strip_prefix c,
            pure format!"\n{c} : {t}\n" },
     fs ← format.intercalate ", " <$> cs.mmap (strip_prefix >=> pure ∘ to_fmt),
     let out := format.to_string format!"{{! {fs} !}",
     trace (format.join ts).to_string,
     return [(out,"")] }

meta def classical : tactic unit :=
do h ← get_unused_name `_inst,
   mk_const `classical.prop_decidable >>= note h none,
   reset_instance_cache

open expr

meta def add_prime : name → name
| (name.mk_string s p) := name.mk_string (s ++ "'") p
| n := (name.mk_string "x'" n)

meta def mk_comp (v : expr) : expr → tactic expr
| (app f e) :=
  if e = v then pure f
  else do
    guard (¬ v.occurs f) <|> fail "bad guard",
    e' ← mk_comp e >>= instantiate_mvars,
    f ← instantiate_mvars f,
    mk_mapp ``function.comp [none,none,none,f,e']
| e :=
  do guard (e = v),
     t ← infer_type e,
     mk_mapp ``id [t]

meta def mk_higher_order_type : expr → tactic expr
| (pi n bi d b@(pi _ _ _ _)) :=
  do v ← mk_local_def n d,
     let b' := (b.instantiate_var v),
     (pi n bi d ∘ flip abstract_local v.local_uniq_name) <$> mk_higher_order_type b'
| (pi n bi d b) :=
  do v ← mk_local_def n d,
     let b' := (b.instantiate_var v),
     (l,r) ← match_eq b' <|> fail format!"not an equality {b'}",
     l' ← mk_comp v l,
     r' ← mk_comp v r,
     mk_app ``eq [l',r']
 | e := failed

open lean.parser interactive.types

@[user_attribute]
meta def higher_order_attr : user_attribute unit (option name) :=
{ name := `higher_order,
  parser := optional ident,
  descr :=
"From a lemma of the shape `f (g x) = h x` derive an auxiliary lemma of the
form `f ∘ g = h` for reasoning about higher-order functions.",
  after_set := some $ λ lmm _ _,
    do env  ← get_env,
       decl ← env.get lmm,
       let num := decl.univ_params.length,
       let lvls := (list.iota num).map (`l).append_after,
       let l : expr := expr.const lmm $ lvls.map level.param,
       t ← infer_type l >>= instantiate_mvars,
       t' ← mk_higher_order_type t,
       (_,pr) ← solve_aux t' $ do {
         intros, applyc ``_root_.funext, intro1, applyc lmm; assumption },
       pr ← instantiate_mvars pr,
       lmm' ← higher_order_attr.get_param lmm,
       lmm' ← (flip name.update_prefix lmm.get_prefix <$> lmm') <|> pure (add_prime lmm),
       add_decl $ declaration.thm lmm' lvls t' (pure pr),
       copy_attribute `simp lmm tt lmm',
       copy_attribute `functor_norm lmm tt lmm' }

attribute [higher_order map_comp_pure] map_pure

private meta def tactic.use_aux (h : pexpr) : tactic unit :=
(focus1 (refine h >> done)) <|> (fconstructor >> tactic.use_aux)

meta def tactic.use (l : list pexpr) : tactic unit :=
focus1 $ l.mmap' $ λ h, tactic.use_aux h <|> fail format!"failed to instantiate goal with {h}"

meta def clear_aux_decl_aux : list expr → tactic unit
| []     := skip
| (e::l) := do cond e.is_aux_decl (tactic.clear e) skip, clear_aux_decl_aux l

meta def clear_aux_decl : tactic unit :=
local_context >>= clear_aux_decl_aux

end tactic


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Johannes Hölzl, Reid Barton, Sean Leather

Bundled type and structure.
-/
import category_theory.functor
import category_theory.types

universes u v

namespace category_theory
variables {c d : Type u → Type v} {α : Type u}

/--
`concrete_category @hom` collects the evidence that a type constructor `c` and a
morphism predicate `hom` can be thought of as a concrete category.

In a typical example, `c` is the type class `topological_space` and `hom` is
`continuous`.
-/
structure concrete_category (hom : out_param $ ∀ {α β}, c α → c β → (α → β) → Prop) :=
(hom_id : ∀ {α} (ia : c α), hom ia ia id)
(hom_comp : ∀ {α β γ} (ia : c α) (ib : c β) (ic : c γ) {f g}, hom ia ib f → hom ib ic g → hom ia ic (g ∘ f))

attribute [class] concrete_category

/-- `bundled` is a type bundled with a type class instance for that type. Only
the type class is exposed as a parameter. -/
structure bundled (c : Type u → Type v) : Type (max (u+1) v) :=
(α : Type u)
(str : c α)

def mk_ob {c : Type u → Type v} (α : Type u) [str : c α] : bundled c := ⟨α, str⟩

namespace bundled

instance : has_coe_to_sort (bundled c) :=
{ S := Type u, coe := bundled.α }

/-- Map over the bundled structure -/
def map (f : ∀ {α}, c α → d α) (b : bundled c) : bundled d :=
⟨b.α, f b.str⟩

section concrete_category
variables (hom : ∀ {α β : Type u}, c α → c β → (α → β) → Prop)
variables [h : concrete_category @hom]
include h

instance : category (bundled c) :=
{ hom   := λ a b, subtype (hom a.2 b.2),
  id    := λ a, ⟨@id a.1, h.hom_id a.2⟩,
  comp  := λ a b c f g, ⟨g.1 ∘ f.1, h.hom_comp a.2 b.2 c.2 f.2 g.2⟩ }

variables {X Y Z : bundled c}

@[simp] lemma concrete_category_id (X : bundled c) : subtype.val (𝟙 X) = id :=
rfl

@[simp] lemma concrete_category_comp (f : X ⟶ Y) (g : Y ⟶ Z) :
  subtype.val (f ≫ g) = g.val ∘ f.val :=
rfl

instance : has_coe_to_fun (X ⟶ Y) :=
{ F   := λ f, X → Y,
  coe := λ f, f.1 }

@[simp] lemma bundled_hom_coe {X Y : bundled c} (val : X → Y) (prop) (x : X) :
  (⟨val, prop⟩ : X ⟶ Y) x = val x := rfl

end concrete_category

end bundled

def concrete_functor
  {C : Type u → Type v} {hC : ∀{α β}, C α → C β → (α → β) → Prop} [concrete_category @hC]
  {D : Type u → Type v} {hD : ∀{α β}, D α → D β → (α → β) → Prop} [concrete_category @hD]
  (m : ∀{α}, C α → D α) (h : ∀{α β} {ia : C α} {ib : C β} {f}, hC ia ib f → hD (m ia) (m ib) f) :
  bundled C ⥤ bundled D :=
{ obj := bundled.map @m,
  map := λ X Y f, ⟨ f, h f.2 ⟩}

section forget
variables {C : Type u → Type v} {hom : ∀α β, C α → C β → (α → β) → Prop} [i : concrete_category hom]
include i

/-- The forgetful functor from a bundled category to `Type`. -/
def forget : bundled C ⥤ Type u := { obj := bundled.α, map := λa b h, h.1 }

instance forget.faithful : faithful (forget : bundled C ⥤ Type u) := {}

end forget

end category_theory


/-
Copyright (c) 2020 Adam Topaz. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Adam Topaz
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.monad.basic
import Mathlib.category_theory.eq_to_hom
import Mathlib.PostPort

universes v u l

namespace Mathlib

/-!
# Bundled Monads

We define bundled (co)monads as a structure consisting of a functor `func : C ⥤ C` endowed with
a term of type `(co)monad func`. See `category_theory.monad.basic` for the definition.
The type of bundled (co)monads on a category `C` is denoted `(Co)Monad C`.

We also define morphisms of bundled (co)monads as morphisms of their underlying (co)monads
in the sense of `category_theory.(co)monad_hom`. We construct a category instance on `(Co)Monad C`.
-/

namespace category_theory

/-- Bundled monads. -/
structure Monad (C : Type u) [category C]
where
  func : C ⥤ C
  str : autoParam (monad func)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.apply_instance")
    (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic") "apply_instance") [])

/-- Bundled comonads -/
structure Comonad (C : Type u) [category C]
where
  func : C ⥤ C
  str : autoParam (comonad func)
  (Lean.Syntax.ident Lean.SourceInfo.none (String.toSubstring "Mathlib.tactic.apply_instance")
    (Lean.Name.mkStr (Lean.Name.mkStr (Lean.Name.mkStr Lean.Name.anonymous "Mathlib") "tactic") "apply_instance") [])

namespace Monad

/-- The initial monad. TODO: Prove it's initial. -/
def initial (C : Type u) [category C] : Monad C :=
  mk 𝟭

protected instance inhabited {C : Type u} [category C] : Inhabited (Monad C) :=
  { default := initial C }

protected instance func.category_theory.monad {C : Type u} [category C] {M : Monad C} : monad (func M) :=
  str M

/-- Morphisms of bundled monads. -/
def hom {C : Type u} [category C] (M : Monad C) (N : Monad C) :=
  monad_hom (func M) (func N)

namespace hom

end hom

protected instance hom.inhabited {C : Type u} [category C] {M : Monad C} : Inhabited (hom M M) :=
  { default := monad_hom.id (func M) }

protected instance category_theory.category {C : Type u} [category C] : category (Monad C) :=
  category.mk

/-- The forgetful functor from `Monad C` to `C ⥤ C`. -/
def forget (C : Type u) [category C] : Monad C ⥤ C ⥤ C :=
  functor.mk func fun (_x _x_1 : Monad C) (f : _x ⟶ _x_1) => monad_hom.to_nat_trans f

@[simp] theorem comp_to_nat_trans {C : Type u} [category C] {M : Monad C} {N : Monad C} {L : Monad C} (f : M ⟶ N) (g : N ⟶ L) : monad_hom.to_nat_trans (f ≫ g) = nat_trans.vcomp (monad_hom.to_nat_trans f) (monad_hom.to_nat_trans g) :=
  rfl

@[simp] theorem assoc_func_app {C : Type u} [category C] {M : Monad C} {X : C} : functor.map (func M) (nat_trans.app μ_ X) ≫ nat_trans.app μ_ X =
  nat_trans.app μ_ (functor.obj (func M) X) ≫ nat_trans.app μ_ X :=
  monad.assoc X

end Monad

namespace Comonad

/-- The terminal comonad. TODO: Prove it's terminal. -/
def terminal (C : Type u) [category C] : Comonad C :=
  mk 𝟭

protected instance inhabited {C : Type u} [category C] : Inhabited (Comonad C) :=
  { default := terminal C }

protected instance func.category_theory.comonad {C : Type u} [category C] {M : Comonad C} : comonad (func M) :=
  str M

/-- Morphisms of bundled comonads. -/
def hom {C : Type u} [category C] (M : Comonad C) (N : Comonad C) :=
  comonad_hom (func M) (func N)

namespace hom

end hom

protected instance hom.inhabited {C : Type u} [category C] {M : Comonad C} : Inhabited (hom M M) :=
  { default := comonad_hom.id (func M) }

protected instance category_theory.category {C : Type u} [category C] : category (Comonad C) :=
  category.mk

/-- The forgetful functor from `CoMonad C` to `C ⥤ C`. -/
def forget (C : Type u) [category C] : Comonad C ⥤ C ⥤ C :=
  functor.mk func fun (_x _x_1 : Comonad C) (f : _x ⟶ _x_1) => comonad_hom.to_nat_trans f

@[simp] theorem comp_to_nat_trans {C : Type u} [category C] {M : Comonad C} {N : Comonad C} {L : Comonad C} (f : M ⟶ N) (g : N ⟶ L) : comonad_hom.to_nat_trans (f ≫ g) = nat_trans.vcomp (comonad_hom.to_nat_trans f) (comonad_hom.to_nat_trans g) :=
  rfl

@[simp] theorem coassoc_func_app {C : Type u} [category C] {M : Comonad C} {X : C} : nat_trans.app δ_ X ≫ functor.map (func M) (nat_trans.app δ_ X) =
  nat_trans.app δ_ X ≫ nat_trans.app δ_ (functor.obj (func M) X) :=
  comonad.coassoc X


/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon

The writer monad transformer for passing immutable state.
-/
import algebra.group.defs
import logic.equiv.basic

universes u v w u₀ u₁ v₀ v₁

structure writer_t (ω : Type u) (m : Type u → Type v) (α : Type u) : Type (max u v) :=
(run : m (α × ω))

@[reducible] def writer (ω : Type u) := writer_t ω id

attribute [pp_using_anonymous_constructor] writer_t

namespace writer_t
section
  variable  {ω : Type u}
  variable  {m : Type u → Type v}
  variable  [monad m]
  variables {α β : Type u}
  open function

  @[ext]
  protected lemma ext (x x' : writer_t ω m α)
    (h : x.run = x'.run) :
    x = x' := by cases x; cases x'; congr; apply h

  @[inline] protected def tell (w : ω) : writer_t ω m punit :=
  ⟨pure (punit.star, w)⟩

  @[inline] protected def listen : writer_t ω m α → writer_t ω m (α × ω)
  | ⟨ cmd ⟩ := ⟨ (λ x : α × ω, ((x.1,x.2),x.2)) <$> cmd ⟩

  @[inline] protected def pass : writer_t ω m (α × (ω → ω)) → writer_t ω m α
  | ⟨ cmd ⟩ := ⟨ uncurry (uncurry $ λ x (f : ω → ω) w, (x,f w)) <$> cmd ⟩

  @[inline] protected def pure [has_one ω] (a : α) : writer_t ω m α :=
  ⟨ pure (a,1) ⟩

  @[inline] protected def bind [has_mul ω] (x : writer_t ω m α) (f : α → writer_t ω m β) :
    writer_t ω m β :=
  ⟨ do x  ← x.run,
       x' ← (f x.1).run,
       pure (x'.1,x.2 * x'.2) ⟩

  instance [has_one ω] [has_mul ω] : monad (writer_t ω m) :=
  { pure := λ α, writer_t.pure, bind := λ α β, writer_t.bind }

  instance [monoid ω] [is_lawful_monad m] : is_lawful_monad (writer_t ω m) :=
  { id_map := by { intros, cases x, simp [(<$>),writer_t.bind,writer_t.pure] },
    pure_bind := by { intros, simp [has_pure.pure,writer_t.pure,(>>=),writer_t.bind], ext; refl },
    bind_assoc := by { intros, simp [(>>=),writer_t.bind,mul_assoc] with functor_norm } }

  @[inline] protected def lift [has_one ω] (a : m α) : writer_t ω m α :=
  ⟨ flip prod.mk 1 <$> a ⟩

  instance (m) [monad m] [has_one ω] : has_monad_lift m (writer_t ω m) :=
  ⟨ λ α, writer_t.lift  ⟩

  @[inline] protected def monad_map {m m'} [monad m] [monad m'] {α} (f : Π {α}, m α → m' α) :
    writer_t ω m α → writer_t ω m' α :=
  λ x, ⟨ f x.run ⟩

  instance (m m') [monad m] [monad m'] : monad_functor m m' (writer_t ω m) (writer_t ω m') :=
  ⟨@writer_t.monad_map ω m m' _ _⟩

  @[inline] protected def adapt {ω' : Type u} {α : Type u} (f : ω → ω') :
    writer_t ω m α → writer_t ω' m α :=
  λ x, ⟨prod.map id f <$> x.run⟩

  instance (ε) [has_one ω] [monad m] [monad_except ε m] : monad_except ε (writer_t ω m) :=
  { throw := λ α, writer_t.lift ∘ throw,
    catch := λ α x c, ⟨catch x.run (λ e, (c e).run)⟩ }
end
end writer_t

/--
An implementation of [MonadReader](
https://hackage.haskell.org/package/mtl-2.2.2/docs/Control-Monad-Reader-Class.html#t:MonadReader).
It does not contain `local` because this function cannot be lifted using `monad_lift`.
Instead, the `monad_reader_adapter` class provides the more general `adapt_reader` function.

Note: This class can be seen as a simplification of the more "principled" definition
```
class monad_reader (ρ : out_param (Type u)) (n : Type u → Type u) :=
(lift {α : Type u} : (∀ {m : Type u → Type u} [monad m], reader_t ρ m α) → n α)
```
-/
class monad_writer (ω : out_param (Type u)) (m : Type u → Type v) :=
(tell (w : ω) : m punit)
(listen {α} : m α → m (α × ω))
(pass {α : Type u} : m (α × (ω → ω)) → m α)

export monad_writer

instance {ω : Type u} {m : Type u → Type v} [monad m] : monad_writer ω (writer_t ω m) :=
{ tell := writer_t.tell,
  listen := λ α, writer_t.listen,
  pass := λ α, writer_t.pass }

instance {ω ρ : Type u} {m : Type u → Type v} [monad m] [monad_writer ω m] :
  monad_writer ω (reader_t ρ m) :=
{ tell := λ x, monad_lift (tell x : m punit),
  listen := λ α ⟨ cmd ⟩, ⟨ λ r, listen (cmd r) ⟩,
  pass := λ α ⟨ cmd ⟩, ⟨ λ r, pass (cmd r) ⟩ }

def swap_right {α β γ} : (α × β) × γ → (α × γ) × β
| ⟨⟨x,y⟩,z⟩ := ((x,z),y)

instance {ω σ : Type u} {m : Type u → Type v} [monad m] [monad_writer ω m] :
  monad_writer ω (state_t σ m) :=
{ tell := λ x, monad_lift (tell x : m punit),
  listen := λ α ⟨ cmd ⟩, ⟨ λ r, swap_right <$> listen (cmd r) ⟩,
  pass := λ α ⟨ cmd ⟩, ⟨ λ r, pass (swap_right <$> cmd r) ⟩ }
open function

def except_t.pass_aux {ε α ω} : except ε (α × (ω → ω)) → except ε α × (ω → ω)
| (except.error a) := (except.error a,id)
| (except.ok (x,y)) := (except.ok x,y)

instance {ω ε : Type u} {m : Type u → Type v} [monad m] [monad_writer ω m] :
  monad_writer ω (except_t ε m) :=
{ tell := λ x, monad_lift (tell x : m punit),
  listen := λ α ⟨ cmd ⟩, ⟨ uncurry (λ x y, flip prod.mk y <$> x) <$> listen cmd ⟩,
  pass := λ α ⟨ cmd ⟩, ⟨ pass (except_t.pass_aux <$> cmd) ⟩ }

def option_t.pass_aux {α ω} : option (α × (ω → ω)) → option α × (ω → ω)
| none := (none ,id)
| (some (x,y)) := (some x,y)

instance {ω : Type u} {m : Type u → Type v} [monad m] [monad_writer ω m] :
  monad_writer ω (option_t m) :=
{ tell := λ x, monad_lift (tell x : m punit),
  listen := λ α ⟨ cmd ⟩, ⟨ uncurry (λ x y, flip prod.mk y <$> x) <$> listen cmd ⟩,
  pass := λ α ⟨ cmd ⟩, ⟨ pass (option_t.pass_aux <$> cmd) ⟩ }

/-- Adapt a monad stack, changing the type of its top-most environment.

This class is comparable to
[Control.Lens.Magnify](https://hackage.haskell.org/package/lens-4.15.4/docs/Control-Lens-Zoom.html#t:Magnify),
but does not use lenses (why would it), and is derived automatically for any transformer
implementing `monad_functor`.

Note: This class can be seen as a simplification of the more "principled" definition
```
class monad_reader_functor (ρ ρ' : out_param (Type u)) (n n' : Type u → Type u) :=
(map {α : Type u} :
  (∀ {m : Type u → Type u} [monad m], reader_t ρ m α → reader_t ρ' m α) → n α → n' α)
```
-/
class monad_writer_adapter (ω ω' : out_param (Type u)) (m m' : Type u → Type v) :=
(adapt_writer {α : Type u} : (ω → ω') → m α → m' α)
export monad_writer_adapter (adapt_writer)

section
variables {ω ω' : Type u} {m m' : Type u → Type v}

/-- Transitivity.

This instance generates the type-class problem with a metavariable argument (which is why this
is marked as `[nolint dangerous_instance]`).
Currently that is not a problem, as there are almost no instances of `monad_functor` or
`monad_writer_adapter`.

see Note [lower instance priority] -/
@[nolint dangerous_instance, priority 100]
instance monad_writer_adapter_trans {n n' : Type u → Type v} [monad_writer_adapter ω ω' m m']
  [monad_functor m m' n n'] : monad_writer_adapter ω ω' n n' :=
⟨λ α f, monad_map (λ α, (adapt_writer f : m α → m' α))⟩

instance [monad m] : monad_writer_adapter ω ω' (writer_t ω m) (writer_t ω' m) :=
⟨λ α, writer_t.adapt⟩
end

instance (ω : Type u) (m out) [monad_run out m] : monad_run (λ α, out (α × ω)) (writer_t ω m) :=
⟨λ α x, run $ x.run ⟩

/-- reduce the equivalence between two writer monads to the equivalence between
their underlying monad -/
def writer_t.equiv {m₁ : Type u₀ → Type v₀} {m₂ : Type u₁ → Type v₁}
  {α₁ ω₁ : Type u₀} {α₂ ω₂ : Type u₁} (F : (m₁ (α₁ × ω₁)) ≃ (m₂ (α₂ × ω₂))) :
  writer_t ω₁ m₁ α₁ ≃ writer_t ω₂ m₂ α₂ :=
{ to_fun := λ ⟨f⟩, ⟨F f⟩,
  inv_fun := λ ⟨f⟩, ⟨F.symm f⟩,
  left_inv := λ ⟨f⟩, congr_arg writer_t.mk $ F.left_inv _,
  right_inv := λ ⟨f⟩, congr_arg writer_t.mk $ F.right_inv _ }


/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.Eqns
import Lean.Meta.Tactic.Split
import Lean.Meta.Tactic.Simp.Main
import Lean.Meta.Tactic.Apply
import Lean.Elab.PreDefinition.Basic
import Lean.Elab.PreDefinition.Eqns
import Lean.Elab.PreDefinition.Structural.Basic

namespace Lean.Elab
open Meta
open Eqns

namespace Structural

structure EqnInfo extends EqnInfoCore where
  recArgPos   : Nat
  deriving Inhabited

private partial def mkProof (declName : Name) (type : Expr) : MetaM Expr := do
  trace[Elab.definition.structural.eqns] "proving: {type}"
  withNewMCtxDepth do
    let main ← mkFreshExprSyntheticOpaqueMVar type
    let (_, mvarId) ← main.mvarId!.intros
    unless (← tryURefl mvarId) do -- catch easy cases
      go (← deltaLHS mvarId)
    instantiateMVars main
where
  go (mvarId : MVarId) : MetaM Unit := do
    trace[Elab.definition.structural.eqns] "step\n{MessageData.ofGoal mvarId}"
    if (← tryURefl mvarId) then
      return ()
    else if (← tryContradiction mvarId) then
      return ()
    else if let some mvarId ← simpMatch? mvarId then
      go mvarId
    else if let some mvarId ← simpIf? mvarId then
      go mvarId
    else if let some mvarId ← whnfReducibleLHS? mvarId then
      go mvarId
    else match (← simpTargetStar mvarId {}).1 with
      | TacticResultCNM.closed => return ()
      | TacticResultCNM.modified mvarId => go mvarId
      | TacticResultCNM.noChange =>
        if let some mvarId ← deltaRHS? mvarId declName then
          go mvarId
        else if let some mvarIds ← casesOnStuckLHS? mvarId then
          mvarIds.forM go
        else if let some mvarIds ← splitTarget? mvarId then
          mvarIds.forM go
        else
          throwError "failed to generate equational theorem for '{declName}'\n{MessageData.ofGoal mvarId}"

def mkEqns (info : EqnInfo) : MetaM (Array Name) :=
  withOptions (tactic.hygienic.set · false) do
  let eqnTypes ← withNewMCtxDepth <| lambdaTelescope info.value fun xs body => do
    let us := info.levelParams.map mkLevelParam
    let target ← mkEq (mkAppN (Lean.mkConst info.declName us) xs) body
    let goal ← mkFreshExprSyntheticOpaqueMVar target
    mkEqnTypes #[info.declName] goal.mvarId!
  let baseName := mkPrivateName (← getEnv) info.declName
  let mut thmNames := #[]
  for i in [: eqnTypes.size] do
    let type := eqnTypes[i]!
    trace[Elab.definition.structural.eqns] "{eqnTypes[i]!}"
    let name := baseName ++ (`_eq).appendIndexAfter (i+1)
    thmNames := thmNames.push name
    let value ← mkProof info.declName type
    let (type, value) ← removeUnusedEqnHypotheses type value
    addDecl <| Declaration.thmDecl {
      name, type, value
      levelParams := info.levelParams
    }
  return thmNames

builtin_initialize eqnInfoExt : MapDeclarationExtension EqnInfo ← mkMapDeclarationExtension

def registerEqnsInfo (preDef : PreDefinition) (recArgPos : Nat) : CoreM Unit := do
  modifyEnv fun env => eqnInfoExt.insert env preDef.declName { preDef with recArgPos }

def getEqnsFor? (declName : Name) : MetaM (Option (Array Name)) := do
  if let some info := eqnInfoExt.find? (← getEnv) declName then
    mkEqns info
  else
    return none

def getUnfoldFor? (declName : Name) : MetaM (Option Name) := do
  let env ← getEnv
  Eqns.getUnfoldFor? declName fun _ => eqnInfoExt.find? env declName |>.map (·.toEqnInfoCore)

@[export lean_get_structural_rec_arg_pos]
def getStructuralRecArgPosImp? (declName : Name) : CoreM (Option Nat) := do
  let some info := eqnInfoExt.find? (← getEnv) declName | return none
  return some info.recArgPos

builtin_initialize
  registerGetEqnsFn getEqnsFor?
  registerGetUnfoldEqnFn getUnfoldFor?
  registerTraceClass `Elab.definition.structural.eqns

end Structural
end Lean.Elab