/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Simon Hudon, Sébastien Gouëzel, Scott Morrison
-/
import tactic.lint
import tactic.dependencies

setup_tactic_parser

namespace tactic
namespace interactive
open interactive interactive.types expr

/-- Similar to `constructor`, but does not reorder goals. -/
meta def fconstructor : tactic unit := concat_tags tactic.fconstructor

add_tactic_doc
{ name       := "fconstructor",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.fconstructor],
  tags       := ["logic", "goal management"] }

/-- `try_for n { tac }` executes `tac` for `n` ticks, otherwise uses `sorry` to close the goal.
Never fails. Useful for debugging. -/
meta def try_for (max : parse parser.pexpr) (tac : itactic) : tactic unit :=
do max ← i_to_expr_strict max >>= tactic.eval_expr nat,
  λ s, match _root_.try_for max (tac s) with
  | some r := r
  | none   := (tactic.trace "try_for timeout, using sorry" >> admit) s
  end

/-- Multiple `subst`. `substs x y z` is the same as `subst x, subst y, subst z`. -/
meta def substs (l : parse ident*) : tactic unit :=
propagate_tags $ l.mmap' (λ h, get_local h >>= tactic.subst) >> try (tactic.reflexivity reducible)

add_tactic_doc
{ name       := "substs",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.substs],
  tags       := ["rewriting"] }

/-- Unfold coercion-related definitions -/
meta def unfold_coes (loc : parse location) : tactic unit :=
unfold [
  ``coe, ``coe_t, ``has_coe_t.coe, ``coe_b,``has_coe.coe,
  ``lift, ``has_lift.lift, ``lift_t, ``has_lift_t.lift,
  ``coe_fn, ``has_coe_to_fun.coe, ``coe_sort, ``has_coe_to_sort.coe] loc

add_tactic_doc
{ name       := "unfold_coes",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.unfold_coes],
  tags       := ["simplification"] }

/-- Unfold `has_well_founded.r`, `sizeof` and other such definitions. -/
meta def unfold_wf :=
propagate_tags (well_founded_tactics.unfold_wf_rel; well_founded_tactics.unfold_sizeof)

/-- Unfold auxiliary definitions associated with the current declaration. -/
meta def unfold_aux : tactic unit :=
do tgt ← target,
   name ← decl_name,
   let to_unfold := (tgt.list_names_with_prefix name),
   guard (¬ to_unfold.empty),
   -- should we be using simp_lemmas.mk_default?
   simp_lemmas.mk.dsimplify to_unfold.to_list tgt >>= tactic.change

/-- For debugging only. This tactic checks the current state for any
missing dropped goals and restores them. Useful when there are no
goals to solve but "result contains meta-variables". -/
meta def recover : tactic unit :=
metavariables >>= tactic.set_goals

/-- Like `try { tac }`, but in the case of failure it continues
from the failure state instead of reverting to the original state. -/
meta def continue (tac : itactic) : tactic unit :=
λ s, result.cases_on (tac s)
 (λ a, result.success ())
 (λ e ref, result.success ())

/-- `id { tac }` is the same as `tac`, but it is useful for creating a block scope without
requiring the goal to be solved at the end like `{ tac }`. It can also be used to enclose a
non-interactive tactic for patterns like `tac1; id {tac2}` where `tac2` is non-interactive. -/
@[inline] protected meta def id (tac : itactic) : tactic unit := tac

/--
`work_on_goal n { tac }` creates a block scope for the `n`-goal (indexed from zero),
and does not require that the goal be solved at the end
(any remaining subgoals are inserted back into the list of goals).

Typically usage might look like:
````
intros,
simp,
apply lemma_1,
work_on_goal 2
{ dsimp,
  simp },
refl
````

See also `id { tac }`, which is equivalent to `work_on_goal 0 { tac }`.
-/
meta def work_on_goal : parse small_nat → itactic → tactic unit
| n t := do
  goals ← get_goals,
  let earlier_goals := goals.take n,
  let later_goals := goals.drop (n+1),
  set_goals (goals.nth n).to_list,
  t,
  new_goals ← get_goals,
  set_goals (earlier_goals ++ new_goals ++ later_goals)

/--
`swap n` will move the `n`th goal to the front.
`swap` defaults to `swap 2`, and so interchanges the first and second goals.

See also `tactic.interactive.rotate`, which moves the first `n` goals to the back.
-/
meta def swap (n := 2) : tactic unit :=
do gs ← get_goals,
   match gs.nth (n-1) with
   | (some g) := set_goals (g :: gs.remove_nth (n-1))
   | _        := skip
   end

add_tactic_doc
{ name       := "swap",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.swap],
  tags       := ["goal management"] }

/--
`rotate` moves the first goal to the back. `rotate n` will do this `n` times.

See also `tactic.interactive.swap`, which moves the `n`th goal to the front.
-/
meta def rotate (n := 1) : tactic unit := tactic.rotate n

add_tactic_doc
{ name       := "rotate",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.rotate],
  tags       := ["goal management"] }

/-- Clear all hypotheses starting with `_`, like `_match` and `_let_match`. -/
meta def clear_ : tactic unit := tactic.repeat $ do
  l ← local_context,
  l.reverse.mfirst $ λ h, do
    name.mk_string s p ← return $ local_pp_name h,
    guard (s.front = '_'),
    cl ← infer_type h >>= is_class, guard (¬ cl),
    tactic.clear h

add_tactic_doc
{ name       := "clear_",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.clear_],
  tags       := ["context management"] }

/--
Acts like `have`, but removes a hypothesis with the same name as
this one. For example if the state is `h : p ⊢ goal` and `f : p → q`,
then after `replace h := f h` the goal will be `h : q ⊢ goal`,
where `have h := f h` would result in the state `h : p, h : q ⊢ goal`.
This can be used to simulate the `specialize` and `apply at` tactics
of Coq. -/
meta def replace (h : parse ident?) (q₁ : parse (tk ":" *> texpr)?)
  (q₂ : parse $ (tk ":=" *> texpr)?) : tactic unit :=
do let h := h.get_or_else `this,
  old ← try_core (get_local h),
  «have» h q₁ q₂,
  match old, q₂ with
  | none,   _      := skip
  | some o, some _ := tactic.clear o
  | some o, none   := swap >> tactic.clear o >> swap
  end

add_tactic_doc
{ name       := "replace",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.replace],
  tags       := ["context management"] }

/-- Make every proposition in the context decidable. -/
meta def classical := tactic.classical

add_tactic_doc
{ name       := "classical",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.classical],
  tags       := ["classical logic", "type class"] }

private meta def generalize_arg_p_aux : pexpr → parser (pexpr × name)
| (app (app (macro _ [const `eq _ ]) h) (local_const x _ _ _)) := pure (h, x)
| _ := fail "parse error"

private meta def generalize_arg_p : parser (pexpr × name) :=
with_desc "expr = id" $ parser.pexpr 0 >>= generalize_arg_p_aux

@[nolint def_lemma]
lemma {u} generalize_a_aux {α : Sort u}
  (h : ∀ x : Sort u, (α → x) → x) : α := h α id

/--
Like `generalize` but also considers assumptions
specified by the user. The user can also specify to
omit the goal.
-/
meta def generalize_hyp  (h : parse ident?) (_ : parse $ tk ":")
  (p : parse generalize_arg_p)
  (l : parse location) :
  tactic unit :=
do h' ← get_unused_name `h,
   x' ← get_unused_name `x,
   g ← if ¬ l.include_goal then
       do refine ``(generalize_a_aux _),
          some <$> (prod.mk <$> tactic.intro x' <*> tactic.intro h')
   else pure none,
   n ← l.get_locals >>= tactic.revert_lst,
   generalize h () p,
   intron n,
   match g with
     | some (x',h') :=
        do tactic.apply h',
           tactic.clear h',
           tactic.clear x'
     | none := return ()
   end

add_tactic_doc
{ name       := "generalize_hyp",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.generalize_hyp],
  tags       := ["context management"] }

meta def compact_decl_aux : list name → binder_info → expr → list expr →
  tactic (list (list name × binder_info × expr))
| ns bi t [] := pure [(ns.reverse, bi, t)]
| ns bi t (v'@(local_const n pp bi' t') :: xs) :=
  do t' ← infer_type v',
     if bi = bi' ∧ t = t'
       then compact_decl_aux (pp :: ns) bi t xs
       else do vs ← compact_decl_aux [pp] bi' t' xs,
               pure $ (ns.reverse, bi, t) :: vs
| ns bi t (_ :: xs) := compact_decl_aux ns bi t xs

/-- go from (x₀ : t₀) (x₁ : t₀) (x₂ : t₀) to (x₀ x₁ x₂ : t₀) -/
meta def compact_decl : list expr → tactic (list (list name × binder_info × expr))
| [] := pure []
| (v@(local_const n pp bi t) :: xs)  :=
  do t ← infer_type v,
     compact_decl_aux [pp] bi t xs
| (_ :: xs) := compact_decl xs

/--
Remove identity functions from a term. These are normally
automatically generated with terms like `show t, from p` or
`(p : t)` which translate to some variant on `@id t p` in
order to retain the type.
-/
meta def clean (q : parse texpr) : tactic unit :=
do tgt : expr ← target,
   e ← i_to_expr_strict ``(%%q : %%tgt),
   tactic.exact $ e.clean

meta def source_fields (missing : list name) (e : pexpr) : tactic (list (name × pexpr)) :=
do e ← to_expr e,
   t ← infer_type e,
   let struct_n : name := t.get_app_fn.const_name,
   fields ← expanded_field_list struct_n,
   let exp_fields := fields.filter (λ x, x.2 ∈ missing),
   exp_fields.mmap $ λ ⟨p,n⟩,
     (prod.mk n ∘ to_pexpr) <$> mk_mapp (n.update_prefix p) [none,some e]

meta def collect_struct' : pexpr → state_t (list $ expr×structure_instance_info) tactic pexpr | e :=
do some str ← pure (e.get_structure_instance_info)
       | e.traverse collect_struct',
   v ← monad_lift mk_mvar,
   modify (list.cons (v,str)),
   pure $ to_pexpr v

meta def collect_struct (e : pexpr) : tactic $ pexpr × list (expr×structure_instance_info) :=
prod.map id list.reverse <$> (collect_struct' e).run []

meta def refine_one (str : structure_instance_info) :
  tactic $ list (expr×structure_instance_info) :=
do    tgt ← target >>= whnf,
      let struct_n : name := tgt.get_app_fn.const_name,
      exp_fields ← expanded_field_list struct_n,
      let missing_f := exp_fields.filter (λ f, (f.2 : name) ∉ str.field_names),
      (src_field_names,src_field_vals) ← (@list.unzip name _ ∘ list.join) <$>
        str.sources.mmap (source_fields $ missing_f.map prod.snd),
      let provided  := exp_fields.filter (λ f, (f.2 : name) ∈ str.field_names),
      let missing_f' := missing_f.filter (λ x, x.2 ∉ src_field_names),
      vs ← mk_mvar_list missing_f'.length,
      (field_values,new_goals) ← list.unzip <$> (str.field_values.mmap collect_struct : tactic _),
      e' ← to_expr $ pexpr.mk_structure_instance
          { struct := some struct_n
          , field_names  := str.field_names  ++ missing_f'.map prod.snd ++ src_field_names
          , field_values := field_values ++ vs.map to_pexpr         ++ src_field_vals },
      tactic.exact e',
      gs ← with_enable_tags (
        mzip_with (λ (n : name × name) v, do
           set_goals [v],
           try (dsimp_target simp_lemmas.mk),
           apply_auto_param
             <|> apply_opt_param
             <|> (set_main_tag [`_field,n.2,n.1]),
           get_goals)
        missing_f' vs),
      set_goals gs.join,
      return new_goals.join

meta def refine_recursively : expr × structure_instance_info → tactic (list expr) | (e,str) :=
do set_goals [e],
   rs ← refine_one str,
   gs ← get_goals,
   gs' ← rs.mmap refine_recursively,
   return $ gs'.join ++ gs

/--
`refine_struct { .. }` acts like `refine` but works only with structure instance
literals. It creates a goal for each missing field and tags it with the name of the
field so that `have_field` can be used to generically refer to the field currently
being refined.

As an example, we can use `refine_struct` to automate the construction of semigroup
instances:

```lean
refine_struct ( { .. } : semigroup α ),
-- case semigroup, mul
-- α : Type u,
-- ⊢ α → α → α

-- case semigroup, mul_assoc
-- α : Type u,
-- ⊢ ∀ (a b c : α), a * b * c = a * (b * c)
```

`have_field`, used after `refine_struct _`, poses `field` as a local constant
with the type of the field of the current goal:

```lean
refine_struct ({ .. } : semigroup α),
{ have_field, ... },
{ have_field, ... },
```
behaves like
```lean
refine_struct ({ .. } : semigroup α),
{ have field := @semigroup.mul, ... },
{ have field := @semigroup.mul_assoc, ... },
```
-/
meta def refine_struct : parse texpr → tactic unit | e :=
do (x,xs) ← collect_struct e,
   refine x,
   gs ← get_goals,
   xs' ← xs.mmap refine_recursively,
   set_goals (xs'.join ++ gs)

/--
`guard_hyp' h : t` fails if the hypothesis `h` does not have type `t`.
We use this tactic for writing tests.
Fixes `guard_hyp` by instantiating meta variables
-/
meta def guard_hyp' (n : parse ident) (p : parse $ tk ":" *> texpr) : tactic unit :=
do h ← get_local n >>= infer_type >>= instantiate_mvars, guard_expr_eq h p

/--
`match_hyp h : t` fails if the hypothesis `h` does not match the type `t` (which may be a pattern).
We use this tactic for writing tests.
-/
meta def match_hyp (n : parse ident) (p : parse $ tk ":" *> texpr) (m := reducible) :
  tactic (list expr) :=
do
  h ← get_local n >>= infer_type >>= instantiate_mvars,
  match_expr p h m

/--
`guard_expr_strict t := e` fails if the expr `t` is not equal to `e`. By contrast
to `guard_expr`, this tests strict (syntactic) equality.
We use this tactic for writing tests.
-/
meta def guard_expr_strict (t : expr) (p : parse $ tk ":=" *> texpr) : tactic unit :=
do e ← to_expr p, guard (t = e)

/--
`guard_target_strict t` fails if the target of the main goal is not syntactically `t`.
We use this tactic for writing tests.
-/
meta def guard_target_strict (p : parse texpr) : tactic unit :=
do t ← target, guard_expr_strict t p

/--
`guard_hyp_strict h : t` fails if the hypothesis `h` does not have type syntactically equal
to `t`.
We use this tactic for writing tests.
-/
meta def guard_hyp_strict (n : parse ident) (p : parse $ tk ":" *> texpr) : tactic unit :=
do h ← get_local n >>= infer_type >>= instantiate_mvars, guard_expr_strict h p

/-- Tests that there are `n` hypotheses in the current context. -/
meta def guard_hyp_nums (n : ℕ) : tactic unit :=
do k ← local_context,
   guard (n = k.length) <|> fail format!"{k.length} hypotheses found"

/-- Test that `t` is the tag of the main goal. -/
meta def guard_tags (tags : parse ident*) : tactic unit :=
do (t : list name) ← get_main_tag,
   guard (t = tags)

/-- `guard_proof_term { t } e` applies tactic `t` and tests whether the resulting proof term
  unifies with `p`. -/
meta def guard_proof_term (t : itactic) (p : parse texpr) : itactic :=
do
  g :: _ ← get_goals,
  e ← to_expr p,
  t,
  g ← instantiate_mvars g,
  unify e g

/-- `success_if_fail_with_msg { tac } msg` succeeds if the interactive tactic `tac` fails with
error message `msg` (for test writing purposes). -/
meta def success_if_fail_with_msg (tac : tactic.interactive.itactic) :=
tactic.success_if_fail_with_msg tac

/-- Get the field of the current goal. -/
meta def get_current_field : tactic name :=
do [_,field,str] ← get_main_tag,
   expr.const_name <$> resolve_name (field.update_prefix str)

meta def field (n : parse ident) (tac : itactic) : tactic unit :=
do gs ← get_goals,
   ts ← gs.mmap get_tag,
   ([g],gs') ← pure $ (list.zip gs ts).partition (λ x, x.snd.nth 1 = some n),
   set_goals [g.1],
   tac, done,
   set_goals $ gs'.map prod.fst

/--
`have_field`, used after `refine_struct _` poses `field` as a local constant
with the type of the field of the current goal:

```lean
refine_struct ({ .. } : semigroup α),
{ have_field, ... },
{ have_field, ... },
```
behaves like
```lean
refine_struct ({ .. } : semigroup α),
{ have field := @semigroup.mul, ... },
{ have field := @semigroup.mul_assoc, ... },
```
-/
meta def have_field : tactic unit :=
propagate_tags $
get_current_field
>>= mk_const
>>= note `field none
>>  return ()

/-- `apply_field` functions as `have_field, apply field, clear field` -/
meta def apply_field : tactic unit :=
propagate_tags $
get_current_field >>= applyc

add_tactic_doc
{ name       := "refine_struct",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.refine_struct, `tactic.interactive.apply_field,
                 `tactic.interactive.have_field],
  tags       := ["structures"],
  inherit_description_from := `tactic.interactive.refine_struct }

/--
`apply_rules hs n` applies the list of lemmas `hs` and `assumption` on the
first goal and the resulting subgoals, iteratively, at most `n` times.
`n` is optional, equal to 50 by default.
You can pass an `apply_cfg` option argument as `apply_rules hs n opt`.
(A typical usage would be with `apply_rules hs n { md := reducible })`,
which asks `apply_rules` to not unfold `semireducible` definitions (i.e. most)
when checking if a lemma matches the goal.)

`hs` can contain user attributes: in this case all theorems with this
attribute are added to the list of rules.

For instance:

```lean
@[user_attribute]
meta def mono_rules : user_attribute :=
{ name := `mono_rules,
  descr := "lemmas usable to prove monotonicity" }

attribute [mono_rules] add_le_add mul_le_mul_of_nonneg_right

lemma my_test {a b c d e : real} (h1 : a ≤ b) (h2 : c ≤ d) (h3 : 0 ≤ e) :
a + c * e + a + c + 0 ≤ b + d * e + b + d + e :=
-- any of the following lines solve the goal:
add_le_add (add_le_add (add_le_add (add_le_add h1 (mul_le_mul_of_nonneg_right h2 h3)) h1 ) h2) h3
by apply_rules [add_le_add, mul_le_mul_of_nonneg_right]
by apply_rules [mono_rules]
by apply_rules mono_rules
```
-/
meta def apply_rules (hs : parse pexpr_list_or_texpr) (n : nat := 50) (opt : apply_cfg := {}) :
  tactic unit :=
tactic.apply_rules hs n opt

add_tactic_doc
{ name       := "apply_rules",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.apply_rules],
  tags       := ["lemma application"] }

meta def return_cast (f : option expr) (t : option (expr × expr))
  (es : list (expr × expr × expr))
  (e x x' eq_h : expr) :
  tactic (option (expr × expr) × list (expr × expr × expr)) :=
(do guard (¬ e.has_var),
    unify x x',
    u ← mk_meta_univ,
    f ← f <|> mk_mapp ``_root_.id [(expr.sort u : expr)],
    t' ← infer_type e,
    some (f',t) ← pure t | return (some (f,t'), (e,x',eq_h) :: es),
    infer_type e >>= is_def_eq t,
    unify f f',
    return (some (f,t), (e,x',eq_h) :: es)) <|>
return (t, es)

meta def list_cast_of_aux (x : expr) (t : option (expr × expr))
  (es : list (expr × expr × expr)) :
  expr → tactic (option (expr × expr) × list (expr × expr × expr))
| e@`(cast %%eq_h %%x') := return_cast none t es e x x' eq_h
| e@`(eq.mp %%eq_h %%x') := return_cast none t es e x x' eq_h
| e@`(eq.mpr %%eq_h %%x') := mk_eq_symm eq_h >>= return_cast none t es e x x'
| e@`(@eq.subst %%α %%p %%a %%b  %%eq_h %%x') := return_cast p t es e x x' eq_h
| e@`(@eq.substr %%α %%p %%a %%b %%eq_h %%x') := mk_eq_symm eq_h >>= return_cast p t es e x x'
| e@`(@eq.rec %%α %%a %%f %%x' _  %%eq_h) := return_cast f t es e x x' eq_h
| e@`(@eq.rec_on %%α %%a %%f %%b  %%eq_h %%x') := return_cast f t es e x x' eq_h
| e := return (t,es)

meta def list_cast_of (x tgt : expr) : tactic (list (expr × expr × expr)) :=
(list.reverse ∘ prod.snd) <$> tgt.mfold (none, []) (λ e i es, list_cast_of_aux x es.1 es.2 e)

private meta def h_generalize_arg_p_aux : pexpr → parser (pexpr × name)
| (app (app (macro _ [const `heq _ ]) h) (local_const x _ _ _)) := pure (h, x)
| _ := fail "parse error"

private meta def h_generalize_arg_p : parser (pexpr × name) :=
with_desc "expr == id" $ parser.pexpr 0 >>= h_generalize_arg_p_aux

/--
`h_generalize Hx : e == x` matches on `cast _ e` in the goal and replaces it with
`x`. It also adds `Hx : e == x` as an assumption. If `cast _ e` appears multiple
times (not necessarily with the same proof), they are all replaced by `x`. `cast`
`eq.mp`, `eq.mpr`, `eq.subst`, `eq.substr`, `eq.rec` and `eq.rec_on` are all treated
as casts.

- `h_generalize Hx : e == x with h` adds hypothesis `α = β` with `e : α, x : β`;
- `h_generalize Hx : e == x with _` chooses automatically chooses the name of
  assumption `α = β`;
- `h_generalize! Hx : e == x` reverts `Hx`;
- when `Hx` is omitted, assumption `Hx : e == x` is not added.
-/
meta def h_generalize (rev : parse (tk "!")?)
     (h : parse ident_?)
     (_ : parse (tk ":"))
     (arg : parse h_generalize_arg_p)
     (eqs_h : parse ( (tk "with" >> pure <$> ident_) <|> pure [])) :
  tactic unit :=
do let (e,n) := arg,
   let h' := if h = `_ then none else h,
   h' ← (h' : tactic name) <|> get_unused_name ("h" ++ n.to_string : string),
   e ← to_expr e,
   tgt ← target,
   ((e,x,eq_h)::es) ← list_cast_of e tgt | fail "no cast found",
   interactive.generalize h' () (to_pexpr e, n),
   asm ← get_local h',
   v ← get_local n,
   hs ← es.mmap (λ ⟨e,_⟩, mk_app `eq [e,v]),
   (eqs_h.zip [e]).mmap' (λ ⟨h,e⟩, do
        h ← if h ≠ `_ then pure h else get_unused_name `h,
        () <$ note h none eq_h ),
   hs.mmap' (λ h,
     do h' ← assert `h h,
        tactic.exact asm,
        try (rewrite_target h'),
        tactic.clear h' ),
   when h.is_some (do
     (to_expr ``(heq_of_eq_rec_left %%eq_h %%asm)
       <|> to_expr ``(heq_of_cast_eq %%eq_h %%asm))
     >>= note h' none >> pure ()),
   tactic.clear asm,
   when rev.is_some (interactive.revert [n])

add_tactic_doc
{ name       := "h_generalize",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.h_generalize],
  tags       := ["context management"] }

/-- Tests whether `t` is definitionally equal to `p`. The difference with `guard_expr_eq` is that
  this uses definitional equality instead of alpha-equivalence. -/
meta def guard_expr_eq' (t : expr) (p : parse $ tk ":=" *> texpr) : tactic unit :=
do e ← to_expr p, is_def_eq t e

/--
`guard_target' t` fails if the target of the main goal is not definitionally equal to `t`.
We use this tactic for writing tests.
The difference with `guard_target` is that this uses definitional equality instead of
alpha-equivalence.
-/
meta def guard_target' (p : parse texpr) : tactic unit :=
do t ← target, guard_expr_eq' t p

add_tactic_doc
{ name       := "guard_target'",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.guard_target'],
  tags       := ["testing"] }

/--
a weaker version of `trivial` that tries to solve the goal by reflexivity or by reducing it to true,
unfolding only `reducible` constants. -/
meta def triv : tactic unit :=
tactic.triv' <|> tactic.reflexivity reducible <|> tactic.contradiction <|> fail "triv tactic failed"

add_tactic_doc
{ name       := "triv",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.triv],
  tags       := ["finishing"] }

/--
Similar to `existsi`. `use x` will instantiate the first term of an `∃` or `Σ` goal with `x`. It
will then try to close the new goal using `triv`, or try to simplify it by applying `exists_prop`.
Unlike `existsi`, `x` is elaborated with respect to the expected type.
`use` will alternatively take a list of terms `[x0, ..., xn]`.

`use` will work with constructors of arbitrary inductive types.

Examples:
```lean
example (α : Type) : ∃ S : set α, S = S :=
by use ∅

example : ∃ x : ℤ, x = x :=
by use 42

example : ∃ n > 0, n = n :=
begin
  use 1,
  -- goal is now 1 > 0 ∧ 1 = 1, whereas it would be ∃ (H : 1 > 0), 1 = 1 after existsi 1.
  exact ⟨zero_lt_one, rfl⟩,
end

example : ∃ a b c : ℤ, a + b + c = 6 :=
by use [1, 2, 3]

example : ∃ p : ℤ × ℤ, p.1 = 1 :=
by use ⟨1, 42⟩

example : Σ x y : ℤ, (ℤ × ℤ) × ℤ :=
by use [1, 2, 3, 4, 5]

inductive foo
| mk : ℕ → bool × ℕ → ℕ → foo

example : foo :=
by use [100, tt, 4, 3]
```
-/
meta def use (l : parse pexpr_list_or_texpr) : tactic unit :=
focus1 $
  tactic.use l;
  try (triv <|> (do
        `(Exists %%p) ← target,
        to_expr ``(exists_prop.mpr) >>= tactic.apply >> skip))

add_tactic_doc
{ name       := "use",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.use, `tactic.interactive.existsi],
  tags       := ["logic"],
  inherit_description_from := `tactic.interactive.use }

/--
`clear_aux_decl` clears every `aux_decl` in the local context for the current goal.
This includes the induction hypothesis when using the equation compiler and
`_let_match` and `_fun_match`.

It is useful when using a tactic such as `finish`, `simp *` or `subst` that may use these
auxiliary declarations, and produce an error saying the recursion is not well founded.

```lean
example (n m : ℕ) (h₁ : n = m) (h₂ : ∃ a : ℕ, a = n ∧ a = m) : 2 * m = 2 * n :=
let ⟨a, ha⟩ := h₂ in
begin
  clear_aux_decl, -- subst will fail without this line
  subst h₁
end

example (x y : ℕ) (h₁ : ∃ n : ℕ, n * 1 = 2) (h₂ : 1 + 1 = 2 → x * 1 = y) : x = y :=
let ⟨n, hn⟩ := h₁ in
begin
  clear_aux_decl, -- finish produces an error without this line
  finish
end
```
-/
meta def clear_aux_decl : tactic unit := tactic.clear_aux_decl

add_tactic_doc
{ name       := "clear_aux_decl",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.clear_aux_decl, `tactic.clear_aux_decl],
  tags       := ["context management"],
  inherit_description_from := `tactic.interactive.clear_aux_decl }

meta def loc.get_local_pp_names : loc → tactic (list name)
| loc.wildcard := list.map expr.local_pp_name <$> local_context
| (loc.ns l) := return l.reduce_option

meta def loc.get_local_uniq_names (l : loc) : tactic (list name) :=
list.map expr.local_uniq_name <$> l.get_locals

/--
The logic of `change x with y at l` fails when there are dependencies.
`change'` mimics the behavior of `change`, except in the case of `change x with y at l`.
In this case, it will correctly replace occurences of `x` with `y` at all possible hypotheses
in `l`. As long as `x` and `y` are defeq, it should never fail.
-/
meta def change' (q : parse texpr) : parse (tk "with" *> texpr)? → parse location → tactic unit
| none (loc.ns [none]) := do e ← i_to_expr q, change_core e none
| none (loc.ns [some h]) := do eq ← i_to_expr q, eh ← get_local h, change_core eq (some eh)
| none _ := fail "change-at does not support multiple locations"
| (some w) l :=
  do l' ← loc.get_local_pp_names l,
     l'.mmap' (λ e, try (change_with_at q w e)),
     when l.include_goal $ change q w (loc.ns [none])

add_tactic_doc
{ name       := "change'",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.change', `tactic.interactive.change],
  tags       := ["renaming"],
  inherit_description_from := `tactic.interactive.change' }

private meta def opt_dir_with : parser (option (bool × name)) :=
(do tk "with",
   arrow ← (tk "<-")?,
   h ← ident,
   return (arrow.is_some, h)) <|> return none

/--
`set a := t with h` is a variant of `let a := t`. It adds the hypothesis `h : a = t` to
the local context and replaces `t` with `a` everywhere it can.

`set a := t with ←h` will add `h : t = a` instead.

`set! a := t with h` does not do any replacing.

```lean
example (x : ℕ) (h : x = 3)  : x + x + x = 9 :=
begin
  set y := x with ←h_xy,
/-
x : ℕ,
y : ℕ := x,
h_xy : x = y,
h : y = 3
⊢ y + y + y = 9
-/
end
```
-/
meta def set (h_simp : parse (tk "!")?) (a : parse ident) (tp : parse ((tk ":") >> texpr)?)
  (_ : parse (tk ":=")) (pv : parse texpr)
  (rev_name : parse opt_dir_with) :=
do tp ← i_to_expr $ tp.get_or_else pexpr.mk_placeholder,
   pv ← to_expr ``(%%pv : %%tp),
   tp ← instantiate_mvars tp,
   definev a tp pv,
   when h_simp.is_none $ change' ``(%%pv) (some (expr.const a [])) $ interactive.loc.wildcard,
   match rev_name with
   | some (flip, id) :=
     do nv ← get_local a,
        mk_app `eq (cond flip [pv, nv] [nv, pv]) >>= assert id,
        reflexivity
   | none := skip
   end

add_tactic_doc
{ name       := "set",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.set],
  tags       := ["context management"] }

/--
`clear_except h₀ h₁` deletes all the assumptions it can except for `h₀` and `h₁`.
-/
meta def clear_except (xs : parse ident *) : tactic unit :=
do n ← xs.mmap (try_core ∘ get_local) >>= revert_lst ∘ list.filter_map id,
   ls ← local_context,
   ls.reverse.mmap' $ try ∘ tactic.clear,
   intron_no_renames n

add_tactic_doc
{ name       := "clear_except",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.clear_except],
  tags       := ["context management"] }

meta def format_names (ns : list name) : format :=
format.join $ list.intersperse " " (ns.map to_fmt)

private meta def indent_bindents (l r : string) : option (list name) → expr → tactic format
| none e :=
  do e ← pp e,
     pformat!"{l}{format.nest l.length e}{r}"
| (some ns) e :=
  do e ← pp e,
     let ns := format_names ns,
     let margin := l.length + ns.to_string.length + " : ".length,
     pformat!"{l}{ns} : {format.nest margin e}{r}"

private meta def format_binders : list name × binder_info × expr → tactic format
| (ns, binder_info.default, t) := indent_bindents "(" ")" ns t
| (ns, binder_info.implicit, t) := indent_bindents "{" "}" ns t
| (ns, binder_info.strict_implicit, t) := indent_bindents "⦃" "⦄" ns t
| ([n], binder_info.inst_implicit, t) :=
  if "_".is_prefix_of n.to_string
    then indent_bindents "[" "]" none t
    else indent_bindents "[" "]" [n] t
| (ns, binder_info.inst_implicit, t) := indent_bindents "[" "]" ns t
| (ns, binder_info.aux_decl, t) := indent_bindents "(" ")" ns t

private meta def partition_vars' (s : name_set) :
  list expr → list expr → list expr → tactic (list expr × list expr)
| [] as bs := pure (as.reverse, bs.reverse)
| (x :: xs) as bs :=
do t ← infer_type x,
   if t.has_local_in s then partition_vars' xs as (x :: bs)
     else partition_vars' xs (x :: as) bs

private meta def partition_vars : tactic (list expr × list expr) :=
do ls ← local_context,
   partition_vars' (name_set.of_list $ ls.map expr.local_uniq_name) ls [] []

/--
Format the current goal as a stand-alone example. Useful for testing tactics
or creating [minimal working examples](https://leanprover-community.github.io/mwe.html).

* `extract_goal`: formats the statement as an `example` declaration
* `extract_goal my_decl`: formats the statement as a `lemma` or `def` declaration
  called `my_decl`
* `extract_goal with i j k:` only use local constants `i`, `j`, `k` in the declaration

Examples:

```lean
example (i j k : ℕ) (h₀ : i ≤ j) (h₁ : j ≤ k) : i ≤ k :=
begin
  extract_goal,
     -- prints:
     -- example (i j k : ℕ) (h₀ : i ≤ j) (h₁ : j ≤ k) : i ≤ k :=
     -- begin
     --   admit,
     -- end
  extract_goal my_lemma
     -- prints:
     -- lemma my_lemma (i j k : ℕ) (h₀ : i ≤ j) (h₁ : j ≤ k) : i ≤ k :=
     -- begin
     --   admit,
     -- end
end

example {i j k x y z w p q r m n : ℕ} (h₀ : i ≤ j) (h₁ : j ≤ k) (h₁ : k ≤ p) (h₁ : p ≤ q) : i ≤ k :=
begin
  extract_goal my_lemma,
    -- prints:
    -- lemma my_lemma {i j k x y z w p q r m n : ℕ}
    --   (h₀ : i ≤ j)
    --   (h₁ : j ≤ k)
    --   (h₁ : k ≤ p)
    --   (h₁ : p ≤ q) :
    --   i ≤ k :=
    -- begin
    --   admit,
    -- end

  extract_goal my_lemma with i j k
    -- prints:
    -- lemma my_lemma {p i j k : ℕ}
    --   (h₀ : i ≤ j)
    --   (h₁ : j ≤ k)
    --   (h₁ : k ≤ p) :
    --   i ≤ k :=
    -- begin
    --   admit,
    -- end
end

example : true :=
begin
  let n := 0,
  have m : ℕ, admit,
  have k : fin n, admit,
  have : n + m + k.1 = 0, extract_goal,
    -- prints:
    -- example (m : ℕ)  : let n : ℕ := 0 in ∀ (k : fin n), n + m + k.val = 0 :=
    -- begin
    --   intros n k,
    --   admit,
    -- end
end
```

-/
meta def extract_goal (print_use : parse $ tt <$ tk "!" <|> pure ff)
  (n : parse ident?) (vs : parse (tk "with" *> ident*)?)
  : tactic unit :=
do tgt ← target,
   solve_aux tgt $ do
   { ((cxt₀,cxt₁,ls,tgt),_) ← solve_aux tgt $ do
       { vs.mmap clear_except,
         ls ← local_context,
         ls ← ls.mfilter $ succeeds ∘ is_local_def,
         n ← revert_lst ls,
         (c₀,c₁) ← partition_vars,
         tgt ← target,
         ls ← intron' n,
         pure (c₀,c₁,ls,tgt) },
     is_prop ← is_prop tgt,
     let title := match n, is_prop with
                  | none, _ := to_fmt "example"
                  | (some n), tt := format!"lemma {n}"
                  | (some n), ff := format!"def {n}"
                  end,
     cxt₀ ← compact_decl cxt₀ >>= list.mmap format_binders,
     cxt₁ ← compact_decl cxt₁ >>= list.mmap format_binders,
     stmt ← pformat!"{tgt} :=",
     let fmt :=
       format.group $ format.nest 2 $
         title ++ cxt₀.foldl (λ acc x, acc ++ format.group (format.line ++ x)) "" ++
         format.join (list.map (λ x, format.line ++ x) cxt₁) ++ " :" ++
         format.line ++ stmt,
     trace $ fmt.to_string $ options.mk.set_nat `pp.width 80,
     let var_names := format.intercalate " " $ ls.map (to_fmt ∘ local_pp_name),
     let call_intron := if ls.empty
                     then to_fmt ""
                     else format!"\n  intros {var_names},",
     trace!"begin{call_intron}\n  admit,\nend\n" },
   skip

add_tactic_doc
{ name       := "extract_goal",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.extract_goal],
  tags       := ["goal management", "proof extraction", "debugging"] }

/--
`inhabit α` tries to derive a `nonempty α` instance and then upgrades this
to an `inhabited α` instance.
If the target is a `Prop`, this is done constructively;
otherwise, it uses `classical.choice`.

```lean
example (α) [nonempty α] : ∃ a : α, true :=
begin
  inhabit α,
  existsi default α,
  trivial
end
```
-/
meta def inhabit (t : parse parser.pexpr) (inst_name : parse ident?) : tactic unit :=
do ty ← i_to_expr t,
   nm ← returnopt inst_name <|> get_unused_name `inst,
   tgt ← target,
   tgt_is_prop ← is_prop tgt,
   if tgt_is_prop then do
     decorate_error "could not infer nonempty instance:" $
       mk_mapp ``nonempty.elim_to_inhabited [ty, none, tgt] >>= tactic.apply,
     introI nm
   else do
     decorate_error "could not infer nonempty instance:" $
      mk_mapp ``classical.inhabited_of_nonempty' [ty, none] >>= note nm none,
     resetI

add_tactic_doc
{ name       := "inhabit",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.inhabit],
  tags       := ["context management", "type class"] }

/-- `revert_deps n₁ n₂ ...` reverts all the hypotheses that depend on one of `n₁, n₂, ...`
It does not revert `n₁, n₂, ...` themselves (unless they depend on another `nᵢ`). -/
meta def revert_deps (ns : parse ident*) : tactic unit :=
propagate_tags $
  ns.mmap get_local >>= revert_reverse_dependencies_of_hyps >> skip

add_tactic_doc
{ name       := "revert_deps",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.revert_deps],
  tags       := ["context management", "goal management"] }

/-- `revert_after n` reverts all the hypotheses after `n`. -/
meta def revert_after (n : parse ident) : tactic unit :=
propagate_tags $ get_local n >>= tactic.revert_after >> skip

add_tactic_doc
{ name       := "revert_after",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.revert_after],
  tags       := ["context management", "goal management"] }

/-- Reverts all local constants on which the target depends (recursively). -/
meta def revert_target_deps : tactic unit :=
propagate_tags $ tactic.revert_target_deps >> skip

add_tactic_doc
{ name       := "revert_target_deps",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.revert_target_deps],
  tags       := ["context management", "goal management"] }

/-- `clear_value n₁ n₂ ...` clears the bodies of the local definitions `n₁, n₂ ...`, changing them
into regular hypotheses. A hypothesis `n : α := t` is changed to `n : α`. -/
meta def clear_value (ns : parse ident*) : tactic unit :=
propagate_tags $ ns.reverse.mmap get_local >>= tactic.clear_value

add_tactic_doc
{ name       := "clear_value",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.clear_value],
  tags       := ["context management"] }

/--
`generalize' : e = x` replaces all occurrences of `e` in the target with a new hypothesis `x` of
the same type.

`generalize' h : e = x` in addition registers the hypothesis `h : e = x`.

`generalize'` is similar to `generalize`. The difference is that `generalize' : e = x` also
succeeds when `e` does not occur in the goal. It is similar to `set`, but the resulting hypothesis
`x` is not a local definition.
-/
meta def generalize' (h : parse ident?) (_ : parse $ tk ":") (p : parse generalize_arg_p) :
  tactic unit :=
propagate_tags $
do let (p, x) := p,
   e ← i_to_expr p,
   some h ← pure h | tactic.generalize' e x >> skip,
   -- `h` is given, the regular implementation of `generalize` works.
   tgt ← target,
   tgt' ← do
   { ⟨tgt', _⟩ ← solve_aux tgt (tactic.generalize e x >> target),
     to_expr ``(Π x, %%e = x → %%(tgt'.binding_body.lift_vars 0 1)) }
   <|> to_expr ``(Π x, %%e = x → %%tgt),
   t ← assert h tgt',
   swap,
   exact ``(%%t %%e rfl),
   intro x,
   intro h

add_tactic_doc
{ name       := "generalize'",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.generalize'],
  tags       := ["context management"] }

/--
If the expression `q` is a local variable with type `x = t` or `t = x`, where `x` is a local
constant, `tactic.interactive.subst' q` substitutes `x` by `t` everywhere in the main goal and
then clears `q`.
If `q` is another local variable, then we find a local constant with type `q = t` or `t = q` and
substitute `t` for `q`.

Like `tactic.interactive.subst`, but fails with a nicer error message if the substituted variable is
a local definition. It is trickier to fix this in core, since `tactic.is_local_def` is in mathlib.
-/
meta def subst' (q : parse texpr) : tactic unit := do
i_to_expr q >>= tactic.subst' >> try (tactic.reflexivity reducible)

add_tactic_doc
{ name       := "subst'",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.subst'],
  tags       := ["context management"] }

end interactive
end tactic


namespace Foo
-- The following declaration shadows the builtin parser alias `letDecl`
syntax letDecl := term ">==>" term

syntax "foo!" letDecl : term

macro_rules
  | `(foo! $x:term >==> $y) => `($x + $y)

end Foo

-- The following declaration shadows the builtin parser alias `letDecl`
syntax letDecl := term ">=>=>" term

syntax "bla!" letDecl : term

macro_rules
  | `(bla! $x:term >=>=> $y) => `($x * $y)

syntax "boo!" Foo.letDecl : term

macro_rules
  | `(boo! $x:term >==> $y) => `($x - $y)

theorem ex1 : (foo! 10 >==> 20) = 30   := rfl
theorem ex2 : (bla! 10 >=>=> 20) = 200 := rfl
theorem ex3 : (boo! 30 >==> 20) = 10   := rfl


import .def_coords

universe u

namespace o_minimal

open_locale finvec

variables {R : Type u} (S : struc R)

-- We set up a minimal theory of (literal) definable subsets of Rⁿ
-- and definable functions between them.

/-- A bundled definable subset of some Rⁿ. -/
structure Def : Type u :=
(ambdim : ℕ)
(to_set : set (finvec ambdim R))
(is_definable : S.definable to_set)

variables {S}

instance : has_coe_to_sort (Def S) :=
⟨Type u, λ X, X.to_set⟩

lemma Def.is_def_coords (X : Def S) : S.def_coords (set.univ : set X) :=
begin
  unfold struc.def_coords,
  convert X.is_definable,
  simp
end

variables (S)

def struc.definable_fun {X Y : Def S} (f : X → Y) : Prop :=
S.def_coords {z : X × Y | f z.1 = z.2}

variables {S}

@[ext] structure Hom (X Y : Def S) : Type u :=
(to_fun : X → Y)
(is_definable : S.definable_fun to_fun)

instance {X Y : Def S} : has_coe_to_fun (Hom X Y) :=
⟨_, λ f, f.to_fun⟩

--instance : category_theory.has_hom (Def S) := { hom := Hom }
local infixr ` ⟶ `:10 := Hom

@[simp] lemma Hom.to_fun_eq_coe {X Y : Def S} (f : X ⟶ Y) :
  f.to_fun = f :=
rfl

-- TODO float out proofs of definability of identity, composition
-- (useful later in presheaf stuff, notably representable instance)

def Def.id (X : Def S) : X ⟶ X :=
{ to_fun := id,
  is_definable := struc.def_coords.diag X.is_def_coords }

def Hom.comp {X Y Z : Def S} (g : Y ⟶ Z) (f : X ⟶ Y) : X ⟶ Z :=
{ to_fun := g.to_fun ∘ f.to_fun,
  is_definable := begin
    suffices : S.def_coords {p : X × Z | ∃ y, f p.1 = y ∧ g y = p.2},
    { convert this,
      ext ⟨x, z⟩,
      simp [struc.definable_fun] },
    have dXZY : S.def_coords (set.univ : set ((X × Z) × Y)) :=
      (X.is_def_coords.prod_univ Z.is_def_coords).prod_univ Y.is_def_coords,
    apply struc.def_coords.exists,
    apply struc.def_coords.inter,
    { let φ : (X × Z) × Y → X × Y := λ p, (p.1.1, p.2),
      have : is_reindexing R φ :=
        is_reindexing.prod R ((is_reindexing.fst R).comp R (is_reindexing.fst R)) (is_reindexing.snd R),
      refine struc.def_coords.reindex dXZY this f.is_definable },
    { let φ : (X × Z) × Y → Y × Z := λ p, (p.2, p.1.2),
      have : is_reindexing R φ :=
        is_reindexing.prod R (is_reindexing.snd R) ((is_reindexing.snd R).comp R (is_reindexing.fst R)),
      refine struc.def_coords.reindex dXZY this g.is_definable },
  end }

lemma Hom.comp_id {X Y : Def S} (f : X ⟶ Y) : f.comp (Def.id X) = f :=
by { ext, refl }

lemma Hom.id_comp {X Y : Def S} (f : X ⟶ Y) : (Def.id Y).comp f = f :=
by { ext, refl }

lemma Hom.comp_assoc {W X Y Z : Def S} (h : Y ⟶ Z) (g : X ⟶ Y) (f : W ⟶ X) :
  (h.comp g).comp f = h.comp (g.comp f) :=
rfl

def pt : Def S :=
{ ambdim := 0,
  to_set := set.univ,
  is_definable := S.definable_univ 0 }

instance pt.unique : unique (pt : Def S) :=
⟨⟨⟨fin_zero_elim, trivial⟩⟩, λ x, by { ext i, fin_cases i }⟩

/-! ### Presheaf stuff -/

variables (S)

-- TODO: generalize to Sort?
class definable_psh (X : Type*) :=
(definable : Π {K : Def S}, (K → X) → Prop)
(definable_precomp : ∀ {L K : Def S} (φ : L ⟶ K) {f : K → X},
  definable f → definable (f ∘ φ))

-- TODO: apply bug??
def definable {X : Type*} [definable_psh S X] (x : X) : Prop :=
definable_psh.definable (λ (_ : (pt : Def S)), x)

variables {S}

def definable_psh.definable' {X : Type*} (h : definable_psh S X) {K : Def S} (f : K → X) : Prop :=
definable_psh.definable f

instance Def.definable_psh (X : Def S) : definable_psh S X :=
{ definable := λ K f, S.definable_fun f,
  definable_precomp := begin
    rintros L K φ f h,
    exact ((⟨f, h⟩ : K ⟶ X).comp φ).is_definable
  end }

lemma pt.definable {K : Def S} {f : K → (pt : Def S)} : definable_psh.definable f :=
begin
  change S.definable _,
  convert K.is_def_coords using 1,
  ext x,
  split,
  { rintros ⟨⟨k, p⟩, -, rfl⟩,
    refine ⟨k, trivial, _⟩,
    simp },
  { rintros ⟨k, -, rfl⟩,
    refine ⟨⟨k, default _⟩, show _ = _, by cc, _⟩,
    simp }
end

instance {X Y : Type*} [definable_psh S X] [definable_psh S Y] : definable_psh S (X × Y) :=
{ definable := λ K f, definable_psh.definable (prod.fst ∘ f) ∧ definable_psh.definable (prod.snd ∘ f),
  definable_precomp := begin
    rintros L K φ _ ⟨h₁, h₂⟩,
    exact ⟨definable_psh.definable_precomp φ h₁, definable_psh.definable_precomp φ h₂⟩,
  end }

instance function.definable_psh {X Y : Type*} [hX : definable_psh S X] [hY : definable_psh S Y] :
  definable_psh S (X → Y) :=
{ definable := λ K f, ∀ (M : Def S) {g : M → K × X} (h : definable_psh.definable g),
    definable_psh.definable (function.uncurry f ∘ g),
  definable_precomp := λ L K φ f hf M g hg, begin
    suffices : definable_psh.definable (λ m, (φ (g m).1, (g m).2)),
    { apply hf M this },
    split,
    { exact definable_psh.definable_precomp ⟨λ m, (g m).1, hg.1⟩
        (show definable_psh.definable φ, from φ.is_definable) },
    { exact hg.2 }
  end }

lemma definable_fun {X Y : Type*} [definable_psh S X] [definable_psh S Y]
  {f : X → Y} : definable S f ↔
  ∀ {K : Def S} (φ : K → X), definable_psh.definable φ → definable_psh.definable (f ∘ φ) :=
begin
  split; intro H,
  { intros K φ hφ,
    -- TODO: This proof is awkward
    specialize H K,
    swap,
    { exact (λ k, (default _, φ k)) },
    exact H ⟨pt.definable, hφ⟩ },
  { intros K φ hφ,
    exact H _ hφ.2 }
end

lemma definable_app {X Y : Type*} [definable_psh S X] [definable_psh S Y]
  {f : X → Y} (hf : definable S f) {x : X} (hx : definable S x) : definable S (f x) :=
begin
  rw definable_fun at hf,
  exact hf _ hx
end

lemma definable.app_ctx {Γ X Y : Type*} [definable_psh S Γ] [definable_psh S X] [definable_psh S Y]
  {f : Γ → X → Y} (hf : definable S f) {x : Γ → X} (hx : definable S x) :
  definable S (λ γ, f γ (x γ)) :=
begin
  rw definable_fun at ⊢ hf hx,
  intros K φ hφ,
  change definable_psh.definable (λ k, f (φ k) (x (φ k))),
  specialize hf φ hφ,
  specialize hf K,
  swap, { exact λ k, (k, x (φ k)) },
  exact hf ⟨(Def.id K).is_definable, hx φ hφ⟩
end

lemma definable_yoneda {K : Def S} {X : Type*} [definable_psh S X]
  {f : K → X} : definable_psh.definable f ↔ definable S f :=
begin
  rw definable_fun,
  split,
  { intros h L φ hφ,
    exact definable_psh.definable_precomp ⟨φ, hφ⟩ h },
  { intros H,
    refine H id _,
    exact (Def.id K).is_definable }
end

lemma definable_prod_mk {X Y : Type*} [definable_psh S X] [definable_psh S Y] :
  definable S (prod.mk : X → Y → X × Y) :=
-- I have no idea how to come up with these proofs.
-- Maybe we should tweak the type of definable_precomp (or write a lemma)
-- that takes the underlying map φ and its proof of definability separately
-- so that Lean has a better chance of guessing what's happening?
λ L g h L' g' h',
⟨definable_psh.definable_precomp ⟨λ x, (g' x).fst, h'.1⟩ h.2, h'.2⟩

lemma definable_fst {X Y : Type*} [definable_psh S X] [definable_psh S Y] :
  definable S (prod.fst : X × Y → X) :=
begin
  rw definable_fun,
  intros K φ hφ,
  exact hφ.1
end

lemma definable_snd {X Y : Type*} [definable_psh S X] [definable_psh S Y] :
  definable S (prod.snd : X × Y → Y) :=
begin
  rw definable_fun,
  intros K φ hφ,
  exact hφ.2
end

lemma definable.prod_mk {W X Y : Type*} [definable_psh S W] [definable_psh S X] [definable_psh S Y]
  {f : W → X} (hf : definable S f) {g : W → Y} (hg : definable S g) :
  definable S (λ w, (f w, g w)) :=
begin
  rw definable_fun at ⊢ hf hg,
  intros K φ hφ,
  exact ⟨hf φ hφ, hg φ hφ⟩
end

lemma definable_fun₂ {X Y Z : Type*} [definable_psh S X] [definable_psh S Y] [definable_psh S Z]
  {f : X → Y → Z} :
  (∀ {L : Def S} (φ : L → X), definable S φ → definable S (f ∘ φ)) ↔
  (∀ {L : Def S} (φ : L → X × Y), definable S φ → definable S (function.uncurry f ∘ φ)) :=
begin
  split; intro H,
  { intros L φ hφ,
    rw definable_fun at ⊢,
    intros K ψ hψ,
    have : definable S (prod.fst ∘ φ),
    { rw ←definable_yoneda at ⊢ hφ,
      exact hφ.1 },
    specialize H (λ l, (φ l).1) this,
    rw definable_fun at H,
    specialize H ψ hψ,
    specialize H K,
    swap, { exact λ k, (k, (φ (ψ k)).2) },
    refine H ⟨(Def.id K).is_definable, _⟩, clear H,
    rw ←definable_yoneda at hφ,
    exact definable_psh.definable_precomp ⟨ψ, hψ⟩ hφ.2 },
  { intros L φ hφ,
    rw definable_fun,
    intros K ψ hψ,
    intros K' ψ' hψ',
    dsimp [function.uncurry, function.comp],
    specialize H (λ k', (φ (ψ (ψ' k').1), (ψ' k').2)),
    have : definable S (λ k', (φ (ψ (ψ' k').1), (ψ' k').2)),
    { rw ←definable_yoneda at ⊢ hφ,
      split,
      { refine definable_psh.definable_precomp ⟨λ k', ψ (ψ' k').fst, _⟩ hφ,
        exact (Hom.comp ⟨ψ, hψ⟩ ⟨_, hψ'.1⟩).is_definable },
      { exact hψ'.2 } },
    specialize H this,
    rw definable_fun at H,
    exact H _ (Def.id _).is_definable }
end

lemma definable_comp {X Y Z : Type*} [definable_psh S X] [definable_psh S Y] [definable_psh S Z] :
  definable S (function.comp : (Y → Z) → (X → Y) → (X → Z)) :=
begin
  -- TODO: Make these 4 lines a lemma.
  rw definable_fun,
  intros L₁ φ₁ hφ₁,
  rw definable_yoneda at ⊢ hφ₁,
  revert L₁,
  -- end lemma
  rw definable_fun₂,
  rw definable_fun₂,
  rintros L φ hφ,
  rw ←definable_yoneda at hφ,
  obtain ⟨⟨hφ₁, hφ₂⟩, hφ₃⟩ := hφ,
  rw definable_yoneda at hφ₁ hφ₂ hφ₃,
  dsimp [function.uncurry, function.comp],
  exact hφ₁.app_ctx (hφ₂.app_ctx hφ₃)
end

lemma definable.comp {X Y Z : Type*} [definable_psh S X] [definable_psh S Y] [definable_psh S Z]
  {g : Y → Z} (hg : definable S g) {f : X → Y} (hf : definable S f) :
  definable S (g ∘ f) :=
definable_app (definable_app definable_comp hg) hf

lemma definable.comp_ctx {Γ X Y Z : Type*} [definable_psh S Γ] [definable_psh S X] [definable_psh S Y] [definable_psh S Z]
  {g : Γ → Y → Z} (hg : definable S g) {f : Γ → X → Y} (hf : definable S f) :
  definable S (λ γ, g γ ∘ f γ) :=
definable.app_ctx (definable.comp definable_comp hg) hf

lemma definable_curry {X Y Z : Type*} [definable_psh S X] [definable_psh S Y] [definable_psh S Z] :
  definable S (function.curry : (X × Y → Z) → X → Y → Z) :=
begin
  -- TODO: Make these 4 lines a lemma.
  rw definable_fun,
  intros L₁ φ₁ hφ₁,
  rw definable_yoneda at ⊢ hφ₁,
  revert L₁,
  -- end lemma
  rw definable_fun₂,
  rw definable_fun₂,
  rintros L φ hφ,
  rw ←definable_yoneda at hφ,
  obtain ⟨⟨hφ₁, hφ₂⟩, hφ₃⟩ := hφ,
  rw definable_yoneda at hφ₁ hφ₂ hφ₃,
  exact definable.app_ctx hφ₁ (hφ₂.prod_mk hφ₃)
end

instance Prop.definable_psh : definable_psh S Prop :=
{ definable := λ K s, S.def_coords s,
  definable_precomp := λ L K φ f hf, sorry } -- preimage

instance set.definable_psh {X : Type*} [definable_psh S X] : definable_psh S (set X) :=
show definable_psh S (X → Prop), by apply_instance

lemma definable_and : definable S (∧) :=
begin
  suffices : definable S (λ r : Prop × Prop, r.1 ∧ r.2),
  { exact definable_app definable_curry this },
  rw definable_fun,
  rintros K φ ⟨hφ₁, hφ₂⟩,
  exact hφ₁.inter hφ₂
end

lemma definable.and {W : Type*} [definable_psh S W]
  {f : W → Prop} (hf : definable S f) {g : W → Prop} (hg : definable S g) :
  definable S (λ w, f w ∧ g w) :=
definable.app_ctx (definable.comp definable_and hf) hg

lemma definable_inter {X : Type*} [definable_psh S X] :
  definable S ((∩) : set X → set X → set X) :=
begin
  suffices : definable S (λ (r : set X × set X) (x : X), r.1 x ∧ r.2 x),
  { exact (definable_app definable_curry this : _) },
  -- TODO: Make these 4 lines a lemma.
  rw definable_fun,
  intros L₁ φ₁ hφ₁,
  rw definable_yoneda at ⊢ hφ₁,
  revert L₁,
  -- end lemma
  rw definable_fun₂,
  intros L φ hφ,
  rw ←definable_yoneda at hφ,
  obtain ⟨⟨hφ₁, hφ₂⟩, hφ₃⟩ := hφ,
  rw definable_yoneda at hφ₁ hφ₂ hφ₃,
  apply definable.and,
  { exact hφ₁.app_ctx hφ₃ },
  { exact hφ₂.app_ctx hφ₃ }
end

/-
instance foo {X Y : Type*} [definable_psh S X] [definable_psh S Y]
  {p : X → Prop}
  : definable_psh S (Π (x : X) (h : p x), Y) :=
sorry
-/

lemma definable_definable {X : Type*} [definable_psh S X] :
  definable S (definable S : X → Prop) :=
begin
  rw definable_fun,
  intros K φ hφ,
  change S.def_coords _,
  convert K.is_def_coords,
  apply set.eq_univ_of_forall,
  intro x,
  change definable S (φ x),
  apply definable_app,
  { rw ←definable_yoneda, exact hφ },
  -- now we need to know that every point of a representable guy
  -- is definable. this needs definable constants!
  sorry
  -- In general, the definable elements of a structure
  -- might or might not form a definable set.
  -- Counterexample: take (ℝ, +, *) without constants;
  -- definable elements are the algebraic real numbers,
  -- but only tame sets can be definable.
  -- However, once the structure has definable constants,
  -- then everything is definable and of course the set `univ` is definable.
end
-- Important note: it is definitely *not* true that
-- `definable S` = `set.univ` on *every* X with a definable_psh structure;
-- just represented guys.

/-
similarly, in an o-minimal structure:

lemma definable_finite [DUNLO R] [o_minimal S] :
  definable S (set.finite : set R → Prop) := sorry

because "finite" is equivalent to "does not contain an interval"
on the tame = definable sets, which are the only ones that matter.
-/

instance self : definable_psh S R := sorry

variables (S)

#exit
class definable_fam {X : Type*} [definable_psh S X] (Y : X → Sort*) :=
(definable : Π {K : Def S} (x : K → X) (hx : definable_psh.definable x), (Π k, Y (x k)) → Prop)
-- s.t. blah blah blah...

instance moo {X : Type*} {Y : X → Type*} [definable_psh S X] [definable_fam S Y] :
  definable_psh S (Π (x : X), Y x) :=
sorry

constant choice : Π (X : set R), X.nonempty → X

example : definable S (set.nonempty : set R → Prop) :=
sorry

instance : definable_fam S (set.nonempty : set R → Prop) := sorry

instance pi {X : Type*} [definable_psh S X] {Y Z : X → Sort*} [definable_fam S Y] [definable_fam S Z] :
  definable_fam S (λ x, Y x → Z x) :=
sorry

instance subtype {X : Type*} [definable_psh S X] : definable_fam S (λ (s : set X), s) :=
sorry

example : definable S ((λ x hx₁ hx₂, choice x hx₁) : Π (X : set R), X.nonempty → X.nonempty → X) :=
sorry

-- can we do without this `definable_fam` stuff? even as a hack?
-- or maybe stick with this for now?

/- TODO:
* class represented [has_coordinates R X] expressing compatibility
* prove this notion of definability of functions, sets reduces
  to the original one in the represented case
Then:
* prove stuff like `is_least : set R → R → Prop` is definable
-/

end o_minimal


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.list.basic
import Mathlib.Lean3Lib.init.data.char.basic

universes l u_1

namespace Mathlib

/- In the VM, strings are implemented using a dynamic array and UTF-8 encoding.

   TODO: we currently cannot mark string_imp as private because
   we need to bind string_imp.mk and string_imp.cases_on in the VM.
-/

structure string_imp
where
  data : List char

def string :=
  string_imp

def list.as_string (s : List char) : string :=
  string_imp.mk s

namespace string

protected instance has_lt : HasLess string :=
  { Less := fun (s₁ s₂ : string) => string_imp.data s₁ < string_imp.data s₂ }

/- Remark: this function has a VM builtin efficient implementation. -/

protected instance has_decidable_lt (s₁ : string) (s₂ : string) : Decidable (s₁ < s₂) :=
  list.has_decidable_lt (string_imp.data s₁) (string_imp.data s₂)

protected instance has_decidable_eq : DecidableEq string :=
  fun (_x : string) => sorry

def empty : string :=
  string_imp.mk []

def length : string → ℕ :=
  sorry

/- The internal implementation uses dynamic arrays and will perform destructive updates
   if the string is not shared. -/

def push : string → char → string :=
  sorry

/- The internal implementation uses dynamic arrays and will perform destructive updates
   if the string is not shared. -/

def append : string → string → string :=
  sorry

/- O(n) in the VM, where n is the length of the string -/

def to_list : string → List char :=
  sorry

def fold {α : Type u_1} (a : α) (f : α → char → α) (s : string) : α :=
  list.foldl f a (to_list s)

/- In the VM, the string iterator is implemented as a pointer to the string being iterated + index.

   TODO: we currently cannot mark interator_imp as private because
   we need to bind string_imp.mk and string_imp.cases_on in the VM.
-/

structure iterator_imp
where
  fst : List char
  snd : List char

def iterator :=
  iterator_imp

def mk_iterator : string → iterator :=
  sorry

namespace iterator

def curr : iterator → char :=
  sorry

/- In the VM, `set_curr` is constant time if the string being iterated is not shared and linear time
   if it is. -/

def set_curr : iterator → char → iterator :=
  sorry

def next : iterator → iterator :=
  sorry

def prev : iterator → iterator :=
  sorry

def has_next : iterator → Bool :=
  sorry

def has_prev : iterator → Bool :=
  sorry

def insert : iterator → string → iterator :=
  sorry

def remove : iterator → ℕ → iterator :=
  sorry

/- In the VM, `to_string` is a constant time operation. -/

def to_string : iterator → string :=
  sorry

def to_end : iterator → iterator :=
  sorry

def next_to_string : iterator → string :=
  sorry

def prev_to_string : iterator → string :=
  sorry

protected def extract_core : List char → List char → Option (List char) :=
  sorry

def extract : iterator → iterator → Option string :=
  sorry

end iterator

end string

/- The following definitions do not have builtin support in the VM -/

protected instance string.inhabited : Inhabited string :=
  { default := string.empty }

protected instance string.has_sizeof : SizeOf string :=
  { sizeOf := string.length }

protected instance string.has_append : Append string :=
  { append := string.append }

namespace string

def str : string → char → string :=
  push

def is_empty (s : string) : Bool :=
  to_bool (length s = 0)

def front (s : string) : char :=
  iterator.curr (mk_iterator s)

def back (s : string) : char :=
  iterator.curr (iterator.prev (iterator.to_end (mk_iterator s)))

def join (l : List string) : string :=
  list.foldl (fun (r s : string) => r ++ s) empty l

def singleton (c : char) : string :=
  push empty c

def intercalate (s : string) (ss : List string) : string :=
  list.as_string (list.intercalate (to_list s) (list.map to_list ss))

namespace iterator

def nextn : iterator → ℕ → iterator :=
  sorry

def prevn : iterator → ℕ → iterator :=
  sorry

end iterator

def pop_back (s : string) : string :=
  iterator.prev_to_string (iterator.prev (iterator.to_end (mk_iterator s)))

def popn_back (s : string) (n : ℕ) : string :=
  iterator.prev_to_string (iterator.prevn (iterator.to_end (mk_iterator s)) n)

def backn (s : string) (n : ℕ) : string :=
  iterator.next_to_string (iterator.prevn (iterator.to_end (mk_iterator s)) n)

end string

protected def char.to_string (c : char) : string :=
  string.singleton c

def string.to_nat (s : string) : ℕ :=
  to_nat_core (string.mk_iterator s) (string.length s) 0

namespace string

theorem empty_ne_str (c : char) (s : string) : empty ≠ str s c := sorry

theorem str_ne_empty (c : char) (s : string) : str s c ≠ empty :=
  ne.symm (empty_ne_str c s)

theorem str_ne_str_left {c₁ : char} {c₂ : char} (s₁ : string) (s₂ : string) : c₁ ≠ c₂ → str s₁ c₁ ≠ str s₂ c₂ := sorry

theorem str_ne_str_right (c₁ : char) (c₂ : char) {s₁ : string} {s₂ : string} : s₁ ≠ s₂ → str s₁ c₁ ≠ str s₂ c₂ := sorry


/-
Copyright (c) 2020 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Extra facts about `pprod`
-/

@[simp] theorem pprod.mk.eta {α : Sort u_1} {β : Sort u_2} {p : PProd α β} :
    { fst := pprod.fst p, snd := pprod.snd p } = p :=
  pprod.cases_on p fun (a : α) (b : β) => rfl

end Mathlib


/-
Copyright (c) 2020 Sebastian Ullrich. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sebastian Ullrich
-/

import Lean.PrettyPrinter.Delaborator.Basic
import Lean.Parser

namespace Lean.PrettyPrinter.Delaborator
open Lean.Meta
open Lean.Parser.Term

@[builtinDelab fvar]
def delabFVar : Delab := do
let Expr.fvar id _ ← getExpr | unreachable!
try
  let l ← getLocalDecl id
  pure $ mkIdent l.userName
catch _ =>
  -- loose free variable, use internal name
  pure $ mkIdent id

-- loose bound variable, use pseudo syntax
@[builtinDelab bvar]
def delabBVar : Delab := do
  let Expr.bvar idx _ ← getExpr | unreachable!
  pure $ mkIdent $ Name.mkSimple $ "#" ++ toString idx

@[builtinDelab mvar]
def delabMVar : Delab := do
  let Expr.mvar n _ ← getExpr | unreachable!
  let mvarDecl ← getMVarDecl n
  let n :=
    match mvarDecl.userName with
    | Name.anonymous => n.replacePrefix `_uniq `m
    | n => n
  `(?$(mkIdent n))

@[builtinDelab sort]
def delabSort : Delab := do
  let Expr.sort l _ ← getExpr | unreachable!
  match l with
  | Level.zero _ => `(Prop)
  | Level.succ (Level.zero _) _ => `(Type)
  | _ => match l.dec with
    | some l' => `(Type $(Level.quote l' max_prec))
    | none    => `(Sort $(Level.quote l max_prec))

-- find shorter names for constants, in reverse to Lean.Elab.ResolveName

private def unresolveQualifiedName (ns : Name) (c : Name) : DelabM Name := do
  let c' := c.replacePrefix ns Name.anonymous;
  let env ← getEnv
  guard $ c' != c && !c'.isAnonymous && (!c'.isAtomic || !isProtected env c)
  pure c'

private def unresolveUsingNamespace (c : Name) : Name → DelabM Name
  | ns@(Name.str p _ _) => unresolveQualifiedName ns c <|> unresolveUsingNamespace c p
  | _ => failure

private def unresolveOpenDecls (c : Name) : List OpenDecl → DelabM Name
  | [] => failure
  | OpenDecl.simple ns exs :: openDecls =>
    let c' := c.replacePrefix ns Name.anonymous
    if c' != c && exs.elem c' then unresolveOpenDecls c openDecls
    else
      unresolveQualifiedName ns c <|> unresolveOpenDecls c openDecls
  | OpenDecl.explicit openedId resolvedId :: openDecls =>
    guard (c == resolvedId) *> pure openedId <|> unresolveOpenDecls c openDecls

-- NOTE: not a registered delaborator, as `const` is never called (see [delab] description)
def delabConst : Delab := do
  let Expr.const c ls _ ← getExpr | unreachable!
  let c₀ := c
  let mut c ← if (← getPPOption getPPFullNames) then pure c else
    let ctx ← read
    let env ← getEnv
    let as := getRevAliases env c
    -- might want to use a more clever heuristic such as selecting the shortest alias...
    let c := as.headD c
    unresolveUsingNamespace c ctx.currNamespace <|> unresolveOpenDecls c ctx.openDecls <|> pure c
  unless (← getPPOption getPPPrivateNames) do
    c := (privateToUserName? c).getD c
  let ppUnivs ← getPPOption getPPUniverses
  if ls.isEmpty || !ppUnivs then
    if (← getLCtx).usesUserName c then
      -- `c` is also a local declaration
      if c == c₀ then
        -- `c` is the fully qualified named. So, we append the `_root_` prefix
        c := `_root_ ++ c
      else
        c := c₀
    return mkIdent c
  else
    `($(mkIdent c).{$[$(ls.toArray.map quote)],*})

inductive ParamKind where
  | explicit
  -- combines implicit params, optParams, and autoParams
  | implicit (defVal : Option Expr)

/-- Return array with n-th element set to kind of n-th parameter of `e`. -/
def getParamKinds (e : Expr) : MetaM (Array ParamKind) := do
  let t ← inferType e
  forallTelescopeReducing t fun params _ =>
    params.mapM fun param => do
      let l ← getLocalDecl param.fvarId!
      match l.type.getOptParamDefault? with
      | some val => pure $ ParamKind.implicit val
      | _ =>
        if l.type.isAutoParam || !l.binderInfo.isExplicit then
          pure $ ParamKind.implicit none
        else
          pure ParamKind.explicit

@[builtinDelab app]
def delabAppExplicit : Delab := do
  let (fnStx, argStxs) ← withAppFnArgs
    (do
      let fn ← getExpr
      let stx ← if fn.isConst then delabConst else delab
      let paramKinds ← liftM <| getParamKinds fn <|> pure #[]
      let stx ← if paramKinds.any (fun | ParamKind.explicit => false | _ => true) then `(@$stx) else pure stx
      pure (stx, #[]))
    (fun ⟨fnStx, argStxs⟩ => do
      let argStx ← delab
      pure (fnStx, argStxs.push argStx))
  Syntax.mkApp fnStx argStxs

@[builtinDelab app]
def delabAppImplicit : Delab := whenNotPPOption getPPExplicit do
  let (fnStx, _, argStxs) ← withAppFnArgs
    (do
      let fn ← getExpr
      let stx ← if fn.isConst then delabConst else delab
      let paramKinds ← liftM (getParamKinds fn <|> pure #[])
      pure (stx, paramKinds.toList, #[]))
    (fun (fnStx, paramKinds, argStxs) => do
      let arg ← getExpr;
      let implicit : Bool := match paramKinds with -- TODO: check why we need `: Bool` here
        | [ParamKind.implicit (some v)] => !v.hasLooseBVars && v == arg
        | ParamKind.implicit none :: _  => true
        | _                             => false
      if implicit then
        pure (fnStx, paramKinds.tailD [], argStxs)
      else do
        let argStx ← delab
        pure (fnStx, paramKinds.tailD [], argStxs.push argStx))
  Syntax.mkApp fnStx argStxs

@[builtinDelab app]
def delabAppWithUnexpander : Delab := whenPPOption getPPNotation do
  let Expr.const c _ _ ← pure (← getExpr).getAppFn | failure
  let stx ← delabAppImplicit
  match stx with
  | `($cPP:ident $args*) => do go c stx
  | `($cPP:ident) => do go c stx
  | _ => pure stx
where
  go c stx := do
    let some (f::_) ← pure <| (appUnexpanderAttribute.ext.getState (← getEnv)).table.find? c
      | pure stx
    let EStateM.Result.ok stx _ ← f stx |>.run ()
      | pure stx
    pure stx

/-- State for `delabAppMatch` and helpers. -/
structure AppMatchState where
  info      : MatcherInfo
  matcherTy : Expr
  params    : Array Expr := #[]
  hasMotive : Bool := false
  discrs    : Array Syntax := #[]
  varNames  : Array (Array Name) := #[]
  rhss      : Array Syntax := #[]
  -- additional arguments applied to the result of the `match` expression
  moreArgs  : Array Syntax := #[]
/--
  Extract arguments of motive applications from the matcher type.
  For the example below: `#[#[`([])], #[`(a::as)]]` -/
private partial def delabPatterns (st : AppMatchState) : DelabM (Array (Array Syntax)) :=
  withReader (fun ctx => { ctx with inPattern := true }) do
    let ty ← instantiateForall st.matcherTy st.params
    forallTelescope ty fun params _ => do
      -- skip motive and discriminators
      let alts := Array.ofSubarray $ params[1 + st.discrs.size:]
      alts.mapIdxM fun idx alt => do
        let ty ← inferType alt
        withReader ({ · with expr := ty }) $
          usingNames st.varNames[idx] do
            withAppFnArgs (pure #[]) (fun pats => do pure $ pats.push (← delab))
where
  usingNames {α} (varNames : Array Name) (x : DelabM α) : DelabM α :=
    usingNamesAux 0 varNames x
  usingNamesAux {α} (i : Nat) (varNames : Array Name) (x : DelabM α) : DelabM α :=
    if i < varNames.size then
      withBindingBody varNames[i] <| usingNamesAux (i+1) varNames x
    else
      x

/-- Skip `numParams` binders, and execute `x varNames` where `varNames` contains the new binder names. -/
private def skippingBinders {α} (numParams : Nat) (x : Array Name → DelabM α) : DelabM α :=
  loop numParams #[]
where
  loop : Nat → Array Name → DelabM α
    | 0,   varNames => x varNames
    | n+1, varNames => do
      let varName ← (← getExpr).bindingName!.eraseMacroScopes
      -- Pattern variables cannot shadow each other
      if varNames.contains varName then
        let varName := (← getLCtx).getUnusedName varName
        withBindingBody varName do
          loop n (varNames.push varName)
      else
        withBindingBodyUnusedName fun id => do
          loop n (varNames.push id.getId)

/--
  Delaborate applications of "matchers" such as
  ```
  List.map.match_1 : {α : Type _} →
    (motive : List α → Sort _) →
      (x : List α) → (Unit → motive List.nil) → ((a : α) → (as : List α) → motive (a :: as)) → motive x
  ```
-/
@[builtinDelab app]
def delabAppMatch : Delab := whenPPOption getPPNotation do
  -- incrementally fill `AppMatchState` from arguments
  let st ← withAppFnArgs
    (do
      let (Expr.const c us _) ← getExpr | failure
      let (some info) ← getMatcherInfo? c | failure
      { matcherTy := (← getConstInfo c).instantiateTypeLevelParams us, info := info : AppMatchState })
    (fun st => do
      if st.params.size < st.info.numParams then
        pure { st with params := st.params.push (← getExpr) }
      else if !st.hasMotive then
        -- discard motive argument
        pure { st with hasMotive := true }
      else if st.discrs.size < st.info.numDiscrs then
        pure { st with discrs := st.discrs.push (← delab) }
      else if st.rhss.size < st.info.altNumParams.size then
        /- We save the variables names here to be able to implement safe_shadowing.
           The pattern delaboration must use the names saved here. -/
        let (varNames, rhs) ← skippingBinders st.info.altNumParams[st.rhss.size] fun varNames => do
          let rhs ← delab
          return (varNames, rhs)
        pure { st with rhss := st.rhss.push rhs, varNames := st.varNames.push varNames }
      else
        pure { st with moreArgs := st.moreArgs.push (← delab) })

  if st.discrs.size < st.info.numDiscrs || st.rhss.size < st.info.altNumParams.size then
    -- underapplied
    failure

  match st.discrs, st.rhss with
  | #[discr], #[] =>
    let stx ← `(nomatch $discr)
    Syntax.mkApp stx st.moreArgs
  | _,        #[] => failure
  | _,        _   =>
    let pats ← delabPatterns st
    let stx ← `(match $[$st.discrs:term],* with $[| $pats,* => $st.rhss]*)
    Syntax.mkApp stx st.moreArgs

@[builtinDelab mdata]
def delabMData : Delab := do
  if let some _ := Lean.Meta.Match.inaccessible? (← getExpr) then
    let s ← withMDataExpr delab
    if (← read).inPattern then
      `(.($s)) -- We only include the inaccessible annotation when we are delaborating patterns
    else
      return s
  else
    -- only interpret `pp.` values by default
    let Expr.mdata m _ _ ← getExpr | unreachable!
    let mut posOpts := (← read).optionsPerPos
    let pos := (← read).pos
    for (k, v) in m do
      if (`pp).isPrefixOf k then
        let opts := posOpts.find? pos |>.getD {}
        posOpts := posOpts.insert pos (opts.insert k v)
    withReader ({ · with optionsPerPos := posOpts }) do
      withMDataExpr delab

/--
Check for a `Syntax.ident` of the given name anywhere in the tree.
This is usually a bad idea since it does not check for shadowing bindings,
but in the delaborator we assume that bindings are never shadowed.
-/
partial def hasIdent (id : Name) : Syntax → Bool
  | Syntax.ident _ _ id' _ => id == id'
  | Syntax.node _ args     => args.any (hasIdent id)
  | _                      => false

/--
Return `true` iff current binder should be merged with the nested
binder, if any, into a single binder group:
* both binders must have same binder info and domain
* they cannot be inst-implicit (`[a b : A]` is not valid syntax)
* `pp.binder_types` must be the same value for both terms
* prefer `fun a b` over `fun (a b)`
-/
private def shouldGroupWithNext : DelabM Bool := do
  let e ← getExpr
  let ppEType ← getPPOption getPPBinderTypes;
  let go (e' : Expr) := do
    let ppE'Type ← withBindingBody `_ $ getPPOption getPPBinderTypes
    pure $ e.binderInfo == e'.binderInfo &&
      e.bindingDomain! == e'.bindingDomain! &&
      e'.binderInfo != BinderInfo.instImplicit &&
      ppEType == ppE'Type &&
      (e'.binderInfo != BinderInfo.default || ppE'Type)
  match e with
  | Expr.lam _ _     e'@(Expr.lam _ _ _ _) _     => go e'
  | Expr.forallE _ _ e'@(Expr.forallE _ _ _ _) _ => go e'
  | _ => pure false

private partial def delabBinders (delabGroup : Array Syntax → Syntax → Delab) : optParam (Array Syntax) #[] → Delab
  -- Accumulate names (`Syntax.ident`s with position information) of the current, unfinished
  -- binder group `(d e ...)` as determined by `shouldGroupWithNext`. We cannot do grouping
  -- inside-out, on the Syntax level, because it depends on comparing the Expr binder types.
  | curNames => do
    if (← shouldGroupWithNext) then
      -- group with nested binder => recurse immediately
      withBindingBodyUnusedName fun stxN => delabBinders delabGroup (curNames.push stxN)
    else
      -- don't group => delab body and prepend current binder group
      let (stx, stxN) ← withBindingBodyUnusedName fun stxN => do (← delab, stxN)
      delabGroup (curNames.push stxN) stx

@[builtinDelab lam]
def delabLam : Delab :=
  delabBinders fun curNames stxBody => do
    let e ← getExpr
    let stxT ← withBindingDomain delab
    let ppTypes ← getPPOption getPPBinderTypes
    let expl ← getPPOption getPPExplicit
    -- leave lambda implicit if possible
    let blockImplicitLambda := expl ||
      e.binderInfo == BinderInfo.default ||
      Elab.Term.blockImplicitLambda stxBody ||
      curNames.any (fun n => hasIdent n.getId stxBody);
    if !blockImplicitLambda then
      pure stxBody
    else
      let group ← match e.binderInfo, ppTypes with
        | BinderInfo.default,     true   =>
          -- "default" binder group is the only one that expects binder names
          -- as a term, i.e. a single `Syntax.ident` or an application thereof
          let stxCurNames ←
            if curNames.size > 1 then
              `($(curNames.get! 0) $(curNames.eraseIdx 0)*)
            else
              pure $ curNames.get! 0;
          `(funBinder| ($stxCurNames : $stxT))
        | BinderInfo.default,     false  => pure curNames.back  -- here `curNames.size == 1`
        | BinderInfo.implicit,    true   => `(funBinder| {$curNames* : $stxT})
        | BinderInfo.implicit,    false  => `(funBinder| {$curNames*})
        | BinderInfo.instImplicit, _     => `(funBinder| [$curNames.back : $stxT])  -- here `curNames.size == 1`
        | _                      , _     => unreachable!;
      match stxBody with
      | `(fun $binderGroups* => $stxBody) => `(fun $group $binderGroups* => $stxBody)
      | _                                 => `(fun $group => $stxBody)

@[builtinDelab forallE]
def delabForall : Delab :=
  delabBinders fun curNames stxBody => do
    let e ← getExpr
    let prop ← try isProp e catch _ => false
    let stxT ← withBindingDomain delab
    let group ← match e.binderInfo with
    | BinderInfo.implicit     => `(bracketedBinderF|{$curNames* : $stxT})
    -- here `curNames.size == 1`
    | BinderInfo.instImplicit => `(bracketedBinderF|[$curNames.back : $stxT])
    | _                       =>
      -- heuristic: use non-dependent arrows only if possible for whole group to avoid
      -- noisy mix like `(α : Type) → Type → (γ : Type) → ...`.
      let dependent := curNames.any $ fun n => hasIdent n.getId stxBody
      -- NOTE: non-dependent arrows are available only for the default binder info
      if dependent then
        if prop && !(← getPPOption getPPBinderTypes) then
          return ← `(∀ $curNames:ident*, $stxBody)
        else
          `(bracketedBinderF|($curNames* : $stxT))
      else
        return ← curNames.foldrM (fun _ stxBody => `($stxT → $stxBody)) stxBody
    if prop then
      match stxBody with
      | `(∀ $groups*, $stxBody) => `(∀ $group $groups*, $stxBody)
      | _                       => `(∀ $group, $stxBody)
    else
      `($group:bracketedBinder → $stxBody)

@[builtinDelab letE]
def delabLetE : Delab := do
  let Expr.letE n t v b _ ← getExpr | unreachable!
  let n ← getUnusedName n b
  let stxT ← descend t 0 delab
  let stxV ← descend v 1 delab
  let stxB ← withLetDecl n t v fun fvar =>
    let b := b.instantiate1 fvar
    descend b 2 delab
  `(let $(mkIdent n) : $stxT := $stxV; $stxB)

@[builtinDelab lit]
def delabLit : Delab := do
  let Expr.lit l _ ← getExpr | unreachable!
  match l with
  | Literal.natVal n => pure $ quote n
  | Literal.strVal s => pure $ quote s

-- `@OfNat.ofNat _ n _` ~> `n`
@[builtinDelab app.OfNat.ofNat]
def delabOfNat : Delab := whenPPOption getPPCoercions do
  let (Expr.app (Expr.app _ (Expr.lit (Literal.natVal n) _) _) _ _) ← getExpr | failure
  return quote n

-- `@OfDecimal.ofDecimal _ _ m s e` ~> `m*10^(sign * e)` where `sign == 1` if `s = false` and `sign = -1` if `s = true`
@[builtinDelab app.OfScientific.ofScientific]
def delabOfScientific : Delab := whenPPOption getPPCoercions do
  let expr ← getExpr
  guard <| expr.getAppNumArgs == 5
  let Expr.lit (Literal.natVal m) _ ← pure (expr.getArg! 2) | failure
  let Expr.lit (Literal.natVal e) _ ← pure (expr.getArg! 4) | failure
  let s ← match expr.getArg! 3 with
    | Expr.const `Bool.true _ _  => pure true
    | Expr.const `Bool.false _ _ => pure false
    | _ => failure
  let str  := toString m
  if s && e == str.length then
    return Syntax.mkScientificLit ("0." ++ str)
  else if s && e < str.length then
    let mStr := str.extract 0 (str.length - e)
    let eStr := str.extract (str.length - e) str.length
    return Syntax.mkScientificLit (mStr ++ "." ++ eStr)
  else
    return Syntax.mkScientificLit (str ++ "e" ++ (if s then "-" else "") ++ toString e)

/--
Delaborate a projection primitive. These do not usually occur in
user code, but are pretty-printed when e.g. `#print`ing a projection
function.
-/
@[builtinDelab proj]
def delabProj : Delab := do
  let Expr.proj _ idx _ _ ← getExpr | unreachable!
  let e ← withProj delab
  -- not perfectly authentic: elaborates to the `idx`-th named projection
  -- function (e.g. `e.1` is `Prod.fst e`), which unfolds to the actual
  -- `proj`.
  let idx := Syntax.mkLit fieldIdxKind (toString (idx + 1));
  `($(e).$idx:fieldIdx)

/-- Delaborate a call to a projection function such as `Prod.fst`. -/
@[builtinDelab app]
def delabProjectionApp : Delab := whenPPOption getPPStructureProjections $ do
  let e@(Expr.app fn _ _) ← getExpr | failure
  let Expr.const c@(Name.str _ f _) _ _ ← pure fn.getAppFn | failure
  let env ← getEnv
  let some info ← pure $ env.getProjectionFnInfo? c | failure
  -- can't use with classes since the instance parameter is implicit
  guard $ !info.fromClass
  -- projection function should be fully applied (#struct params + 1 instance parameter)
  -- TODO: support over-application
  guard $ e.getAppNumArgs == info.nparams + 1
  -- If pp.explicit is true, and the structure has parameters, we should not
  -- use field notation because we will not be able to see the parameters.
  let expl ← getPPOption getPPExplicit
  guard $ !expl || info.nparams == 0
  let appStx ← withAppArg delab
  `($(appStx).$(mkIdent f):ident)

@[builtinDelab app]
def delabStructureInstance : Delab := whenPPOption getPPStructureInstances do
  let env ← getEnv
  let e ← getExpr
  let some s ← pure $ e.isConstructorApp? env | failure
  guard $ isStructure env s.induct;
  /- If implicit arguments should be shown, and the structure has parameters, we should not
     pretty print using { ... }, because we will not be able to see the parameters. -/
  let explicit ← getPPOption getPPExplicit
  guard !(explicit && s.numParams > 0)
  let fieldNames := getStructureFields env s.induct
  let (_, fields) ← withAppFnArgs (pure (0, #[])) fun ⟨idx, fields⟩ => do
      if idx < s.numParams then
        pure (idx + 1, fields)
      else
        let val ← delab
        let field ← `(structInstField|$(mkIdent <| fieldNames.get! (idx - s.numParams)):ident := $val)
        pure (idx + 1, fields.push field)
  let lastField := fields[fields.size - 1]
  let fields := fields.pop
  let ty ←
    if (← getPPOption getPPStructureInstanceType) then
      let ty ← inferType e
      -- `ty` is not actually part of `e`, but since `e` must be an application or constant, we know that
      -- index 2 is unused.
      pure <| some (← descend ty 2 delab)
    else pure <| none
  `({ $[$fields, ]* $lastField $[: $ty]? })

@[builtinDelab app.Prod.mk]
def delabTuple : Delab := whenPPOption getPPNotation do
  let e ← getExpr
  guard $ e.getAppNumArgs == 4
  let a ← withAppFn $ withAppArg delab
  let b ← withAppArg delab
  match b with
  | `(($b, $bs,*)) => `(($a, $b, $bs,*))
  | _              => `(($a, $b))

-- abbrev coe {α : Sort u} {β : Sort v} (a : α) [CoeT α a β] : β
@[builtinDelab app.coe]
def delabCoe : Delab := whenPPOption getPPCoercions do
  let e ← getExpr
  guard $ e.getAppNumArgs >= 4
  -- delab as application, then discard function
  let stx ← delabAppImplicit
  match stx with
  | `($fn $arg)   => arg
  | `($fn $args*) => `($(args.get! 0) $(args.eraseIdx 0)*)
  | _             => failure

-- abbrev coeFun {α : Sort u} {γ : α → Sort v} (a : α) [CoeFun α γ] : γ a
@[builtinDelab app.coeFun]
def delabCoeFun : Delab := delabCoe

@[builtinDelab app.List.nil]
def delabNil : Delab := whenPPOption getPPNotation do
  guard $ (← getExpr).getAppNumArgs == 1
  `([])

@[builtinDelab app.List.cons]
def delabConsList : Delab := whenPPOption getPPNotation do
  guard $ (← getExpr).getAppNumArgs == 3
  let x ← withAppFn (withAppArg delab)
  match (← withAppArg delab) with
  | `([])      => `([$x])
  | `([$xs,*]) => `([$x, $xs,*])
  | _          => failure

@[builtinDelab app.List.toArray]
def delabListToArray : Delab := whenPPOption getPPNotation do
  guard $ (← getExpr).getAppNumArgs == 2
  match (← withAppArg delab) with
  | `([$xs,*]) => `(#[$xs,*])
  | _         => failure

@[builtinDelab app.ite]
def delabIte : Delab := whenPPOption getPPNotation do
  guard $ (← getExpr).getAppNumArgs == 5
  let c ← withAppFn $ withAppFn $ withAppFn $ withAppArg delab
  let t ← withAppFn $ withAppArg delab
  let e ← withAppArg delab
  `(if $c then $t else $e)

@[builtinDelab app.dite]
def delabDIte : Delab := whenPPOption getPPNotation do
  guard $ (← getExpr).getAppNumArgs == 5
  let c ← withAppFn $ withAppFn $ withAppFn $ withAppArg delab
  let (t, h) ← withAppFn $ withAppArg $ delabBranch none
  let (e, _) ← withAppArg $ delabBranch h
  `(if $(mkIdent h):ident : $c then $t else $e)
where
  delabBranch (h? : Option Name) : DelabM (Syntax × Name) := do
    let e ← getExpr
    guard e.isLambda
    let h ← match h? with
      | some h => return (← withBindingBody h delab, h)
      | none   => withBindingBodyUnusedName fun h => do
        return (← delab, h.getId)

@[builtinDelab app.namedPattern]
def delabNamedPattern : Delab := do
  guard $ (← getExpr).getAppNumArgs == 3
  let x ← withAppFn $ withAppArg delab
  let p ← withAppArg delab
  guard x.isIdent
  `($x:ident@$p:term)

partial def delabDoElems : DelabM (List Syntax) := do
  let e ← getExpr
  if e.isAppOfArity `Bind.bind 6 then
    -- Bind.bind.{u, v} : {m : Type u → Type v} → [self : Bind m] → {α β : Type u} → m α → (α → m β) → m β
    let ma ← withAppFn $ withAppArg delab
    withAppArg do
      match (← getExpr) with
      | Expr.lam _ _ body _ =>
        withBindingBodyUnusedName fun n => do
          if body.hasLooseBVars then
            prependAndRec `(doElem|let $n:term ← $ma)
          else
            prependAndRec `(doElem|$ma:term)
      | _ => failure
  else if e.isLet then
    let Expr.letE n t v b _ ← getExpr | unreachable!
    let n ← getUnusedName n b
    let stxT ← descend t 0 delab
    let stxV ← descend v 1 delab
    withLetDecl n t v fun fvar =>
      let b := b.instantiate1 fvar
      descend b 2 $
        prependAndRec `(doElem|let $(mkIdent n) : $stxT := $stxV)
  else
    let stx ← delab
    [←`(doElem|$stx:term)]
  where
    prependAndRec x : DelabM _ := List.cons <$> x <*> delabDoElems

@[builtinDelab app.Bind.bind]
def delabDo : Delab := whenPPOption getPPNotation do
  guard <| (← getExpr).isAppOfArity `Bind.bind 6
  let elems ← delabDoElems
  let items ← elems.toArray.mapM (`(doSeqItem|$(·):doElem))
  `(do $items:doSeqItem*)

@[builtinDelab app.sorryAx]
def delabSorryAx : Delab := whenPPOption getPPNotation do
  guard <| (← getExpr).isAppOfArity ``sorryAx 2
  `(sorry)

@[builtinDelab app.Eq.ndrec]
def delabEqNDRec : Delab := whenPPOption getPPNotation do
  guard <| (← getExpr).getAppNumArgs == 6
  -- Eq.ndrec.{u1, u2} : {α : Sort u2} → {a : α} → {motive : α → Sort u1} → (m : motive a) → {b : α} → (h : a = b) → motive b
  let m ← withAppFn <| withAppFn <| withAppArg delab
  let h ← withAppArg delab
  `($h ▸ $m)

@[builtinDelab app.Eq.rec]
def delabEqRec : Delab :=
  -- relevant signature parts as in `Eq.ndrec`
  delabEqNDRec

def reifyName : Expr → DelabM Name
  | Expr.const ``Lean.Name.anonymous .. => Name.anonymous
  | Expr.app (Expr.app (Expr.const ``Lean.Name.mkStr ..) n _) (Expr.lit (Literal.strVal s) _) _ => do
    (← reifyName n).mkStr s
  | Expr.app (Expr.app (Expr.const ``Lean.Name.mkNum ..) n _) (Expr.lit (Literal.natVal i) _) _ => do
    (← reifyName n).mkNum i
  | _ => failure

@[builtinDelab app.Lean.Name.mkStr]
def delabNameMkStr : Delab := whenPPOption getPPNotation do
  let n ← reifyName (← getExpr)
  -- not guaranteed to be a syntactically valid name, but usually more helpful than the explicit version
  mkNode ``Lean.Parser.Term.quotedName #[Syntax.mkNameLit s!"`{n}"]

@[builtinDelab app.Lean.Name.mkNum]
def delabNameMkNum : Delab := delabNameMkStr

end Lean.PrettyPrinter.Delaborator


import tactic.interactive

example (b : bool) (h : b = tt) : true :=
begin
  let b₁ : bool := b,
  /-
  This test shows that `tactic.revert_target_deps`
  will revert `b₁` because it occurse in the `have` statement below,
  but recursively also reverts `b` (and hence `h`),
  because `b` occurs in the body of the `let` statement that introduces `b₁`,
  even though `b` doesn't occur directly in the `have` statement below.
  -/
  have : ∀ b₂ : bool, b₂ ≠ b₁ → b₂ = ff,
  { revert_target_deps,
    tactic.interactive.guard_target
      ``(∀ (b : bool), b = tt → (let b₁ : bool := b in ∀ (b₂ : bool), b₂ ≠ b₁ → b₂ = ff)),
    exact dec_trivial },
  trivial
end


import tactic.linarith
import category_theory.shift
import algebra.homology.homological_complex
import algebra.homology.homotopy_category
import for_mathlib.category_theory.quotient_shift
import for_mathlib.algebra.homology.hom_complex
import for_mathlib.category_theory.shift_misc

noncomputable theory

open category_theory category_theory.category category_theory.limits

variables (C : Type*) [category C] [preadditive C]

namespace cochain_complex

open homological_complex

local attribute [simp] X_iso_of_eq_hom_naturality X_iso_of_eq_inv_naturality

@[simps obj_d map_f]
def shift_functor (n : ℤ) : cochain_complex C ℤ ⥤ cochain_complex C ℤ :=
{ obj := λ K,
  { X := λ i, K.X (i+n),
    d := λ i j, cochain_complex.hom_complex.ε n • K.d _ _,
    shape' := λ i j hij, begin
      rw [K.shape, smul_zero],
      intro hij',
      apply hij,
      dsimp [complex_shape.up] at hij' ⊢,
      linarith,
    end, },
  map := λ K₁ K₂ φ,
  { f := λ i, φ.f _, }, }

variable {C}

@[simp]
lemma X_iso_of_eq_of_shift_functor (K : cochain_complex C ℤ) (n : ℤ) {i i' : ℤ} (h : i = i') :
  ((shift_functor C n).obj K).X_iso_of_eq h = K.X_iso_of_eq (by subst h) := rfl

@[simp]
def shift_functor_obj_X_iso (K : cochain_complex C ℤ) (n i m : ℤ) (hm : m = i + n) :
  ((shift_functor C n).obj K).X i ≅ K.X m :=
X_iso_of_eq K hm.symm

variable (C)

@[simp]
def shift_functor_congr {n n' : ℤ} (h : n = n') :
  shift_functor C n ≅ shift_functor C n' :=
nat_iso.of_components
  (λ K, hom.iso_of_components (λ i, K.X_iso_of_eq (by subst h))
  (λ i j hij, by { dsimp, simp [h], })) (λ K₁ K₂ φ, by { ext, dsimp, simp, })

@[simps]
def shift_functor_zero' (n : ℤ) (h : n = 0) :
  shift_functor C n ≅ 𝟭 _ :=
nat_iso.of_components (λ K, hom.iso_of_components
  (λ i, K.shift_functor_obj_X_iso _ _ _ (by linarith))
    (by { subst h, tidy, })) (by tidy)

@[simps]
def shift_functor_add' (n₁ n₂ n₁₂ : ℤ) (h : n₁₂ = n₁ + n₂) :
  shift_functor C n₁ ⋙ shift_functor C n₂ ≅ shift_functor C n₁₂ :=
nat_iso.of_components
  (λ K, hom.iso_of_components (λ i, K.X_iso_of_eq (by linarith))
  (λ i j hij, begin
    subst h,
    dsimp,
    simp only [linear.comp_smul, X_iso_of_eq_hom_comp_d, linear.smul_comp,
      d_comp_X_iso_of_eq_hom, ← mul_smul, ← cochain_complex.hom_complex.ε_add, add_comm n₁],
  end)) (by tidy)

instance : has_shift (cochain_complex C ℤ) ℤ :=
has_shift_mk _ _
{ F := shift_functor C,
  ε := (shift_functor_zero' C _ rfl).symm,
  μ := λ n₁ n₂, shift_functor_add' C n₁ n₂ _ rfl,
  associativity := λ n₁ n₂ n₃ K, by { ext i, dsimp [X_iso_of_eq], simp, }, }

variable {C}

@[simp]
lemma shift_functor_map_f' {K L : cochain_complex C ℤ} (φ : K ⟶ L) (n p : ℤ) :
  ((category_theory.shift_functor (cochain_complex C ℤ) n).map φ).f p = φ.f (p+n) := rfl

@[simp]
lemma shift_functor_obj_d' (K : cochain_complex C ℤ) (n i j : ℤ) :
  ((category_theory.shift_functor (cochain_complex C ℤ) n).obj K).d i j =
    cochain_complex.hom_complex.ε n • K.d _ _ := rfl

lemma shift_functor_add_inv_app_f (K : cochain_complex C ℤ) (a b n : ℤ) :
  ((shift_functor_add (cochain_complex C ℤ) a b).inv.app K : _ ⟶ _).f n =
    (K.X_iso_of_eq (by { dsimp, rw [add_comm a, add_assoc],})).hom := rfl

lemma shift_functor_add_hom_app_f (K : cochain_complex C ℤ) (a b n : ℤ) :
  ((shift_functor_add (cochain_complex C ℤ) a b).hom.app K : _ ⟶ _).f n =
    (K.X_iso_of_eq (by { dsimp, rw [add_comm a, add_assoc],})).inv :=
begin
  haveI : is_iso (((shift_functor_add (cochain_complex C ℤ) a b).inv.app K : _ ⟶ _).f n),
  { rw shift_functor_add_inv_app_f,
    apply_instance, },
  rw [← cancel_mono (((shift_functor_add (cochain_complex C ℤ) a b).inv.app K : _ ⟶ _).f n),
    ← homological_complex.comp_f, iso.hom_inv_id_app, homological_complex.id_f,
    shift_functor_add_inv_app_f, iso.inv_hom_id],
end

lemma shift_functor_add_comm_hom_app_f (K : cochain_complex C ℤ) (a b n : ℤ) :
  ((shift_functor_add_comm (cochain_complex C ℤ) a b).hom.app K : _ ⟶ _).f n =
    (K.X_iso_of_eq (by { dsimp, simp only [add_assoc, add_comm a], })).hom :=
begin
  dsimp only [shift_functor_add_comm, iso.trans, iso.symm],
  simpa only [nat_trans.comp_app, homological_complex.comp_f,
    shift_functor_add_hom_app_f, shift_functor_add_inv_app_f,
    homological_complex.X_iso_of_eq, eq_to_iso.inv, eq_to_iso.hom, eq_to_hom_app,
    homological_complex.eq_to_hom_f, eq_to_hom_trans],
end

variable (C)

lemma shift_functor_add'_eq (a b c : ℤ) (h : c = a + b) :
  category_theory.shift_functor_add' (cochain_complex C ℤ) a b c h =
    (shift_functor_add' C a b c h).symm :=
begin
  subst h,
  dsimp only [category_theory.shift_functor_add'],
  ext K n,
  dsimp only [iso.trans, shift_functor_add', nat_iso.of_components,
    nat_trans.comp_app, homological_complex.comp_f, hom.iso_of_components],
  simp only [eq_to_hom_app, eq_to_hom_f, shift_functor_add_hom_app_f,
    X_iso_of_eq, eq_to_iso, eq_to_hom_trans, eq_to_hom_refl, nat_trans.id_app,
    homological_complex.id_f, id_comp],
end

lemma shift_functor_add_eq (a b : ℤ) :
  category_theory.shift_functor_add (cochain_complex C ℤ) a b =
    (shift_functor_add' C a b _ rfl).symm :=
begin
  ext1,
  rw ← shift_functor_add'_eq,
  dsimp [category_theory.shift_functor_add'],
  rw id_comp,
end

lemma shift_functor_zero_eq  :
  (category_theory.shift_functor_zero (cochain_complex C ℤ) ℤ) =
    (shift_functor_zero' C 0 rfl) :=
begin
  change (category_theory.shift_functor_zero (cochain_complex C ℤ) ℤ).symm.symm =
    (shift_functor_zero' C 0 rfl).symm.symm,
  congr' 1,
  ext1,
  refl,
end

variables {C} {D : Type*} [category D] (F : C ⥤ D) [preadditive D] [functor.additive F]

def map_cochain_complex_shift_iso (n : ℤ) :
  shift_functor C n ⋙ F.map_homological_complex (complex_shape.up ℤ) ≅
    F.map_homological_complex (complex_shape.up ℤ) ⋙ shift_functor D n :=
nat_iso.of_components (λ K, hom.iso_of_components (λ i, iso.refl _)
  (λ i j hij, by { dsimp, rw [id_comp, comp_id, functor.map_zsmul], })) (by tidy)

instance map_cochain_complex_has_comm_shift :
  (functor.map_homological_complex F (complex_shape.up ℤ)).has_comm_shift ℤ :=
{ iso := λ n, map_cochain_complex_shift_iso F n,
  iso_zero := begin
    ext K i,
    rw [functor.comm_shift.unit_hom_app, comp_f,
      functor.map_homological_complex_map_f, shift_functor_zero_eq,
      shift_functor_zero_eq,
      shift_functor_zero'_hom_app_f, shift_functor_zero'_inv_app_f],
    dsimp [X_iso_of_eq],
    simpa only [eq_to_hom_map, eq_to_hom_trans],
  end,
  iso_add := λ a b, begin
    ext K i,
    simp only [functor.comm_shift.add_hom_app, comp_f, iso.symm_inv,
      functor.map_homological_complex_map_f, shift_functor_add_eq, iso.symm_hom,
        shift_functor_add'_inv_app_f, shift_functor_add'_hom_app_f,
        shift_functor_map_f'],
    dsimp [map_cochain_complex_shift_iso, iso.refl,
      X_iso_of_eq],
    erw [eq_to_hom_map, id_comp, id_comp, eq_to_hom_trans, eq_to_hom_refl],
  end, }

end cochain_complex


import Mathlib.Tactic.ClearExcept

-- Most basic test
example (_delete_this : Nat) (dont_delete_this : Int) : Nat := by
  clear * - dont_delete_this
  fail_if_success assumption
  exact dont_delete_this.toNat

-- Confirms that clearExcept does not delete class instances
example [dont_delete_this : Inhabited Nat] (dont_delete_this2 : Prop) : Inhabited Nat := by
  clear * - dont_delete_this2
  assumption

-- Confirms that clearExcept can clear hypotheses even when they have dependencies
example (delete_this : Nat) (_delete_this2 : delete_this = delete_this) (dont_delete_this : Int) : Nat := by
  clear * - dont_delete_this
  fail_if_success assumption
  exact dont_delete_this.toNat

-- Confirms that clearExcept does not clear hypotheses when they have dependencies that should not be cleared
example (dont_delete_this : Nat) (dont_delete_this2 : dont_delete_this = dont_delete_this) : Nat := by
  clear * - dont_delete_this2
  exact dont_delete_this

-- Confirms that clearExcept can preserve multiple identifiers
example (_delete_this : Nat) (dont_delete_this : Int) (dont_delete_this2 : Int) : Nat := by
  clear * - dont_delete_this dont_delete_this2
  fail_if_success assumption
  exact dont_delete_this.toNat + dont_delete_this2.toNat


class foo (F : Type) where
  foo : F

class foobar (F : outParam Type) [foo F] where
  bar : F

class C (α : Type) where
  val : α

class D (α : Type) (β : outParam Type) [C β] where
  val1 : α
  val2 : β := C.val

instance : C String where
  val := "hello"

instance : C Nat where
  val := 42

instance : D Nat String where
  val1 := 37

def f (α : Type) {β : Type} {_ : C β} [D α β] : α × β :=
  (D.val1, D.val2 α)

example : f Nat = (37, "hello") := rfl


import Lean

open Lean
open Lean.Meta
open Lean.Elab
open Lean.Elab

private partial def matchHyps : List Expr → List Expr → List Expr → MetaM Bool
  | p::ps, oldHyps, h::newHyps => do
    let pt ← inferType p
    let t ← inferType h
    --dbg_trace "{pt} {t}"
    if (← isDefEq pt t) then
      matchHyps ps [] (oldHyps ++ newHyps)
    else
      matchHyps (p::ps) (h::oldHyps) newHyps
  | [], _, _    => pure true
  | _::_, _, [] => pure false

-- from Lean.Server.Completion
private def isBlackListed (declName : Name) : MetaM Bool := do
  let env ← getEnv
  declName.isInternal
  <||> isAuxRecursor env declName
  <||> isNoConfusion env declName
  <||> isRec declName
  <||> isMatcher declName

initialize findCache : IO.Ref (Option (Std.HashMap HeadIndex (Array Name))) ← IO.mkRef none

def findType (t : Expr) : TermElabM Unit := withReducible do
  let env ← getEnv
  let headMap ← match (← findCache.get) with
    | some headMap => pure headMap
    | none => profileitM Exception "#find: init cache" (← getOptions) do
      let mut headMap := Std.HashMap.empty
      -- TODO: `ForIn` for `SMap`
      for (_, c) in env.constants.map₁.toList do
        if (← isBlackListed c.name) then
          continue
        let (_, _, ty) ← forallMetaTelescopeReducing c.type
        let head := ty.toHeadIndex
        headMap := headMap.insert head (headMap.findD head #[] |>.push c.name)
      findCache.set headMap
      pure headMap

  let t ← instantiateMVars t
  let head := (← forallMetaTelescopeReducing t).2.2.toHeadIndex
  let pat ← abstractMVars t

  let mut numFound := 0
  for n in headMap.findD head #[] ++ env.constants.map₂.toList.toArray.map (·.1) do
    let c := env.find? n |>.get!
    let us ← mkFreshLevelMVars c.numLevelParams
    let cTy ← c.instantiateTypeLevelParams us
    let found ← forallTelescopeReducing cTy fun cParams cTy' => do
      let pat ← pat.expr.instantiateLevelParamsArray pat.paramNames (← mkFreshLevelMVars pat.numMVars).toArray
      let (_, _, pat) ← lambdaMetaTelescope pat
      let (patParams, _, pat) ← forallMetaTelescopeReducing pat
      --dbg_trace "{cTy'}\n{pat}"
      isDefEq cTy' pat <&&> matchHyps patParams.toList [] cParams.toList
    if found then
      numFound := numFound + 1
      if numFound > 20 then
        logInfo m!"maximum number of search results reached"
        break
      logInfo m!"{n}: {cTy}"

open Lean.Elab.Command in
/-
The `find` command finds definitions & lemmas using pattern matching on the type. For instance:
```lean
#find _ + _ = _ + _
#find ?n + _ = _ + ?n
#find (_ : Nat) + _ = _ + _
#find Nat → Nat
```
Inside tactic proofs, the `find` tactic can be used instead.
-/
elab "#find" t:term : command =>
  liftTermElabM none do
    let t ← Term.elabTerm t none
    Term.synthesizeSyntheticMVars (mayPostpone := false) (ignoreStuckTC := true)
    findType t

--#find _ + _ = _ + _
--#find _ + _ = _ + _
--#find ?n + _ = _ + ?n
--#find (_ : Nat) + _ = _ + _
--#find Nat → Nat
--#find _ ≤ _ → _ + _ ≤ _ + _  -- TODO

open Lean.Elab.Tactic
/-
Display theorems (and definitions) whose result type matches the current goal, i.e. which should be `apply`able.
```lean
example : True := by find
```
`find` will not affect the goal by itself and should be removed from the finished proof.

For a command that takes the type to search for as an argument, see `#find`, which is also available as a tactic.
-/
elab "find" : tactic => do
  findType (← getMainTarget)

/-
Tactic version of the `#find` command. See also the `find` tactic to search for theorems matching the current goal.
-/
elab "#find" t:term : tactic => do
  let t ← Term.elabTerm t none
  Term.synthesizeSyntheticMVars (mayPostpone := false) (ignoreStuckTC := true)
  findType t