/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.dlist
import tactic.core
import tactic.clear

/-!

# Recursive cases (`rcases`) tactic and related tactics

`rcases` is a tactic that will perform `cases` recursively, according to a pattern. It is used to
destructure hypotheses or expressions composed of inductive types like `h1 : a ∧ b ∧ c ∨ d` or
`h2 : ∃ x y, trans_rel R x y`. Usual usage might be `rcases h1 with ⟨ha, hb, hc⟩ | hd` or
`rcases h2 with ⟨x, y, _ | ⟨z, hxz, hzy⟩⟩` for these examples.

Each element of an `rcases` pattern is matched against a particular local hypothesis (most of which
are generated during the execution of `rcases` and represent individual elements destructured from
the input expression). An `rcases` pattern has the following grammar:

* A name like `x`, which names the active hypothesis as `x`.
* A blank `_`, which does nothing (letting the automatic naming system used by `cases` name the
  hypothesis).
* A hyphen `-`, which clears the active hypothesis and any dependents.
* The keyword `rfl`, which expects the hypothesis to be `h : a = b`, and calls `subst` on the
  hypothesis (which has the effect of replacing `b` with `a` everywhere or vice versa).
* A type ascription `p : ty`, which sets the type of the hypothesis to `ty` and then matches it
  against `p`. (Of course, `ty` must unify with the actual type of `h` for this to work.)
* A tuple pattern `⟨p1, p2, p3⟩`, which matches a constructor with many arguments, or a series
  of nested conjunctions or existentials. For example if the active hypothesis is `a ∧ b ∧ c`,
  then the conjunction will be destructured, and `p1` will be matched against `a`, `p2` against `b`
  and so on.
* An alteration pattern `p1 | p2 | p3`, which matches an inductive type with multiple constructors,
  or a nested disjunction like `a ∨ b ∨ c`.

The patterns are fairly liberal about the exact shape of the constructors, and will insert
additional alternation branches and tuple arguments if there are not enough arguments provided, and
reuse the tail for further matches if there are too many arguments provided to alternation and
tuple patterns.

This file also contains the `obtain` and `rintro` tactics, which use the same syntax of `rcases`
patterns but with a slightly different use case:

* `rintro` (or `rintros`) is used like `rintro x ⟨y, z⟩` and is the same as `intros` followed by
  `rcases` on the newly introduced arguments.
* `obtain` is the same as `rcases` but with a syntax styled after `have` rather than `cases`.
  `obtain ⟨hx, hy⟩ | hz := foo` is equivalent to `rcases foo with ⟨hx, hy⟩ | hz`. Unlike `rcases`,
  `obtain` also allows one to omit `:= foo`, although a type must be provided in this case,
  as in `obtain ⟨hx, hy⟩ | hz : a ∧ b ∨ c`, in which case it produces a subgoal for proving
  `a ∧ b ∨ c` in addition to the subgoals `hx : a, hy : b |- goal` and `hz : c |- goal`.

## Tags

rcases, rintro, obtain, destructuring, cases, pattern matching, match
-/

open lean lean.parser

namespace tactic

/-!
These synonyms for `list` are used to clarify the meanings of the many
usages of lists in this module.

- `listΣ` is used where a list represents a disjunction, such as the
  list of possible constructors of an inductive type.

- `listΠ` is used where a list represents a conjunction, such as the
  list of arguments of an individual constructor.

These are merely type synonyms, and so are not checked for consistency
by the compiler.

The `def`/`local notation` combination makes Lean retain these
annotations in reported types.
-/

/-- A list, with a disjunctive meaning (like a list of inductive constructors, or subgoals) -/
@[reducible] def list_Sigma := list

/-- A list, with a conjunctive meaning (like a list of constructor arguments, or hypotheses) -/
@[reducible] def list_Pi := list

local notation `listΣ` := list_Sigma
local notation `listΠ` := list_Pi

/-- A metavariable representing a subgoal, together with a list of local constants to clear. -/
@[reducible] meta def uncleared_goal := list expr × expr

/--
An `rcases` pattern can be one of the following, in a nested combination:

* A name like `foo`
* The special keyword `rfl` (for pattern matching on equality using `subst`)
* A hyphen `-`, which clears the active hypothesis and any dependents.
* A type ascription like `pat : ty` (parentheses are optional)
* A tuple constructor like `⟨p1, p2, p3⟩`
* An alternation / variant pattern `p1 | p2 | p3`

Parentheses can be used for grouping; alternation is higher precedence than type ascription, so
`p1 | p2 | p3 : ty` means `(p1 | p2 | p3) : ty`.

N-ary alternations are treated as a group, so `p1 | p2 | p3` is not the same as `p1 | (p2 | p3)`,
and similarly for tuples. However, note that an n-ary alternation or tuple can match an n-ary
conjunction or disjunction, because if the number of patterns exceeds the number of constructors in
the type being destructed, the extra patterns will match on the last element, meaning that
`p1 | p2 | p3` will act like `p1 | (p2 | p3)` when matching `a1 ∨ a2 ∨ a3`. If matching against a
type with 3 constructors,  `p1 | (p2 | p3)` will act like `p1 | (p2 | p3) | _` instead.
-/
meta inductive rcases_patt : Type
| one : name → rcases_patt
| clear : rcases_patt
| typed : rcases_patt → pexpr → rcases_patt
| tuple : listΠ rcases_patt → rcases_patt
| alts : listΣ rcases_patt → rcases_patt

namespace rcases_patt
meta instance inhabited : inhabited rcases_patt :=
⟨one `_⟩

/-- Get the name from a pattern, if provided -/
meta def name : rcases_patt → option name
| (one `_) := none
| (one `rfl) := none
| (one n) := some n
| (typed p _) := p.name
| (alts [p]) := p.name
| _ := none

/-- Interpret an rcases pattern as a tuple, where `p` becomes `⟨p⟩`
if `p` is not already a tuple. -/
meta def as_tuple : rcases_patt → listΠ rcases_patt
| (tuple ps) := ps
| p := [p]

/-- Interpret an rcases pattern as an alternation, where non-alternations are treated as one
alternative. -/
meta def as_alts : rcases_patt → listΣ rcases_patt
| (alts ps) := ps
| p := [p]

/-- Convert a list of patterns to a tuple pattern, but mapping `[p]` to `p` instead of `⟨p⟩`. -/
meta def tuple' : listΠ rcases_patt → rcases_patt
| [p] := p
| ps := tuple ps

/-- Convert a list of patterns to an alternation pattern, but mapping `[p]` to `p` instead of
a unary alternation `|p`. -/
meta def alts' : listΣ rcases_patt → rcases_patt
| [p] := p
| ps := alts ps

/-- This function is used for producing rcases patterns based on a case tree. Suppose that we have
a list of patterns `ps` that will match correctly against the branches of the case tree for one
constructor. This function will merge tuples at the end of the list, so that `[a, b, ⟨c, d⟩]`
becomes `⟨a, b, c, d⟩` instead of `⟨a, b, ⟨c, d⟩⟩`.

We must be careful to turn `[a, ⟨⟩]` into `⟨a, ⟨⟩⟩` instead of `⟨a⟩` (which will not perform the
nested match). -/
meta def tuple₁_core : listΠ rcases_patt → listΠ rcases_patt
| [] := []
| [tuple []] := [tuple []]
| [tuple ps] := ps
| (p :: ps) := p :: tuple₁_core ps

/-- This function is used for producing rcases patterns based on a case tree. This is like
`tuple₁_core` but it produces a pattern instead of a tuple pattern list, converting `[n]` to `n`
instead of `⟨n⟩` and `[]` to `_`, and otherwise just converting `[a, b, c]` to `⟨a, b, c⟩`. -/
meta def tuple₁ : listΠ rcases_patt → rcases_patt
| [] := default _
| [one n] := one n
| ps := tuple (tuple₁_core ps)

/-- This function is used for producing rcases patterns based on a case tree. Here we are given
the list of patterns to apply to each argument of each constructor after the main case, and must
produce a list of alternatives with the same effect. This function calls `tuple₁` to make the
individual alternatives, and handles merging `[a, b, c | d]` to `a | b | c | d` instead of
`a | b | (c | d)`. -/
meta def alts₁_core : listΣ (listΠ rcases_patt) → listΣ rcases_patt
| [] := []
| [[alts ps]] := ps
| (p :: ps) := tuple₁ p :: alts₁_core ps

/-- This function is used for producing rcases patterns based on a case tree. This is like
`alts₁_core`, but it produces a cases pattern directly instead of a list of alternatives. We
specially translate the empty alternation to `⟨⟩`, and translate `|(a | b)` to `⟨a | b⟩` (because we
don't have any syntax for unary alternation). Otherwise we can use the regular merging of
alternations at the last argument so that `a | b | (c | d)` becomes `a | b | c | d`. -/
meta def alts₁ : listΣ (listΠ rcases_patt) → rcases_patt
| [[]] := tuple []
| [[alts ps]] := tuple [alts ps]
| ps := alts' (alts₁_core ps)

meta instance has_reflect : has_reflect rcases_patt
| (one n) := `(_)
| clear := `(_)
| (typed l e) :=
  (`(typed).subst (has_reflect l)).subst (reflect e)
| (tuple l) := `(λ l, tuple l).subst $
  by haveI := has_reflect; exact list.reflect l
| (alts l) := `(λ l, alts l).subst $
  by haveI := has_reflect; exact list.reflect l

/-- Formats an `rcases` pattern. If the `bracket` argument is true, then it will be
printed at high precedence, i.e. it will have parentheses around it if it is not already a tuple
or atomic name. -/
protected meta def format : ∀ bracket : bool, rcases_patt → tactic _root_.format
| _ (one n) := pure $ to_fmt n
| _ clear := pure "-"
| _ (tuple []) := pure "⟨⟩"
| _ (tuple ls) := do
  fs ← ls.mmap $ format ff,
  pure $ "⟨" ++ _root_.format.group (_root_.format.nest 1 $
    _root_.format.join $ list.intersperse ("," ++ _root_.format.line) fs) ++ "⟩"
| br (alts ls) := do
  fs ← ls.mmap $ format tt,
  let fmt := _root_.format.join $ list.intersperse (↑" |" ++ _root_.format.space) fs,
  pure $ if br then _root_.format.bracket "(" ")" fmt else fmt
| br (typed p e) := do
  fp ← format ff p,
  fe ← pp e,
  let fmt := fp ++ " : " ++ fe,
  pure $ if br then _root_.format.bracket "(" ")" fmt else fmt

meta instance has_to_tactic_format : has_to_tactic_format rcases_patt := ⟨rcases_patt.format ff⟩

end rcases_patt

/-- Takes the number of fields of a single constructor and patterns to match its fields against
(not necessarily the same number). The returned lists each contain one element per field of the
constructor. The `name` is the name which will be used in the top-level `cases` tactic, and the
`rcases_patt` is the pattern which the field will be matched against by subsequent `cases`
tactics. -/
meta def rcases.process_constructor :
  nat → listΠ rcases_patt → listΠ name × listΠ rcases_patt
| 0     ps  := ([], [])
| 1     []  := ([`_], [default _])
| 1     [p] := ([p.name.get_or_else `_], [p])

-- The interesting case: we matched the last field against multiple
-- patterns, so split off the remaining patterns into a subsequent
-- match. This handles matching `α × β × γ` against `⟨a, b, c⟩`.
| 1     ps  := ([`_], [rcases_patt.tuple ps])

| (n+1) ps  :=
  let hd := ps.head, (ns, tl) := rcases.process_constructor n ps.tail in
  (hd.name.get_or_else `_ :: ns, hd :: tl)

/-- Takes a list of constructor names, and an (alternation) list of patterns, and matches each
pattern against its constructor. It returns the list of names that will be passed to `cases`,
and the list of `(constructor name, patterns)` for each constructor, where `patterns` is the
(conjunctive) list of patterns to apply to each constructor argument. -/
meta def rcases.process_constructors (params : nat) :
  listΣ name → listΣ rcases_patt →
  tactic (dlist name × listΣ (name × listΠ rcases_patt))
| []      ps := pure (dlist.empty, [])
| (c::cs) ps := do
  n ← mk_const c >>= get_arity,
  let (h, t) := (match cs, ps.tail with
  -- We matched the last constructor against multiple patterns,
  -- so split off the remaining constructors. This handles matching
  -- `α ⊕ β ⊕ γ` against `a|b|c`.
  | [], _::_ := ([rcases_patt.alts ps], [])
  | _, _ := (ps.head.as_tuple, ps.tail)
  end : _),
  let (ns, ps) := rcases.process_constructor (n - params) h,
  (l, r) ← rcases.process_constructors cs t,
  pure (dlist.of_list ns ++ l, (c, ps) :: r)

/-- Like `zip`, but only elements satisfying a matching predicate `p` will go in the list,
and elements of the first list that fail to match the second list will be skipped. -/
private def align {α β} (p : α → β → Prop) [∀ a b, decidable (p a b)] :
  list α → list β → list (α × β)
| (a::as) (b::bs) :=
  if p a b then (a, b) :: align as bs else align as (b::bs)
| _ _ := []

/-- Given a local constant `e`, get its type. *But* if `e` does not exist, go find a hypothesis
with the same pretty name as `e` and get it instead. This is needed because we can sometimes lose
track of the unique names of hypotheses when they are revert/intro'd by `change` and `cases`. (A
better solution would be for these tactics to return a map of renamed hypotheses so that we don't
lose track of them.) -/
private meta def get_local_and_type (e : expr) : tactic (expr × expr) :=
(do t ← infer_type e, pure (t, e)) <|> (do
    e ← get_local e.local_pp_name,
    t ← infer_type e, pure (t, e))

/--
* `rcases_core p e` will match a pattern `p` against a local hypothesis `e`.
  It returns the list of subgoals that were produced.
* `rcases.continue pes` will match a (conjunctive) list of `(p, e)` pairs which refer to
  patterns and local hypotheses to match against, and applies all of them. Note that this can
  involve matching later arguments multiple times given earlier arguments, for example
  `⟨a | b, ⟨c, d⟩⟩` performs the `⟨c, d⟩` match twice, once on the `a` branch and once on `b`.
-/
meta mutual def rcases_core, rcases.continue
with rcases_core : rcases_patt → expr → tactic (list uncleared_goal)
| (rcases_patt.one `rfl) e := do
  (t, e) ← get_local_and_type e,
  subst e,
  list.map (prod.mk []) <$> get_goals
-- If the pattern is any other name, we already bound the name in the
-- top-level `cases` tactic, so there is no more work to do for it.
| (rcases_patt.one _) _ := list.map (prod.mk []) <$> get_goals
| rcases_patt.clear e := do
  m ← try_core (get_local_and_type e),
  list.map (prod.mk $ m.elim [] (λ ⟨_, e⟩, [e])) <$> get_goals
| (rcases_patt.typed p ty) e := do
  (t, e) ← get_local_and_type e,
  ty ← i_to_expr_no_subgoals ``(%%ty : Sort*),
  unify t ty,
  t ← instantiate_mvars t,
  ty ← instantiate_mvars ty,
  e ← if t =ₐ ty then pure e else
    change_core ty (some e) >> get_local e.local_pp_name,
  rcases_core p e
| (rcases_patt.alts [p]) e := rcases_core p e
| pat e := do
  (t, e) ← get_local_and_type e,
  t ← whnf t,
  env ← get_env,
  let I := t.get_app_fn.const_name,
  let pat := pat.as_alts,
  (ids, r, l) ← (if I ≠ `quot
  then do
    when (¬env.is_inductive I) $
      fail format!"rcases tactic failed: {e} : {I} is not an inductive datatype",
    let params := env.inductive_num_params I,
    let c := env.constructors_of I,
    (ids, r) ← rcases.process_constructors params c pat,
    l ← cases_core e ids.to_list,
    pure (ids, r, l)
  else do
    (ids, r) ← rcases.process_constructors 2 [`quot.mk] pat,
    [(_, d)] ← induction e ids.to_list `quot.induction_on |
      fail format!"quotient induction on {e} failed. Maybe goal is not in Prop?",
    -- the result from `induction` is missing the information that the original constructor was
    -- `quot.mk` so we fix this up:
    pure (ids, r, [(`quot.mk, d)])),
  gs ← get_goals,
  -- `cases_core` may not generate a new goal for every constructor,
  -- as some constructors may be impossible for type reasons. (See its
  -- documentation.) Match up the new goals with our remaining work
  -- by constructor name.
  let ls := align (λ (a : name × _) (b : _ × name × _), a.1 = b.2.1) r (gs.zip l),
  list.join <$> ls.mmap (λ⟨⟨_, ps⟩, g, _, hs, _⟩, set_goals [g] >> rcases.continue (ps.zip hs))

with rcases.continue : listΠ (rcases_patt × expr) → tactic (list uncleared_goal)
| [] := list.map (prod.mk []) <$> get_goals
| ((pat, e) :: pes) := do
  gs ← rcases_core pat e,
  list.join <$> gs.mmap (λ ⟨cs, g⟩, do
    set_goals [g],
    ugs ← rcases.continue pes,
    pure $ ugs.map $ λ ⟨cs', gs⟩, (cs ++ cs', gs))

/-- Given a list of `uncleared_goal`s, each of which is a goal metavariable and
a list of variables to clear, actually perform the clear and set the goals with the result. -/
meta def clear_goals (ugs : list uncleared_goal) : tactic unit := do
  gs ← ugs.mmap (λ ⟨cs, g⟩, do
    set_goals [g],
    cs ← cs.mfoldr (λ c cs,
      (do (_, c) ← get_local_and_type c, pure (c :: cs)) <|> pure cs) [],
    clear' tt cs,
    [g] ← get_goals,
    pure g),
  set_goals gs

/-- `rcases h e pat` performs case distinction on `e` using `pat` to
name the arising new variables and assumptions. If `h` is `some` name,
a new assumption `h : e = pat` will relate the expression `e` with the
current pattern. See the module comment for the syntax of `pat`. -/
meta def rcases (h : option name) (p : pexpr) (pat : rcases_patt) : tactic unit := do
  let p := match pat with
  | rcases_patt.typed _ ty := ``(%%p : %%ty)
  | _ := p
  end,
  e ← match h with
    | some h := do
      x ← get_unused_name $ pat.name.get_or_else `this,
      interactive.generalize h () (p, x),
      get_local x
    | none := i_to_expr p
    end,
  if e.is_local_constant then
    focus1 (rcases_core pat e >>= clear_goals)
  else do
    x ← pat.name.elim mk_fresh_name pure,
    n ← revert_kdependencies e semireducible,
    tactic.generalize e x <|> (do
      t ← infer_type e,
      tactic.assertv x t e,
      get_local x >>= tactic.revert,
      pure ()),
    h ← tactic.intro1,
    focus1 (rcases_core pat h >>= clear_goals)

/-- `rcases_many es pats` performs case distinction on the `es` using `pat` to
name the arising new variables and assumptions.
See the module comment for the syntax of `pat`. -/
meta def rcases_many (ps : listΠ pexpr) (pat : rcases_patt) : tactic unit := do
  let (_, pats) := rcases.process_constructor ps.length pat.as_tuple,
  pes ← (ps.zip pats).mmap (λ ⟨p, pat⟩, do
    let p := match pat with
    | rcases_patt.typed _ ty := ``(%%p : %%ty)
    | _ := p
    end,
    e ← i_to_expr p,
    if e.is_local_constant then
      pure (pat, e)
    else do
      x ← pat.name.elim mk_fresh_name pure,
      n ← revert_kdependencies e semireducible,
      tactic.generalize e x <|> (do
        t ← infer_type e,
        tactic.assertv x t e,
        get_local x >>= tactic.revert,
        pure ()),
      prod.mk pat <$> tactic.intro1),
  focus1 (rcases.continue pes >>= clear_goals)

/-- `rintro pat₁ pat₂ ... patₙ` introduces `n` arguments, then pattern matches on the `patᵢ` using
the same syntax as `rcases`. -/
meta def rintro (ids : listΠ rcases_patt) : tactic unit :=
do l ← ids.mmap (λ id, do
    e ← intro $ id.name.get_or_else `_,
    pure (id, e)),
  focus1 (rcases.continue l >>= clear_goals)

/-- Like `zip_with`, but if the lists don't match in length, the excess elements will be put at the
end of the result. -/
def merge_list {α} (m : α → α → α) : list α → list α → list α
| [] l₂ := l₂
| l₁ [] := l₁
| (a :: l₁) (b :: l₂) := m a b :: merge_list l₁ l₂

/-- Merge two `rcases` patterns. This is used to underapproximate a case tree by an `rcases`
pattern. The two patterns come from cases in two branches, that due to the syntax of `rcases`
patterns are forced to overlap. The rule here is that we take only the case splits that are in
common between both branches. For example if one branch does `⟨a, b⟩` and the other does `c`,
then we return `c` because we don't know that a case on `c` would be safe to do. -/
meta def rcases_patt.merge : rcases_patt → rcases_patt → rcases_patt
| (rcases_patt.alts p₁) p₂ := rcases_patt.alts (merge_list rcases_patt.merge p₁ p₂.as_alts)
| p₁ (rcases_patt.alts p₂) := rcases_patt.alts (merge_list rcases_patt.merge p₁.as_alts p₂)
| (rcases_patt.tuple p₁) p₂ := rcases_patt.tuple (merge_list rcases_patt.merge p₁ p₂.as_tuple)
| p₁ (rcases_patt.tuple p₂) := rcases_patt.tuple (merge_list rcases_patt.merge p₁.as_tuple p₂)
| (rcases_patt.typed p₁ e) p₂ := rcases_patt.typed (p₁.merge p₂) e
| p₁ (rcases_patt.typed p₂ e) := rcases_patt.typed (p₁.merge p₂) e
| (rcases_patt.one `rfl) (rcases_patt.one `rfl) := rcases_patt.one `rfl
| (rcases_patt.one `_) p := p
| p (rcases_patt.one `_) := p
| rcases_patt.clear p := p
| p rcases_patt.clear := p
| (rcases_patt.one n) _ := rcases_patt.one n

/--
* `rcases_hint_core depth e` does the same as `rcases p e`, except the pattern `p` is an output
  instead of an input, controlled only by the case depth argument `depth`. We use `cases` to depth
  `depth` and then reconstruct an `rcases` pattern `p` that would, if passed to `rcases`, perform
  the same thing as the case tree we just constructed (or at least, the nearest expressible
  approximation to this.)
* `rcases_hint.process_constructors depth cs l` takes a list of constructor names `cs` and a
  matching list `l` of elements `(g, c', hs, _)` where  `c'` is a constructor name (used for
  alignment with `cs`), `g` is the subgoal, and `hs` is the list of local hypotheses created by
  `cases` in that subgoal. It matches on all of them, and then produces a `ΣΠ`-list of `rcases`
  patterns describing the result, and the list of generated subgoals.
* `rcases_hint.continue depth es` does the same as `rcases.continue (ps.zip es)`, except the
  patterns `ps` are an output instead of an input, created by matching on everything to depth
  `depth` and recording the successful cases. It returns `ps`, and the list of generated subgoals.
-/
meta mutual def rcases_hint_core, rcases_hint.process_constructors, rcases_hint.continue
with rcases_hint_core : ℕ → expr → tactic (rcases_patt × list expr)
| depth e := do
  (t, e) ← get_local_and_type e,
  t ← whnf t,
  env ← get_env,
  let I := t.get_app_fn.const_name,
  (do guard (I = ``eq),
    subst e,
    prod.mk (rcases_patt.one `rfl) <$> get_goals) <|>
  (do
    let c := env.constructors_of I,
    some l ← try_core (guard (depth ≠ 0) >> cases_core e) |
      let n := match e.local_pp_name with name.anonymous := `_ | n := n end in
      prod.mk (rcases_patt.one n) <$> get_goals,
    gs ← get_goals,
    if gs.empty then
      pure (rcases_patt.tuple [], [])
    else do
      (ps, gs') ← rcases_hint.process_constructors (depth - 1) c (gs.zip l),
      pure (rcases_patt.alts₁ ps, gs'))

with rcases_hint.process_constructors : ℕ → listΣ name →
  list (expr × name × listΠ expr × list (name × expr)) →
  tactic (listΣ (listΠ rcases_patt) × list expr)
| depth [] _  := pure ([], [])
| depth cs [] := pure (cs.map (λ _, []), [])
| depth (c::cs) ls@((g, c', hs, _) :: l) :=
  if c ≠ c' then do
    (ps, gs) ← rcases_hint.process_constructors depth cs ls,
    pure ([] :: ps, gs)
  else do
    (p, gs) ← set_goals [g] >> rcases_hint.continue depth hs,
    (ps, gs') ← rcases_hint.process_constructors depth cs l,
    pure (p :: ps, gs ++ gs')

with rcases_hint.continue : ℕ → listΠ expr → tactic (listΠ rcases_patt × list expr)
| depth [] := prod.mk [] <$> get_goals
| depth (e :: es) := do
  (p, gs) ← rcases_hint_core depth e,
  (ps, gs') ← gs.mfoldl (λ (r : listΠ rcases_patt × list expr) g,
    do (ps, gs') ← set_goals [g] >> rcases_hint.continue depth es,
      pure (merge_list rcases_patt.merge r.1 ps, r.2 ++ gs')) ([], []),
  pure (p :: ps, gs')

/--
* `rcases? e` is like `rcases e with ...`, except it generates `...` by matching on everything it
can, and it outputs an `rcases` invocation that should have the same effect.
* `rcases? e : n` can be used to control the depth of case splits (especially important for
recursive types like `nat`, which can be cased as many times as you like). -/
meta def rcases_hint (p : pexpr) (depth : nat) : tactic rcases_patt :=
do e ← i_to_expr p,
  if e.is_local_constant then
    focus1 $ do (p, gs) ← rcases_hint_core depth e, set_goals gs, pure p
  else do
    x ← mk_fresh_name,
    n ← revert_kdependencies e semireducible,
    tactic.generalize e x <|> (do
      t ← infer_type e,
      tactic.assertv x t e,
      get_local x >>= tactic.revert,
      pure ()),
    h ← tactic.intro1,
    focus1 $ do (p, gs) ← rcases_hint_core depth h, set_goals gs, pure p

/--
* `rcases? ⟨e1, e2, e3⟩` is like `rcases ⟨e1, e2, e3⟩ with ...`, except it
  generates `...` by matching on everything it can, and it outputs an `rcases`
  invocation that should have the same effect.
* `rcases? ⟨e1, e2, e3⟩ : n` can be used to control the depth of case splits
  (especially important for recursive types like `nat`, which can be cased as many
  times as you like). -/
meta def rcases_hint_many (ps : list pexpr) (depth : nat) : tactic (listΠ rcases_patt) :=
do es ← ps.mmap (λ p, do
    e ← i_to_expr p,
    if e.is_local_constant then pure e
    else do
      x ← mk_fresh_name,
      n ← revert_kdependencies e semireducible,
      tactic.generalize e x <|> (do
        t ← infer_type e,
        tactic.assertv x t e,
        get_local x >>= tactic.revert,
        pure ()),
      tactic.intro1),
  focus1 $ do
    (ps, gs) ← rcases_hint.continue depth es,
    set_goals gs,
    pure ps

/--
* `rintro?` is like `rintro ...`, except it generates `...` by introducing and matching on
everything it can, and it outputs an `rintro` invocation that should have the same effect.
* `rintro? : n` can be used to control the depth of case splits (especially important for
recursive types like `nat`, which can be cased as many times as you like). -/
meta def rintro_hint (depth : nat) : tactic (listΠ rcases_patt) :=
do l ← intros,
  focus1 $ do
    (p, gs) ← rcases_hint.continue depth l,
    set_goals gs,
    pure p

setup_tactic_parser

/--
* `rcases_patt_parse tt` will parse a high precedence `rcases` pattern, `patt_hi`.
  This means only tuples and identifiers are allowed; alternations and type ascriptions
  require `(...)` instead, which switches to `patt`.
* `rcases_patt_parse ff` will parse a low precedence `rcases` pattern, `patt`. This consists of a
  `patt_med` (which deals with alternations), optionally followed by a `: ty` type ascription. The
  expression `ty` is at `texpr` precedence because it can appear at the end of a tactic, for
  example in `rcases e with x : ty <|> skip`.
* `rcases_patt_parse_list` will parse an alternation list, `patt_med`, one or more `patt`
  patterns separated by `|`. It does not parse a `:` at the end, so that `a | b : ty` parses as
  `(a | b) : ty` where `a | b` is the `patt_med` part.
* `rcases_patt_parse_list_rest a` parses an alternation list after the initial pattern, `| b | c`.

```lean
patt ::= patt_med (":" expr)?
patt_med ::= (patt_hi "|")* patt_hi
patt_hi ::= id | "rfl" | "_" | "⟨" (patt ",")* patt "⟩" | "(" patt ")"
```
-/
meta mutual def rcases_patt_parse, rcases_patt_parse_list, rcases_patt_parse_list_rest
with rcases_patt_parse : bool → parser rcases_patt
| tt := with_desc "patt_hi" $
  (brackets "(" ")" (rcases_patt_parse ff)) <|>
  (rcases_patt.tuple <$> brackets "⟨" "⟩" (sep_by (tk ",") (rcases_patt_parse ff))) <|>
  (tk "-" $> rcases_patt.clear) <|>
  (rcases_patt.one <$> ident_)
| ff := with_desc "patt" $ do
  pat ← rcases_patt.alts' <$> rcases_patt_parse_list,
  (tk ":" *> pat.typed <$> texpr) <|> pure pat

with rcases_patt_parse_list : parser (listΣ rcases_patt)
| x := (with_desc "patt_med" $ rcases_patt_parse tt >>= rcases_patt_parse_list_rest) x

with rcases_patt_parse_list_rest : rcases_patt → parser (listΣ rcases_patt)
| pat :=
  (tk "|" *> list.cons pat <$> rcases_patt_parse_list) <|>
  -- hack to support `-|-` patterns, because `|-` is a token
  (tk "|-" *> list.cons pat <$> rcases_patt_parse_list_rest rcases_patt.clear) <|>
  pure [pat]

/-- Parse the optional depth argument `(: n)?` of `rcases?` and `rintro?`, with default depth 5. -/
meta def rcases_parse_depth : parser nat :=
do o ← (tk ":" *> small_nat)?, pure $ o.get_or_else 5

/-- The arguments to `rcases`, which in fact dispatch to several other tactics.
* `rcases? expr (: n)?` or `rcases? ⟨expr, ...⟩ (: n)?` calls `rcases_hint`
* `rcases? ⟨expr, ...⟩ (: n)?` calls `rcases_hint_many`
* `rcases (h :)? expr (with patt)?` calls `rcases`
* `rcases ⟨expr, ...⟩ (with patt)?` calls `rcases_many`
-/
@[derive has_reflect]
meta inductive rcases_args
| hint (tgt : pexpr ⊕ list pexpr) (depth : nat)
| rcases (name : option name) (tgt : pexpr) (pat : rcases_patt)
| rcases_many (tgt : listΠ pexpr) (pat : rcases_patt)

/-- Syntax for a `rcases` pattern:
* `rcases? expr (: n)?`
* `rcases (h :)? expr (with patt_list (: expr)?)?`. -/
meta def rcases_parse : parser rcases_args :=
with_desc "('?' expr (: n)?) | ((h :)? expr (with patt)?)" $ do
  hint ← (tk "?")?,
  p ← (sum.inr <$> brackets "⟨" "⟩" (sep_by (tk ",") (parser.pexpr 0))) <|>
      (sum.inl <$> texpr),
  match hint with
  | none := do
    p ← (do
      sum.inl (expr.local_const h _ _ _) ← pure p,
      tk ":" *> (@sum.inl _ (pexpr ⊕ list pexpr) ∘ prod.mk h) <$> texpr) <|>
      pure (sum.inr p),
    ids ← (tk "with" *> rcases_patt_parse ff)?,
    let ids := ids.get_or_else (rcases_patt.tuple []),
    pure $ match p with
    | sum.inl (name, tgt) := rcases_args.rcases (some name) tgt ids
    | sum.inr (sum.inl tgt) := rcases_args.rcases none tgt ids
    | sum.inr (sum.inr tgts) := rcases_args.rcases_many tgts ids
    end
  | some _ := do
    depth ← rcases_parse_depth,
    pure $ rcases_args.hint p depth
  end

/--
`rintro_patt_parse_hi` and `rintro_patt_parse` are like `rcases_patt_parse`, but is used for
parsing top level `rintro` patterns, which allow sequences like `(x y : t)` in addition to simple
`rcases` patterns.

* `rintro_patt_parse_hi` will parse a high precedence `rcases` pattern, `rintro_patt_hi` below.
  This means only tuples and identifiers are allowed; alternations and type ascriptions
  require `(...)` instead, which switches to `patt`.
* `rintro_patt_parse tt` will parse a low precedence `rcases` pattern, `rintro_patt` below.
  This consists of either a sequence of patterns `p1 p2 p3` or an alternation list `p1 | p2 | p3`
  treated as a single pattern, optionally followed by a `: ty` type ascription, which applies to
  every pattern in the list.
* `rintro_patt_parse ff` parses `rintro_patt_low`, which is the same as `rintro_patt_parse tt` but
  it does not permit an unparenthesized alternation list, it must have the form `p1 p2 p3 (: ty)?`.

```lean
rintro_patt ::= (rintro_patt_hi+ | patt_med) (":" expr)?
rintro_patt_low ::= rintro_patt_hi* (":" expr)?
rintro_patt_hi ::= patt_hi | "(" rintro_patt ")"
```
-/
meta mutual def rintro_patt_parse_hi, rintro_patt_parse
with rintro_patt_parse_hi : parser (listΠ rcases_patt)
| x := (with_desc "rintro_patt_hi" $
  brackets "(" ")" (rintro_patt_parse tt) <|>
  (do p ← rcases_patt_parse tt, pure [p])) x
with rintro_patt_parse : bool → parser (listΠ rcases_patt)
| med := with_desc "rintro_patt" $ do
  ll ← rintro_patt_parse_hi*,
  pats ← match med, ll.join with
  | tt, [] := failure
  | tt, [pat] := do l ← rcases_patt_parse_list_rest pat, pure [rcases_patt.alts' l]
  | _, pats := pure pats
  end,
  (do tk ":", e ← texpr, pure (pats.map (λ p, rcases_patt.typed p e))) <|>
  pure pats

/-- Syntax for a `rintro` pattern: `('?' (: n)?) | rintro_patt`. -/
meta def rintro_parse : parser (listΠ rcases_patt ⊕ nat) :=
with_desc "('?' (: n)?) | patt*" $
(tk "?" >> sum.inr <$> rcases_parse_depth) <|>
sum.inl <$> rintro_patt_parse ff

namespace interactive
open interactive interactive.types expr

/--
`rcases` is a tactic that will perform `cases` recursively, according to a pattern. It is used to
destructure hypotheses or expressions composed of inductive types like `h1 : a ∧ b ∧ c ∨ d` or
`h2 : ∃ x y, trans_rel R x y`. Usual usage might be `rcases h1 with ⟨ha, hb, hc⟩ | hd` or
`rcases h2 with ⟨x, y, _ | ⟨z, hxz, hzy⟩⟩` for these examples.

Each element of an `rcases` pattern is matched against a particular local hypothesis (most of which
are generated during the execution of `rcases` and represent individual elements destructured from
the input expression). An `rcases` pattern has the following grammar:

* A name like `x`, which names the active hypothesis as `x`.
* A blank `_`, which does nothing (letting the automatic naming system used by `cases` name the
  hypothesis).
* A hyphen `-`, which clears the active hypothesis and any dependents.
* The keyword `rfl`, which expects the hypothesis to be `h : a = b`, and calls `subst` on the
  hypothesis (which has the effect of replacing `b` with `a` everywhere or vice versa).
* A type ascription `p : ty`, which sets the type of the hypothesis to `ty` and then matches it
  against `p`. (Of course, `ty` must unify with the actual type of `h` for this to work.)
* A tuple pattern `⟨p1, p2, p3⟩`, which matches a constructor with many arguments, or a series
  of nested conjunctions or existentials. For example if the active hypothesis is `a ∧ b ∧ c`,
  then the conjunction will be destructured, and `p1` will be matched against `a`, `p2` against `b`
  and so on.
* An alteration pattern `p1 | p2 | p3`, which matches an inductive type with multiple constructors,
  or a nested disjunction like `a ∨ b ∨ c`.

A pattern like `⟨a, b, c⟩ | ⟨d, e⟩` will do a split over the inductive datatype,
naming the first three parameters of the first constructor as `a,b,c` and the
first two of the second constructor `d,e`. If the list is not as long as the
number of arguments to the constructor or the number of constructors, the
remaining variables will be automatically named. If there are nested brackets
such as `⟨⟨a⟩, b | c⟩ | d` then these will cause more case splits as necessary.
If there are too many arguments, such as `⟨a, b, c⟩` for splitting on
`∃ x, ∃ y, p x`, then it will be treated as `⟨a, ⟨b, c⟩⟩`, splitting the last
parameter as necessary.

`rcases` also has special support for quotient types: quotient induction into Prop works like
matching on the constructor `quot.mk`.

`rcases h : e with PAT` will do the same as `rcases e with PAT` with the exception that an
assumption `h : e = PAT` will be added to the context.

`rcases? e` will perform case splits on `e` in the same way as `rcases e`,
but rather than accepting a pattern, it does a maximal cases and prints the
pattern that would produce this case splitting. The default maximum depth is 5,
but this can be modified with `rcases? e : n`.
-/
meta def rcases : parse rcases_parse → tactic unit
| (rcases_args.rcases h p ids) := tactic.rcases h p ids
| (rcases_args.rcases_many ps ids) := tactic.rcases_many ps ids
| (rcases_args.hint p depth) := do
  (pe, patt) ← match p with
  | sum.inl p := prod.mk <$> pp p <*> rcases_hint p depth
  | sum.inr ps := do
    patts ← rcases_hint_many ps depth,
    pes ← ps.mmap pp,
    pure (format.bracket "⟨" "⟩" (format.comma_separated pes), rcases_patt.tuple patts)
  end,
  ppat ← pp patt,
  trace $ ↑"Try this: rcases " ++ pe ++ " with " ++ ppat

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

/--
The `rintro` tactic is a combination of the `intros` tactic with `rcases` to
allow for destructuring patterns while introducing variables. See `rcases` for
a description of supported patterns. For example, `rintro (a | ⟨b, c⟩) ⟨d, e⟩`
will introduce two variables, and then do case splits on both of them producing
two subgoals, one with variables `a d e` and the other with `b c d e`.

`rintro`, unlike `rcases`, also supports the form `(x y : ty)` for introducing
and type-ascripting multiple variables at once, similar to binders.

`rintro?` will introduce and case split on variables in the same way as
`rintro`, but will also print the `rintro` invocation that would have the same
result. Like `rcases?`, `rintro? : n` allows for modifying the
depth of splitting; the default is 5.

`rintros` is an alias for `rintro`.
-/
meta def rintro : parse rintro_parse → tactic unit
| (sum.inl []) := intros []
| (sum.inl l)  := tactic.rintro l
| (sum.inr depth) := do
  ps ← tactic.rintro_hint depth,
  fs ← ps.mmap (λ p, do
    f ← pp $ p.format tt,
    pure $ format.space ++ format.group f),
  trace $ ↑"Try this: rintro" ++ format.join fs

/-- Alias for `rintro`. -/
meta def rintros := rintro

add_tactic_doc
{ name       := "rintro",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.rintro, `tactic.interactive.rintros],
  tags       := ["induction"],
  inherit_description_from := `tactic.interactive.rintro }

setup_tactic_parser

/-- Parses `patt? (: expr)? (:= expr)?`, the arguments for `obtain`.
 (This is almost the same as `rcases_patt_parse ff`,
but it allows the pattern part to be empty.) -/
meta def obtain_parse :
  parser ((option rcases_patt × option pexpr) × option (pexpr ⊕ list pexpr)) :=
with_desc "patt? (: expr)? (:= expr)?" $ do
  (pat, tp) ←
    (do pat ← rcases_patt_parse ff,
      pure $ match pat with
      | rcases_patt.typed pat tp := (some pat, some tp)
      | _ := (some pat, none)
      end) <|>
    prod.mk none <$> (tk ":" >> texpr)?,
  prod.mk (pat, tp) <$> (do
    tk ":=",
    (guard tp.is_none >>
      sum.inr <$> brackets "⟨" "⟩" (sep_by (tk ",") (parser.pexpr 0))) <|>
    (sum.inl <$> texpr))?

/--
The `obtain` tactic is a combination of `have` and `rcases`. See `rcases` for
a description of supported patterns.

```lean
obtain ⟨patt⟩ : type,
{ ... }
```
is equivalent to
```lean
have h : type,
{ ... },
rcases h with ⟨patt⟩
```

The syntax `obtain ⟨patt⟩ : type := proof` is also supported.

If `⟨patt⟩` is omitted, `rcases` will try to infer the pattern.

If `type` is omitted, `:= proof` is required.
-/
meta def obtain : parse obtain_parse → tactic unit
| ((pat, _), some (sum.inr val)) :=
  tactic.rcases_many val (pat.get_or_else (default _))
| ((pat, none), some (sum.inl val)) :=
  tactic.rcases none val (pat.get_or_else (default _))
| ((pat, some tp), some (sum.inl val)) :=
  tactic.rcases none val $ (pat.get_or_else (default _)).typed tp
| ((pat, some tp), none) := do
  nm ← mk_fresh_name,
  e ← to_expr tp >>= assert nm,
  (g :: gs) ← get_goals,
  set_goals gs,
  tactic.rcases none ``(%%e) (pat.get_or_else (rcases_patt.one `this)),
  gs ← get_goals,
  set_goals (g::gs)
| ((pat, none), none) :=
  fail $ "`obtain` requires either an expected type or a value.\n" ++
         "usage: `obtain ⟨patt⟩? : type (:= val)?` or `obtain ⟨patt⟩? (: type)? := val`"

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

end interactive
end tactic


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

! This file was ported from Lean 3 source module data.dlist.basic
! leanprover-community/mathlib commit d6aae1bcbd04b8de2022b9b83a5b5b10e10c777d
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Std.Data.DList
import Mathlib.Mathport.Rename
import Mathlib.Tactic.Cases

/-!
# Difference list

This file provides a few results about `DList`, which is defined in `Std`.

A difference list is a function that, given a list, returns the original content of the
difference list prepended to the given list. It is useful to represent elements of a given type
as `a₁ + ... + aₙ` where `+ : α → α → α` is any operation, without actually computing.

This structure supports `O(1)` `append` and `concat` operations on lists, making it
useful for append-heavy uses such as logging and pretty printing.
-/

namespace Std

/-- Concatenates a list of difference lists to form a single difference list. Similar to
`List.join`. -/
def DList.join {α : Type _} : List (DList α) → DList α
  | [] => DList.empty
  | x :: xs => x ++ DList.join xs
#align dlist.join Std.DList.join

/-- Convert a lazily-evaluated `List` to a `DList` -/
-- Ported from Lean 3 core
def DList.lazy_ofList (l : Thunk (List α)) : DList α :=
⟨fun xs => l.get ++ xs, fun t => by simp⟩
#align dlist.lazy_of_list Std.DList.lazy_ofList

@[simp]
theorem DList_singleton {α : Type _} {a : α} : DList.singleton a = DList.lazy_ofList [a] :=
  rfl
#align dlist_singleton Std.DList_singleton

@[simp]
theorem DList_lazy {α : Type _} {l : List α} : DList.lazy_ofList l = Std.DList.ofList l :=
  rfl
#align dlist_lazy Std.DList_lazy

-- Porting note: port from lean3
theorem DList.toList_ofList (l : List α) : DList.toList (DList.ofList l) = l := by
  cases l; rfl; simp only [DList.toList, DList.ofList, List.cons_append, List.append_nil]
#align dlist.to_list_of_list Std.DList.toList_ofList

-- Porting note: port from lean3

end Std


/-
Copyright (c) 2021 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import category_theory.sites.limits
import category_theory.flat_functors
import category_theory.limits.preserves.filtered
import category_theory.sites.left_exact

/-!
# Cover-preserving functors between sites.

We define cover-preserving functors between sites as functors that push covering sieves to
covering sieves. A cover-preserving and compatible-preserving functor `G : C ⥤ D` then pulls
sheaves on `D` back to sheaves on `C` via `G.op ⋙ -`.

## Main definitions

* `category_theory.cover_preserving`: a functor between sites is cover-preserving if it
pushes covering sieves to covering sieves
* `category_theory.compatible_preserving`: a functor between sites is compatible-preserving
if it pushes compatible families of elements to compatible families.
* `category_theory.pullback_sheaf`: the pullback of a sheaf along a cover-preserving and
compatible-preserving functor.
* `category_theory.sites.pullback`: the induced functor `Sheaf K A ⥤ Sheaf J A` for a
cover-preserving and compatible-preserving functor `G : (C, J) ⥤ (D, K)`.
* `category_theory.sites.pushforward`: the induced functor `Sheaf J A ⥤ Sheaf K A` for a
cover-preserving and compatible-preserving functor `G : (C, J) ⥤ (D, K)`.
* `category_theory.sites.pushforward`: the induced functor `Sheaf J A ⥤ Sheaf K A` for a
cover-preserving and compatible-preserving functor `G : (C, J) ⥤ (D, K)`.

## Main results

- `category_theory.sites.whiskering_left_is_sheaf_of_cover_preserving`: If `G : C ⥤ D` is
cover-preserving and compatible-preserving, then `G ⋙ -` (`uᵖ`) as a functor
`(Dᵒᵖ ⥤ A) ⥤ (Cᵒᵖ ⥤ A)` of presheaves maps sheaves to sheaves.

## References

* [Elephant]: *Sketches of an Elephant*, P. T. Johnstone: C2.3.
* https://stacks.math.columbia.edu/tag/00WW

-/

universes w v₁ v₂ v₃ u₁ u₂ u₃
noncomputable theory

open category_theory
open opposite
open category_theory.presieve.family_of_elements
open category_theory.presieve
open category_theory.limits

namespace category_theory
variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₂} D]
variables {A : Type u₃} [category.{v₃} A]
variables (J : grothendieck_topology C) (K : grothendieck_topology D)
variables {L : grothendieck_topology A}

/--
A functor `G : (C, J) ⥤ (D, K)` between sites is *cover-preserving*
if for all covering sieves `R` in `C`, `R.pushforward_functor G` is a covering sieve in `D`.
-/
@[nolint has_inhabited_instance]
structure cover_preserving (G : C ⥤ D) : Prop :=
(cover_preserve : ∀ {U : C} {S : sieve U} (hS : S ∈ J U), S.functor_pushforward G ∈ K (G.obj U))

/-- The identity functor on a site is cover-preserving. -/
lemma id_cover_preserving : cover_preserving J J (𝟭 _) := ⟨λ U S hS, by simpa using hS⟩

variables (J) (K)

/-- The composition of two cover-preserving functors is cover-preserving. -/
lemma cover_preserving.comp {F} (hF : cover_preserving J K F) {G} (hG : cover_preserving K L G) :
  cover_preserving J L (F ⋙ G) := ⟨λ U S hS,
begin
  rw sieve.functor_pushforward_comp,
  exact hG.cover_preserve (hF.cover_preserve hS)
end⟩

/--
A functor `G : (C, J) ⥤ (D, K)` between sites is called compatible preserving if for each
compatible family of elements at `C` and valued in `G.op ⋙ ℱ`, and each commuting diagram
`f₁ ≫ G.map g₁ = f₂ ≫ G.map g₂`, `x g₁` and `x g₂` coincide when restricted via `fᵢ`.
This is actually stronger than merely preserving compatible families because of the definition of
`functor_pushforward` used.
-/
@[nolint has_inhabited_instance]
structure compatible_preserving (K : grothendieck_topology D) (G : C ⥤ D) : Prop :=
(compatible :
  ∀ (ℱ : SheafOfTypes.{w} K) {Z} {T : presieve Z}
    {x : family_of_elements (G.op ⋙ ℱ.val) T} (h : x.compatible)
    {Y₁ Y₂} {X} (f₁ : X ⟶ G.obj Y₁) (f₂ : X ⟶ G.obj Y₂) {g₁ : Y₁ ⟶ Z} {g₂ : Y₂ ⟶ Z}
    (hg₁ : T g₁) (hg₂ : T g₂) (eq : f₁ ≫ G.map g₁ = f₂ ≫ G.map g₂),
      ℱ.val.map f₁.op (x g₁ hg₁) = ℱ.val.map f₂.op (x g₂ hg₂))

variables {J K} {G : C ⥤ D} (hG : compatible_preserving.{w} K G) (ℱ : SheafOfTypes.{w} K) {Z : C}
variables {T : presieve Z} {x : family_of_elements (G.op ⋙ ℱ.val) T} (h : x.compatible)

include h hG

/-- `compatible_preserving` functors indeed preserve compatible families. -/
lemma presieve.family_of_elements.compatible.functor_pushforward :
  (x.functor_pushforward G).compatible :=
begin
  rintros Z₁ Z₂ W g₁ g₂ f₁' f₂' H₁ H₂ eq,
  unfold family_of_elements.functor_pushforward,
  rcases get_functor_pushforward_structure H₁ with ⟨X₁, f₁, h₁, hf₁, rfl⟩,
  rcases get_functor_pushforward_structure H₂ with ⟨X₂, f₂, h₂, hf₂, rfl⟩,
  suffices : ℱ.val.map (g₁ ≫ h₁).op (x f₁ hf₁) = ℱ.val.map (g₂ ≫ h₂).op (x f₂ hf₂),
    simpa using this,
  apply hG.compatible ℱ h _ _ hf₁ hf₂,
  simpa using eq
end

@[simp] lemma compatible_preserving.apply_map {Y : C} {f : Y ⟶ Z} (hf : T f) :
  x.functor_pushforward G (G.map f) (image_mem_functor_pushforward G T hf) = x f hf :=
begin
  unfold family_of_elements.functor_pushforward,
  rcases e₁ : get_functor_pushforward_structure (image_mem_functor_pushforward G T hf) with
    ⟨X, g, f', hg, eq⟩,
  simpa using hG.compatible ℱ h f' (𝟙 _) hg hf (by simp[eq])
end

omit h hG

open limits.walking_cospan

lemma compatible_preserving_of_flat {C : Type u₁} [category.{v₁} C] {D : Type u₁} [category.{v₁} D]
  (K : grothendieck_topology D) (G : C ⥤ D) [representably_flat G] : compatible_preserving K G :=
begin
  constructor,
  intros ℱ Z T x hx Y₁ Y₂ X f₁ f₂ g₁ g₂ hg₁ hg₂ e,

  /- First, `f₁` and `f₂` form a cone over `cospan g₁ g₂ ⋙ u`. -/
  let c : cone (cospan g₁ g₂ ⋙ G) :=
    (cones.postcompose (diagram_iso_cospan (cospan g₁ g₂ ⋙ G)).inv).obj
      (pullback_cone.mk f₁ f₂ e),

  /-
  This can then be viewed as a cospan of structured arrows, and we may obtain an arbitrary cone
  over it since `structured_arrow W u` is cofiltered.
  Then, it suffices to prove that it is compatible when restricted onto `u(c'.X.right)`.
  -/
  let c' := is_cofiltered.cone (structured_arrow_cone.to_diagram c ⋙ structured_arrow.pre _ _ _),
  have eq₁ : f₁ = (c'.X.hom ≫ G.map (c'.π.app left).right) ≫ eq_to_hom (by simp),
  { erw ← (c'.π.app left).w, dsimp, simp },
  have eq₂ : f₂ = (c'.X.hom ≫ G.map (c'.π.app right).right) ≫ eq_to_hom (by simp),
  { erw ← (c'.π.app right).w, dsimp, simp },
  conv_lhs { rw eq₁ },
  conv_rhs { rw eq₂ },
  simp only [op_comp, functor.map_comp, types_comp_apply, eq_to_hom_op, eq_to_hom_map],
  congr' 1,

  /-
  Since everything now falls in the image of `u`,
  the result follows from the compatibility of `x` in the image of `u`.
  -/
  injection c'.π.naturality walking_cospan.hom.inl with _ e₁,
  injection c'.π.naturality walking_cospan.hom.inr with _ e₂,
  exact hx (c'.π.app left).right (c'.π.app right).right hg₁ hg₂ (e₁.symm.trans e₂)
end

/--
If `G` is cover-preserving and compatible-preserving,
then `G.op ⋙ _` pulls sheaves back to sheaves.

This result is basically https://stacks.math.columbia.edu/tag/00WW.
-/
theorem pullback_is_sheaf_of_cover_preserving {G : C ⥤ D} (hG₁ : compatible_preserving.{v₃} K G)
  (hG₂ : cover_preserving J K G) (ℱ : Sheaf K A) :
  presheaf.is_sheaf J (G.op ⋙ ℱ.val) :=
begin
  intros X U S hS x hx,
  change family_of_elements (G.op ⋙ ℱ.val ⋙ coyoneda.obj (op X)) _ at x,
  let H := ℱ.2 X _ (hG₂.cover_preserve hS),
  let hx' := hx.functor_pushforward hG₁ (sheaf_over ℱ X),
  split, swap,
  { apply H.amalgamate (x.functor_pushforward G),
    exact hx' },
  split,
  { intros V f hf,
    convert H.is_amalgamation hx' (G.map f) (image_mem_functor_pushforward G S hf),
    rw hG₁.apply_map (sheaf_over ℱ X) hx },
  { intros y hy,
    refine H.is_separated_for _ y _ _
      (H.is_amalgamation (hx.functor_pushforward hG₁ (sheaf_over ℱ X))),
    rintros V f ⟨Z, f', g', h, rfl⟩,
    erw family_of_elements.comp_of_compatible (S.functor_pushforward G)
      hx' (image_mem_functor_pushforward G S h) g',
    dsimp,
    simp [hG₁.apply_map (sheaf_over ℱ X) hx h, ←hy f' h] }
end

/-- The pullback of a sheaf along a cover-preserving and compatible-preserving functor. -/
def pullback_sheaf {G : C ⥤ D} (hG₁ : compatible_preserving K G)
  (hG₂ : cover_preserving J K G) (ℱ : Sheaf K A) : Sheaf J A :=
⟨G.op ⋙ ℱ.val, pullback_is_sheaf_of_cover_preserving hG₁ hG₂ ℱ⟩

variable (A)

/--
The induced functor from `Sheaf K A ⥤ Sheaf J A` given by `G.op ⋙ _`
if `G` is cover-preserving and compatible-preserving.
-/
@[simps] def sites.pullback {G : C ⥤ D} (hG₁ : compatible_preserving K G)
  (hG₂ : cover_preserving J K G) : Sheaf K A ⥤ Sheaf J A :=
{ obj := λ ℱ, pullback_sheaf hG₁ hG₂ ℱ,
  map := λ _ _ f, ⟨(((whiskering_left _ _ _).obj G.op)).map f.val⟩,
  map_id' := λ ℱ, by { ext1, apply (((whiskering_left _ _ _).obj G.op)).map_id },
  map_comp' := λ _ _ _ f g, by { ext1, apply (((whiskering_left _ _ _).obj G.op)).map_comp } }

end category_theory

namespace category_theory

variables {C : Type v₁} [small_category C] {D : Type v₁} [small_category D]
variables (A : Type u₂) [category.{v₁} A]
variables (J : grothendieck_topology C) (K : grothendieck_topology D)

instance [has_limits A] : creates_limits (Sheaf_to_presheaf J A) :=
category_theory.Sheaf.category_theory.Sheaf_to_presheaf.category_theory.creates_limits.{u₂ v₁ v₁}

-- The assumptions so that we have sheafification
variables [concrete_category.{v₁} A] [preserves_limits (forget A)] [has_colimits A] [has_limits A]
variables [preserves_filtered_colimits (forget A)] [reflects_isomorphisms (forget A)]

local attribute [instance] reflects_limits_of_reflects_isomorphisms

instance {X : C} : is_cofiltered (J.cover X) := infer_instance

/-- The pushforward functor `Sheaf J A ⥤ Sheaf K A` associated to a functor `G : C ⥤ D` in the
same direction as `G`. -/
@[simps] def sites.pushforward (G : C ⥤ D) : Sheaf J A ⥤ Sheaf K A :=
Sheaf_to_presheaf J A ⋙ Lan G.op ⋙ presheaf_to_Sheaf K A

instance (G : C ⥤ D) [representably_flat G] :
  preserves_finite_limits (sites.pushforward A J K G) :=
begin
  apply_with comp_preserves_finite_limits { instances := ff },
  { apply_instance },
  apply_with comp_preserves_finite_limits { instances := ff },
  { apply category_theory.Lan_preserves_finite_limits_of_flat },
  { apply category_theory.presheaf_to_Sheaf.limits.preserves_finite_limits.{u₂ v₁ v₁},
    apply_instance }
end

/-- The pushforward functor is left adjoint to the pullback functor. -/
def sites.pullback_pushforward_adjunction {G : C ⥤ D} (hG₁ : compatible_preserving K G)
  (hG₂ : cover_preserving J K G) : sites.pushforward A J K G ⊣ sites.pullback A hG₁ hG₂ :=
((Lan.adjunction A G.op).comp _ _ (sheafification_adjunction K A)).restrict_fully_faithful
  (Sheaf_to_presheaf J A) (𝟭 _)
  (nat_iso.of_components (λ _, iso.refl _)
    (λ _ _ _,(category.comp_id _).trans (category.id_comp _).symm))
  (nat_iso.of_components (λ _, iso.refl _)
    (λ _ _ _,(category.comp_id _).trans (category.id_comp _).symm))

end category_theory


/-
Copyright (c) 2019 Paul-Nicolas Madelaine. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Paul-Nicolas Madelaine, Robert Y. Lewis

Normalizing casts inside expressions.
-/
import tactic.converter.interactive
import tactic.hint

/-!
# A tactic for normalizing casts inside expressions

This tactic normalizes casts inside expressions.
It can be thought of as a call to the simplifier with a specific set of lemmas to
move casts upwards in the expression.
It has special handling of numerals and a simple heuristic to help moving
casts "past" binary operators.
Contrary to simp, it should be safe to use as a non-terminating tactic.

The algorithm implemented here is described in the paper
<https://lean-forward.github.io/norm_cast/norm_cast.pdf>.

## Important definitions
* `tactic.interactive.norm_cast`
* `tactic.interactive.push_cast`
* `tactic.interactive.exact_mod_cast`
* `tactic.interactive.apply_mod_cast`
* `tactic.interactive.rw_mod_cast`
* `tactic.interactive.assumption_mod_cast`
-/

setup_tactic_parser

namespace tactic

/--
Runs `mk_instance` with a time limit.

This is a work around to the fact that in some cases
mk_instance times out instead of failing,
for example: `has_lift_t ℤ ℕ`

`mk_instance_fast` is used when we assume the type class search
should end instantly.
-/
meta def mk_instance_fast (e : expr) (timeout := 1000) : tactic expr :=
try_for timeout (mk_instance e)

end tactic

namespace norm_cast

open tactic expr

declare_trace norm_cast

/--
Output a trace message if `trace.norm_cast` is enabled.
-/
meta def trace_norm_cast {α} [has_to_tactic_format α] (msg : string) (a : α) : tactic unit :=
when_tracing `norm_cast $ do
a ← pp a,
trace ("[norm_cast] " ++ msg ++ a : format)

mk_simp_attribute push_cast "The `push_cast` simp attribute uses `norm_cast` lemmas
to move casts toward the leaf nodes of the expression."

/--
`label` is a type used to classify `norm_cast` lemmas.
* elim lemma:   LHS has 0 head coes and ≥ 1 internal coe
* move lemma:   LHS has 1 head coe and 0 internal coes,    RHS has 0 head coes and ≥ 1 internal coes
* squash lemma: LHS has ≥ 1 head coes and 0 internal coes, RHS has fewer head coes
-/
@[derive [decidable_eq, has_reflect, inhabited]]
inductive label
| elim   : label
| move   : label
| squash : label

namespace label

/-- Convert `label` into `string`. -/
protected def to_string : label → string
| elim   := "elim"
| move   := "move"
| squash := "squash"

instance : has_to_string label := ⟨label.to_string⟩
instance : has_repr label := ⟨label.to_string⟩
meta instance : has_to_format label := ⟨λ l, l.to_string⟩

/-- Convert `string` into `label`. -/
def of_string : string -> option label
| "elim" := some elim
| "move" := some move
| "squash" := some squash
| _ := none

end label

open label

/-- Count how many coercions are at the top of the expression. -/
meta def count_head_coes : expr → ℕ
| `(coe %%e) := count_head_coes e + 1
| `(coe_sort %%e) := count_head_coes e + 1
| `(coe_fn %%e) := count_head_coes e + 1
| _ := 0

/-- Count how many coercions are inside the expression, including the top ones. -/
meta def count_coes : expr → tactic ℕ
| `(coe %%e) := (+1) <$> count_coes e
| `(coe_sort %%e) := (+1) <$> count_coes e
| `(coe_fn %%e) := (+1) <$> count_coes e
| (app `(coe_fn %%e) x) := (+) <$> count_coes x <*> (+1) <$> count_coes e
| (expr.lam n bi t e) := do
  l ← mk_local' n bi t,
  count_coes $ e.instantiate_var l
| e := do
  as ← e.get_simp_args,
  list.sum <$> as.mmap count_coes

/-- Count how many coercions are inside the expression, excluding the top ones. -/
private meta def count_internal_coes (e : expr) : tactic ℕ := do
ncoes ← count_coes e,
pure $ ncoes - count_head_coes e

/--
Classifies a declaration of type `ty` as a `norm_cast` rule.
-/
meta def classify_type (ty : expr) : tactic label := do
(_, ty) ← open_pis ty,
(lhs, rhs) ← match ty with
  | `(%%lhs = %%rhs) := pure (lhs, rhs)
  | `(%%lhs ↔ %%rhs) := pure (lhs, rhs)
  | _ := fail "norm_cast: lemma must be = or ↔"
  end,
lhs_coes ← count_coes lhs,
when (lhs_coes = 0) $ fail "norm_cast: badly shaped lemma, lhs must contain at least one coe",
let lhs_head_coes := count_head_coes lhs,
lhs_internal_coes ← count_internal_coes lhs,
let rhs_head_coes := count_head_coes rhs,
rhs_internal_coes ← count_internal_coes rhs,
if lhs_head_coes = 0 then
  return elim
else if lhs_head_coes = 1 then do
  when (rhs_head_coes ≠ 0) $ fail "norm_cast: badly shaped lemma, rhs can't start with coe",
  if rhs_internal_coes = 0 then
    return squash
  else
    return move
else if rhs_head_coes < lhs_head_coes then do
  return squash
else do
  fail "norm_cast: badly shaped shaped squash lemma, rhs must have fewer head coes than lhs"

/-- The cache for `norm_cast` attribute stores three `simp_lemma` objects. -/
meta structure norm_cast_cache :=
(up : simp_lemmas)
(down : simp_lemmas)
(squash : simp_lemmas)

/-- Empty `norm_cast_cache`. -/
meta def empty_cache : norm_cast_cache :=
{ up     := simp_lemmas.mk,
  down   := simp_lemmas.mk,
  squash := simp_lemmas.mk, }

meta instance : inhabited norm_cast_cache := ⟨empty_cache⟩

/-- `add_elim cache e` adds `e` as an `elim` lemma to `cache`. -/
meta def add_elim (cache : norm_cast_cache) (e : expr) : tactic norm_cast_cache :=
do
  new_up ← simp_lemmas.add cache.up e,
  return
  { up     := new_up,
    down   := cache.down,
    squash := cache.squash, }

/-- `add_move cache e` adds `e` as a `move` lemma to `cache`. -/
meta def add_move (cache : norm_cast_cache) (e : expr) : tactic norm_cast_cache :=
do
  ty ← infer_type e,
  new_up ← cache.up.add e tt,
  new_down ← simp_lemmas.add cache.down e,
  return {
    up     := new_up,
    down   := new_down,
    squash := cache.squash, }

/-- `add_squash cache e` adds `e` as an `squash` lemma to `cache`. -/
meta def add_squash (cache : norm_cast_cache) (e : expr) : tactic norm_cast_cache :=
do
  new_squash ← simp_lemmas.add cache.squash e,
  new_down ← simp_lemmas.add cache.down e,
  return {
    up     := cache.up,
    down   := new_down,
    squash := new_squash, }

/--
The type of the `norm_cast` attribute.
The optional label is used to overwrite the classifier.
-/
meta def norm_cast_attr_ty : Type := user_attribute norm_cast_cache (option label)

/--
Efficient getter for the `@[norm_cast]` attribute parameter that does not call `eval_expr`.

See Note [user attribute parameters].
-/
meta def get_label_param (attr : norm_cast_attr_ty) (decl : name) : tactic (option label) := do
p ← attr.get_param_untyped decl,
match p with
| `(none) := pure none
| `(some label.elim) := pure label.elim
| `(some label.move) := pure label.move
| `(some label.squash) := pure label.squash
| _ := fail p
end

/--
`add_lemma cache decl` infers the proper `norm_cast` attribute for `decl` and adds it to `cache`.
-/
meta def add_lemma (attr : norm_cast_attr_ty) (cache : norm_cast_cache) (decl : name) :
  tactic norm_cast_cache :=
do
  e ← mk_const decl,
  param ← get_label_param attr decl,
  l ← param <|> (infer_type e >>= classify_type),
  match l with
  | elim   := add_elim cache e
  | move   := add_move cache e
  | squash := add_squash cache e
  end

-- special lemmas to handle the ≥, > and ≠ operators
private lemma ge_from_le {α} [has_le α] : ∀ (x y : α), x ≥ y ↔ y ≤ x := λ _ _, iff.rfl
private lemma gt_from_lt {α} [has_lt α] : ∀ (x y : α), x > y ↔ y < x := λ _ _, iff.rfl
private lemma ne_from_not_eq {α} : ∀ (x y : α), x ≠ y ↔ ¬(x = y) := λ _ _, iff.rfl

/--
`mk_cache names` creates a `norm_cast_cache`. It infers the proper `norm_cast` attributes
for names in `names`, and collects the lemmas attributed with specific `norm_cast` attributes.
-/
meta def mk_cache (attr : thunk norm_cast_attr_ty) (names : list name) :
  tactic norm_cast_cache := do
-- names has the declarations in reverse order
cache ← names.mfoldr (λ name cache, add_lemma (attr ()) cache name) empty_cache,

--some special lemmas to handle binary relations
let up := cache.up,
up ← up.add_simp ``ge_from_le,
up ← up.add_simp ``gt_from_lt,
up ← up.add_simp ``ne_from_not_eq,

let down := cache.down,
down ← down.add_simp ``coe_coe,

pure { up := up, down := down, squash := cache.squash }

/--
The `norm_cast` attribute.
-/
@[user_attribute] meta def norm_cast_attr : user_attribute norm_cast_cache (option label) :=
{ name      := `norm_cast,
  descr     := "attribute for norm_cast",
  parser    :=
    (do some l ← (label.of_string ∘ to_string) <$> ident, return l)
      <|> return none,
  after_set := some (λ decl prio persistent, do
    param ← get_label_param norm_cast_attr decl,
    match param with
    | some l :=
      when (l ≠ elim) $ simp_attr.push_cast.set decl () tt
    | none := do
      e ← mk_const decl,
      ty ← infer_type e,
      l ← classify_type ty,
      norm_cast_attr.set decl l persistent prio
    end),
  before_unset := some $ λ _ _, tactic.skip,
  cache_cfg := { mk_cache := mk_cache norm_cast_attr, dependencies := [] } }

/-- Classify a declaration as a `norm_cast` rule. -/
meta def make_guess (decl : name) : tactic label :=
do
  e ← mk_const decl,
  ty ← infer_type e,
  classify_type ty

/--
Gets the `norm_cast` classification label for a declaration. Applies the
override specified on the attribute, if necessary.
-/
meta def get_label (decl : name) : tactic label :=
do
  param ← get_label_param norm_cast_attr decl,
  param <|> make_guess decl

end norm_cast

namespace tactic.interactive
open norm_cast

/--
`push_cast` rewrites the expression to move casts toward the leaf nodes.
For example, `↑(a + b)` will be written to `↑a + ↑b`.
Equivalent to `simp only with push_cast`.
Can also be used at hypotheses.

`push_cast` can also be used at hypotheses and with extra simp rules.

```lean
example (a b : ℕ) (h1 : ((a + b : ℕ) : ℤ) = 10) (h2 : ((a + b + 0 : ℕ) : ℤ) = 10) :
  ((a + b : ℕ) : ℤ) = 10 :=
begin
  push_cast,
  push_cast at h1,
  push_cast [int.add_zero] at h2,
end
```
-/
meta def push_cast (hs : parse tactic.simp_arg_list) (l : parse location) : tactic unit :=
tactic.interactive.simp none none tt hs [`push_cast] l

end tactic.interactive

namespace norm_cast
open tactic expr

/-- Prove `a = b` using the given simp set. -/
meta def prove_eq_using (s : simp_lemmas) (a b : expr) : tactic expr := do
(a', a_a', _) ← simplify s [] a {fail_if_unchanged := ff},
(b', b_b', _) ← simplify s [] b {fail_if_unchanged := ff},
on_exception (trace_norm_cast "failed: " (to_expr ``(%%a' = %%b') >>= pp)) $
  is_def_eq a' b' reducible,
b'_b ← mk_eq_symm b_b',
mk_eq_trans a_a' b'_b

/-- Prove `a = b` by simplifying using move and squash lemmas. -/
meta def prove_eq_using_down (a b : expr) : tactic expr := do
cache ← norm_cast_attr.get_cache,
trace_norm_cast "proving: " (to_expr ``(%%a = %%b) >>= pp),
prove_eq_using cache.down a b

/--
This is the main heuristic used alongside the elim and move lemmas.
The goal is to help casts move past operators by adding intermediate casts.
An expression of the shape: op (↑(x : α) : γ) (↑(y : β) : γ)
is rewritten to:            op (↑(↑(x : α) : β) : γ) (↑(y : β) : γ)
when (↑(↑(x : α) : β) : γ) = (↑(x : α) : γ) can be proven with a squash lemma
-/
meta def splitting_procedure : expr → tactic (expr × expr)
| (app (app op x) y) :=
(do
  `(@coe %%α %%δ %%coe1 %%xx) ← return x,
  `(@coe %%β %%γ %%coe2 %%yy) ← return y,
  success_if_fail $ is_def_eq α β,
  is_def_eq δ γ,

  (do
    coe3 ← mk_app `has_lift_t [α, β] >>= mk_instance_fast,
    new_x ← to_expr ``(@coe %%β %%δ %%coe2 (@coe %%α %%β %%coe3 %%xx)),
    let new_e := app (app op new_x) y,
    eq_x ← prove_eq_using_down x new_x,
    pr ← mk_congr_arg op eq_x,
    pr ← mk_congr_fun pr y,
    return (new_e, pr)
  ) <|> (do
    coe3 ← mk_app `has_lift_t [β, α] >>= mk_instance_fast,
    new_y ← to_expr ``(@coe %%α %%δ %%coe1 (@coe %%β %%α %%coe3 %%yy)),
    let new_e := app (app op x) new_y,
    eq_y ← prove_eq_using_down y new_y,
    pr ← mk_congr_arg (app op x) eq_y,
    return (new_e, pr)
  )
) <|> (do
  `(@coe %%α %%β %%coe1 %%xx) ← return x,
  `(@has_one.one %%β %%h1) ← return y,
  h2 ← to_expr ``(has_one %%α) >>= mk_instance_fast,
  new_y ← to_expr ``(@coe %%α %%β %%coe1 (@has_one.one %%α %%h2)),
  eq_y ← prove_eq_using_down y new_y,
  let new_e := app (app op x) new_y,
  pr ← mk_congr_arg (app op x) eq_y,
  return (new_e, pr)
 ) <|> (do
  `(@coe %%α %%β %%coe1 %%xx) ← return x,
  `(@has_zero.zero %%β %%h1) ← return y,
  h2 ← to_expr ``(has_zero %%α) >>= mk_instance_fast,
  new_y ← to_expr ``(@coe %%α %%β %%coe1 (@has_zero.zero %%α %%h2)),
  eq_y ← prove_eq_using_down y new_y,
  let new_e := app (app op x) new_y,
  pr ← mk_congr_arg (app op x) eq_y,
  return (new_e, pr)
) <|> (do
  `(@has_one.one %%β %%h1) ← return x,
  `(@coe %%α %%β %%coe1 %%xx) ← return y,
  h1 ← to_expr ``(has_one %%α) >>= mk_instance_fast,
  new_x ← to_expr ``(@coe %%α %%β %%coe1 (@has_one.one %%α %%h1)),
  eq_x ← prove_eq_using_down x new_x,
  let new_e := app (app op new_x) y,
  pr ← mk_congr_arg (lam `x binder_info.default β (app (app op (var 0)) y)) eq_x,
  return (new_e, pr)
) <|> (do
  `(@has_zero.zero %%β %%h1) ← return x,
  `(@coe %%α %%β %%coe1 %%xx) ← return y,
  h1 ← to_expr ``(has_zero %%α) >>= mk_instance_fast,
  new_x ← to_expr ``(@coe %%α %%β %%coe1 (@has_zero.zero %%α %%h1)),
  eq_x ← prove_eq_using_down x new_x,
  let new_e := app (app op new_x) y,
  pr ← mk_congr_arg (lam `x binder_info.default β (app (app op (var 0)) y)) eq_x,
  return (new_e, pr)
)
| _ := failed

/--
Discharging function used during simplification in the "squash" step.

TODO: norm_cast takes a list of expressions to use as lemmas for the discharger
TODO: a tactic to print the results the discharger fails to proove
-/
private meta def prove : tactic unit :=
assumption

/--
Core rewriting function used in the "squash" step, which moves casts upwards
and eliminates them.

It tries to rewrite an expression using the elim and move lemmas.
On failure, it calls the splitting procedure heuristic.
-/
meta def upward_and_elim (s : simp_lemmas) (e : expr) : tactic (expr × expr) :=
(do
  r ← mcond (is_prop e) (return `iff) (return `eq),
  (new_e, pr) ← s.rewrite e prove r,
  pr ← match r with
  | `iff := mk_app `propext [pr]
  | _    := return pr
  end,
  return (new_e, pr)
) <|> splitting_procedure e

/-!
The following auxiliary functions are used to handle numerals.
-/

/--
If possible, rewrite `(n : α)` to `((n : ℕ) : α)` where `n` is a numeral and `α ≠ ℕ`.
Returns a pair of the new expression and proof that they are equal.
-/
meta def numeral_to_coe (e : expr) : tactic (expr × expr) :=
do
  α ← infer_type e,
  success_if_fail $ is_def_eq α `(ℕ),
  n ← e.to_nat,
  h1 ← mk_app `has_lift_t [`(ℕ), α] >>= mk_instance_fast,
  let new_e : expr := reflect n,
  new_e ← to_expr ``(@coe ℕ %%α %%h1 %%new_e),
  pr ← prove_eq_using_down e new_e,
  return (new_e, pr)

/--
If possible, rewrite `((n : ℕ) : α)` to `(n : α)` where `n` is a numeral.
Returns a pair of the new expression and proof that they are equal.
-/
meta def coe_to_numeral (e : expr) : tactic (expr × expr) :=
do
  `(@coe ℕ %%α %%h1 %%e') ← return e,
  n ← e'.to_nat,
  -- replace e' by normalized numeral
  is_def_eq (reflect n) e' reducible,
  let e := e.app_fn (reflect n),
  new_e ← expr.of_nat α n,
  pr ← prove_eq_using_down e new_e,
  return (new_e, pr)

/-- A local variant on `simplify_top_down`. -/
private meta def simplify_top_down' {α} (a : α) (pre : α → expr → tactic (α × expr × expr))
  (e : expr) (cfg : simp_config := {}) : tactic (α × expr × expr) :=
ext_simplify_core a cfg simp_lemmas.mk (λ _, failed)
  (λ a _ _ _ e, do
    (new_a, new_e, pr) ← pre a e,
    guard (¬ new_e =ₐ e),
    return (new_a, new_e, some pr, ff))
  (λ _ _ _ _ _, failed)
  `eq e

/--
The core simplification routine of `norm_cast`.
-/
meta def derive (e : expr) : tactic (expr × expr) :=
do
  cache ← norm_cast_attr.get_cache,
  e ← instantiate_mvars e,
  let cfg : simp_config := {
    zeta := ff,
    beta := ff,
    eta  := ff,
    proj := ff,
    iota := ff,
    iota_eqn := ff,
    fail_if_unchanged := ff },
  let e0 := e,

  -- step 1: pre-processing of numerals
  ((), e1, pr1) ← simplify_top_down' () (λ _ e, prod.mk () <$> numeral_to_coe e) e0 cfg,
  trace_norm_cast "after numeral_to_coe: " e1,

  -- step 2: casts are moved upwards and eliminated
  ((), e2, pr2) ← simplify_bottom_up () (λ _ e, prod.mk () <$> upward_and_elim cache.up e) e1 cfg,
  trace_norm_cast "after upward_and_elim: " e2,

  -- step 3: casts are squashed
  (e3, pr3, _) ← simplify cache.squash [] e2 cfg,
  trace_norm_cast "after squashing: " e3,

  -- step 4: post-processing of numerals
  ((), e4, pr4) ← simplify_top_down' () (λ _ e, prod.mk () <$> coe_to_numeral e) e3 cfg,
  trace_norm_cast "after coe_to_numeral: " e4,

  let new_e := e4,
  guard (¬ new_e =ₐ e),
  pr ← mk_eq_trans pr1 pr2,
  pr ← mk_eq_trans pr pr3,
  pr ← mk_eq_trans pr pr4,
  return (new_e, pr)

/--
A small variant of `push_cast` suited for non-interactive use.

`derive_push_cast extra_lems e` returns an expression `e'` and a proof that `e = e'`.
-/
meta def derive_push_cast (extra_lems : list simp_arg_type) (e : expr) : tactic (expr × expr) :=
do (s, _) ← mk_simp_set tt [`push_cast] extra_lems,
   (e, prf, _) ← simplify (s.erase [`int.coe_nat_succ]) [] e {fail_if_unchanged := ff},
   return (e, prf)

end norm_cast

namespace tactic
open expr norm_cast

/-- `aux_mod_cast e` runs `norm_cast` on `e` and returns the result. If `include_goal` is true, it
also normalizes the goal. -/
meta def aux_mod_cast (e : expr) (include_goal : bool := tt) : tactic expr :=
match e with
| local_const _ lc _ _ := do
  e ← get_local lc,
  replace_at derive [e] include_goal,
  get_local lc
| e := do
  t ← infer_type e,
  e ← assertv `this t e,
  replace_at derive [e] include_goal,
  get_local `this
end

/-- `exact_mod_cast e` runs `norm_cast` on the goal and `e`, and tries to use `e` to close the
goal. -/
meta def exact_mod_cast (e : expr) : tactic unit :=
decorate_error "exact_mod_cast failed:" $ do
  new_e ← aux_mod_cast e,
  exact new_e

/-- `apply_mod_cast e` runs `norm_cast` on the goal and `e`, and tries to apply `e`. -/
meta def apply_mod_cast (e : expr) : tactic (list (name × expr)) :=
decorate_error "apply_mod_cast failed:" $ do
  new_e ← aux_mod_cast e,
  apply new_e

/-- `assumption_mod_cast` runs `norm_cast` on the goal. For each local hypothesis `h`, it also
normalizes `h` and tries to use that to close the goal. -/
meta def assumption_mod_cast : tactic unit :=
decorate_error "assumption_mod_cast failed:" $ do
  let cfg : simp_config := {
    fail_if_unchanged := ff,
    canonize_instances := ff,
    canonize_proofs := ff,
    proj := ff
  },
  replace_at derive [] tt,
  ctx ← local_context,
  try_lst $ ctx.map (λ h, aux_mod_cast h ff >>= tactic.exact)

end tactic

namespace tactic.interactive
open tactic norm_cast

/--
Normalize casts at the given locations by moving them "upwards".
As opposed to simp, norm_cast can be used without necessarily closing the goal.
-/
meta def norm_cast (loc : parse location) : tactic unit :=
do
  ns ← loc.get_locals,
  tt ← replace_at derive ns loc.include_goal | fail "norm_cast failed to simplify",
  when loc.include_goal $ try tactic.reflexivity,
  when loc.include_goal $ try tactic.triv,
  when (¬ ns.empty) $ try tactic.contradiction

/--
Rewrite with the given rules and normalize casts between steps.
-/
meta def rw_mod_cast (rs : parse rw_rules) (loc : parse location) : tactic unit :=
decorate_error "rw_mod_cast failed:" $ do
  let cfg_norm : simp_config := {},
  let cfg_rw : rewrite_cfg := {},
  ns ← loc.get_locals,
  monad.mapm' (λ r : rw_rule, do
    save_info r.pos,
    replace_at derive ns loc.include_goal,
    rw ⟨[r], none⟩ loc {}
  ) rs.rules,
  replace_at derive ns loc.include_goal,
  skip

/--
Normalize the goal and the given expression, then close the goal with exact.
-/
meta def exact_mod_cast (e : parse texpr) : tactic unit :=
do
  e ← i_to_expr e <|> do {
    ty ← target,
    e ← i_to_expr_strict ``(%%e : %%ty),
    pty ← pp ty, ptgt ← pp e,
    fail ("exact_mod_cast failed, expression type not directly " ++
    "inferrable. Try:\n\nexact_mod_cast ...\nshow " ++
    to_fmt pty ++ ",\nfrom " ++ ptgt : format)
  },
  tactic.exact_mod_cast e

/--
Normalize the goal and the given expression, then apply the expression to the goal.
-/
meta def apply_mod_cast (e : parse texpr) : tactic unit :=
do
  e ← i_to_expr_for_apply e,
  concat_tags $ tactic.apply_mod_cast e

/--
Normalize the goal and every expression in the local context, then close the goal with assumption.
-/
meta def assumption_mod_cast : tactic unit :=
tactic.assumption_mod_cast

end tactic.interactive

namespace conv.interactive
open conv
open norm_cast (derive)

/-- the converter version of `norm_cast' -/
meta def norm_cast : conv unit := replace_lhs derive

end conv.interactive

-- TODO: move this elsewhere?
@[norm_cast] lemma ite_cast {α β} [has_lift_t α β]
  {c : Prop} [decidable c] {a b : α} :
  ↑(ite c a b) = ite c (↑a : β) (↑b : β) :=
by by_cases h : c; simp [h]

@[norm_cast] lemma dite_cast {α β} [has_lift_t α β]
  {c : Prop} [decidable c] {a : c → α} {b : ¬ c → α} :
  ↑(dite c a b) = dite c (λ h, (↑(a h) : β)) (λ h, (↑(b h) : β)) :=
by by_cases h : c; simp [h]

add_hint_tactic "norm_cast at *"

/--
The `norm_cast` family of tactics is used to normalize casts inside expressions.
It is basically a simp tactic with a specific set of lemmas to move casts
upwards in the expression.
Therefore it can be used more safely as a non-terminating tactic.
It also has special handling of numerals.

For instance, given an assumption
```lean
a b : ℤ
h : ↑a + ↑b < (10 : ℚ)
```

writing `norm_cast at h` will turn `h` into
```lean
h : a + b < 10
```

You can also use `exact_mod_cast`, `apply_mod_cast`, `rw_mod_cast`
or `assumption_mod_cast`.
Writing `exact_mod_cast h` and `apply_mod_cast h` will normalize the goal and
`h` before using `exact h` or `apply h`.
Writing `assumption_mod_cast` will normalize the goal and for every
expression `h` in the context it will try to normalize `h` and use
`exact h`.
`rw_mod_cast` acts like the `rw` tactic but it applies `norm_cast` between steps.

`push_cast` rewrites the expression to move casts toward the leaf nodes.
This uses `norm_cast` lemmas in the forward direction.
For example, `↑(a + b)` will be written to `↑a + ↑b`.
It is equivalent to `simp only with push_cast`.
It can also be used at hypotheses with `push_cast at h`
and with extra simp lemmas with `push_cast [int.add_zero]`.

```lean
example (a b : ℕ) (h1 : ((a + b : ℕ) : ℤ) = 10) (h2 : ((a + b + 0 : ℕ) : ℤ) = 10) :
  ((a + b : ℕ) : ℤ) = 10 :=
begin
  push_cast,
  push_cast at h1,
  push_cast [int.add_zero] at h2,
end
```

The implementation and behavior of the `norm_cast` family is described in detail at
<https://lean-forward.github.io/norm_cast/norm_cast.pdf>.
-/
add_tactic_doc
{ name := "norm_cast",
  category   := doc_category.tactic,
  decl_names := [``tactic.interactive.norm_cast, ``tactic.interactive.rw_mod_cast,
                 ``tactic.interactive.apply_mod_cast, ``tactic.interactive.assumption_mod_cast,
                 ``tactic.interactive.exact_mod_cast, ``tactic.interactive.push_cast],
  tags       := ["coercions", "simplification"] }

/--
The `norm_cast` attribute should be given to lemmas that describe the
behaviour of a coercion in regard to an operator, a relation, or a particular
function.

It only concerns equality or iff lemmas involving `↑`, `⇑` and `↥`, describing the behavior of
the coercion functions.
It does not apply to the explicit functions that define the coercions.

Examples:
```lean
@[norm_cast] theorem coe_nat_inj' {m n : ℕ} : (↑m : ℤ) = ↑n ↔ m = n

@[norm_cast] theorem coe_int_denom (n : ℤ) : (n : ℚ).denom = 1

@[norm_cast] theorem cast_id : ∀ n : ℚ, ↑n = n

@[norm_cast] theorem coe_nat_add (m n : ℕ) : (↑(m + n) : ℤ) = ↑m + ↑n

@[norm_cast] theorem cast_sub [add_group α] [has_one α] {m n} (h : m ≤ n) :
  ((n - m : ℕ) : α) = n - m

@[norm_cast] theorem coe_nat_bit0 (n : ℕ) : (↑(bit0 n) : ℤ) = bit0 ↑n

@[norm_cast] theorem cast_coe_nat (n : ℕ) : ((n : ℤ) : α) = n

@[norm_cast] theorem cast_one : ((1 : ℚ) : α) = 1
```

Lemmas tagged with `@[norm_cast]` are classified into three categories: `move`, `elim`, and
`squash`. They are classified roughly as follows:

* elim lemma:   LHS has 0 head coes and ≥ 1 internal coe
* move lemma:   LHS has 1 head coe and 0 internal coes,    RHS has 0 head coes and ≥ 1 internal coes
* squash lemma: LHS has ≥ 1 head coes and 0 internal coes, RHS has fewer head coes

`norm_cast` uses `move` and `elim` lemmas to factor coercions toward the root of an expression
and to cancel them from both sides of an equation or relation. It uses `squash` lemmas to clean
up the result.

Occasionally you may want to override the automatic classification.
You can do this by giving an optional `elim`, `move`, or `squash` parameter to the attribute.

```lean
@[simp, norm_cast elim] lemma nat_cast_re (n : ℕ) : (n : ℂ).re = n :=
by rw [← of_real_nat_cast, of_real_re]
```

Don't do this unless you understand what you are doing.

A full description of the tactic, and the use of each lemma category, can be found at
<https://lean-forward.github.io/norm_cast/norm_cast.pdf>.
-/
add_tactic_doc
{ name := "norm_cast attributes",
  category   := doc_category.attr,
  decl_names := [``norm_cast.norm_cast_attr],
  tags       := ["coercions", "simplification"] }

-- Lemmas defined in core.
attribute [norm_cast]
  int.nat_abs_of_nat
  int.coe_nat_sub
  int.coe_nat_mul
  int.coe_nat_zero
  int.coe_nat_one
  int.coe_nat_add

-- Lemmas about nat.succ need to get a low priority, so that they are tried last.
-- This is because `nat.succ _` matches `1`, `3`, `x+1`, etc.
-- Rewriting would then produce really wrong terms.
attribute [norm_cast, priority 500] int.coe_nat_succ


open Lean.Parser.Tactic in
macro "rw0" s:rwRuleSeq : tactic =>
  `(rw (config := { offsetCnstrs := false }) $s:rwRuleSeq)

example (m n : Nat) : Nat.ble (n+1) (n+0) = false := by
  rw0 [Nat.add_zero]
  trace_state
  admit