-- Copyright (c) 2018 Scott Morrison. All rights reserved.
-- Released under Apache 2.0 license as described in the file LICENSE.
-- Authors: Scott Morrison, Mario Carneiro

import tactic
import data.option.defs

open interactive

namespace tactic

/-
This file defines a `chain` tactic, which takes a list of tactics, and exhaustively tries to apply them
to the goals, until no tactic succeeds on any goal.

Along the way, it generates auxiliary declarations, in order to speed up elaboration time
of the resulting (sometimes long!) proofs.

This tactic is used by the `tidy` tactic.
-/

-- α is the return type of our tactics. When `chain` is called by `tidy`, this is string,
-- describing what that tactic did as an interactive tactic.
variable {α : Type}

/-
Because chain sometimes pauses work on the first goal and works on later goals, we need a method
for combining a list of results generated while working on a later goal into a single result.
This enables `tidy {trace_result := tt}` to output faithfully reproduces its operation, e.g.
````
intros,
simp,
apply lemma_1,
work_on_goal 2 {
  dsimp,
  simp
},
refl
````
-/

namespace interactive
open lean.parser
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)
end interactive

inductive tactic_script (α : Type) : Type
| base : α → tactic_script
| work (index : ℕ) (first : α) (later : list tactic_script) (closed : bool) : tactic_script

meta def tactic_script.to_string : tactic_script string → string
| (tactic_script.base a) := a
| (tactic_script.work n a l c) := "work_on_goal " ++ (to_string n) ++ " { " ++ (", ".intercalate (a :: l.map tactic_script.to_string)) ++ " }"

meta instance : has_to_string (tactic_script string) :=
{ to_string := λ s, s.to_string }

meta instance tactic_script_unit_has_to_string : has_to_string (tactic_script unit) :=
{ to_string := λ s, "[chain tactic]" }

meta def abstract_if_success (tac : expr → tactic α) (g : expr) : tactic α :=
do
  type ← infer_type g,
  is_lemma ← is_prop type,
  if is_lemma then -- there's no point making the abstraction, and indeed it's slower
    tac g
  else do
    m ← mk_meta_var type,
    a ← tac m,
    do {
      val ← instantiate_mvars m,
      guard (val.list_meta_vars = []),
      c  ← new_aux_decl_name,
      gs ← get_goals,
      set_goals [g],
      add_aux_decl c type val ff >>= unify g,
      set_goals gs }
    <|> unify m g,
    return a

/--
`chain_many tac` recursively tries `tac` on all goals, working depth-first on generated subgoals,
until it no longer succeeds on any goal. `chain_many` automatically makes auxiliary definitions.
-/
meta mutual def chain_single, chain_many, chain_iter {α} (tac : tactic α)
with chain_single : expr → tactic (α × list (tactic_script α)) | g :=
do set_goals [g],
  a ← tac,
  l ← get_goals >>= chain_many,
  return (a, l)
with chain_many : list expr → tactic (list (tactic_script α))
| [] := return []
| [g] := do {
  (a, l) ← chain_single g,
  return (tactic_script.base a :: l) } <|> return []
| gs := chain_iter gs []
with chain_iter : list expr → list expr → tactic (list (tactic_script α))
| [] _ := return []
| (g :: later_goals) stuck_goals := do {
  (a, l) ← abstract_if_success chain_single g,
  new_goals ← get_goals,
  let w := tactic_script.work stuck_goals.length a l (new_goals = []),
  let current_goals := stuck_goals.reverse ++ new_goals ++ later_goals,
  set_goals current_goals, -- we keep the goals up to date, so they are correct at the end
  l' ← chain_many current_goals,
  return (w :: l') } <|> chain_iter later_goals (g :: stuck_goals)

meta def chain_core {α : Type} [has_to_string (tactic_script α)] (tactics : list (tactic α)) : tactic (list string) :=
do results ← (get_goals >>= chain_many (first tactics)),
   when results.empty (fail "`chain` tactic made no progress"),
   return (results.map to_string)

variables [has_to_string (tactic_script α)] [has_to_format α]

declare_trace chain

meta def trace_output (t : tactic α) : tactic α :=
do tgt ← target,
   r ← t,
   name ← decl_name,
   trace format!"`chain` successfully applied a tactic during elaboration of {name}:",
   tgt ← pp tgt,
   trace format!"previous target: {tgt}",
   trace format!"tactic result: {r}",
   tgt ← try_core target,
   tgt ← match tgt with
          | (some tgt) := pp tgt
          | none       := return "no goals"
          end,
   trace format!"new target: {tgt}",
   pure r

meta def chain (tactics : list (tactic α)) : tactic (list string) :=
if is_trace_enabled_for `chain then
  chain_core (tactics.map trace_output)
else
  chain_core tactics

end tactic


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

namespace Lean.Compiler
namespace CSimp

structure Entry where
  fromDeclName : Name
  toDeclName   : Name
  thmName      : Name
  deriving Inhabited

structure State where
  map : SMap Name Name := {}
  thmNames : SSet Name := {}
  deriving Inhabited

def State.switch : State → State
  | { map, thmNames } => { map := map.switch, thmNames := thmNames.switch }

builtin_initialize ext : SimpleScopedEnvExtension Entry State ←
  registerSimpleScopedEnvExtension {
    initial        := {}
    addEntry       := fun { map, thmNames } { fromDeclName, toDeclName, thmName } => { map := map.insert fromDeclName toDeclName, thmNames := thmNames.insert thmName }
    finalizeImport := fun s => s.switch
  }

private def isConstantReplacement? (declName : Name) : CoreM (Option Entry) := do
  let info ← getConstInfo declName
  match info.type.eq? with
  | some (_, Expr.const fromDeclName us .., Expr.const toDeclName vs ..) =>
    if us == vs then
      return some { fromDeclName, toDeclName, thmName := declName }
    else
      return none
  | _ => return none

def add (declName : Name) (kind : AttributeKind) : CoreM Unit := do
  if let some entry ← isConstantReplacement? declName then
    ext.add entry kind
  else
    throwError "invalid 'csimp' theorem, only constant replacement theorems (e.g., `@f = @g`) are currently supported."

builtin_initialize
  registerBuiltinAttribute {
    name  := `csimp
    descr := "simplification theorem for the compiler"
    add   := fun declName stx attrKind => do
      Attribute.Builtin.ensureNoArgs stx
      discard <| add declName attrKind
  }

@[export lean_csimp_replace_constants]
def replaceConstants (env : Environment) (e : Expr) : Expr :=
  let s := ext.getState env
  e.replace fun e =>
    if e.isConst then
      match s.map.find? e.constName! with
      | some declNameNew => some (mkConst declNameNew e.constLevels!)
      | none => none
    else
      none

end CSimp

def hasCSimpAttribute (env : Environment) (declName : Name) : Bool :=
  CSimp.ext.getState env |>.thmNames.contains declName

end Lean.Compiler


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

Instances of `traversable` for types from the core library
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.list.forall2
import Mathlib.data.set.lattice
import Mathlib.control.traversable.lemmas
import Mathlib.PostPort

universes u_1 u

namespace Mathlib

theorem option.id_traverse {α : Type u_1} (x : Option α) : option.traverse id.mk x = x :=
  option.cases_on x (Eq.refl (option.traverse id.mk none))
    fun (x : α) => Eq.refl (option.traverse id.mk (some x))

theorem option.comp_traverse {F : Type u → Type u} {G : Type u → Type u} [Applicative F]
    [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G] {α : Type u_1} {β : Type u}
    {γ : Type u} (f : β → F γ) (g : α → G β) (x : Option α) :
    option.traverse (functor.comp.mk ∘ Functor.map f ∘ g) x =
        functor.comp.mk (option.traverse f <$> option.traverse g x) :=
  sorry

theorem option.traverse_eq_map_id {α : Type u_1} {β : Type u_1} (f : α → β) (x : Option α) :
    traverse (id.mk ∘ f) x = id.mk (f <$> x) :=
  option.cases_on x (Eq.refl (traverse (id.mk ∘ f) none))
    fun (x : α) => Eq.refl (traverse (id.mk ∘ f) (some x))

theorem option.naturality {F : Type u → Type u} {G : Type u → Type u} [Applicative F]
    [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G]
    (η : applicative_transformation F G) {α : Type u_1} {β : Type u} (f : α → F β) (x : Option α) :
    coe_fn η (Option β) (option.traverse f x) = option.traverse (coe_fn η β ∘ f) x :=
  sorry

protected instance option.is_lawful_traversable : is_lawful_traversable Option :=
  is_lawful_traversable.mk option.id_traverse option.comp_traverse option.traverse_eq_map_id
    option.naturality

namespace list

protected theorem id_traverse {α : Type u_1} (xs : List α) : list.traverse id.mk xs = xs := sorry

protected theorem comp_traverse {F : Type u → Type u} {G : Type u → Type u} [Applicative F]
    [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G] {α : Type u_1} {β : Type u}
    {γ : Type u} (f : β → F γ) (g : α → G β) (x : List α) :
    list.traverse (functor.comp.mk ∘ Functor.map f ∘ g) x =
        functor.comp.mk (list.traverse f <$> list.traverse g x) :=
  sorry

protected theorem traverse_eq_map_id {α : Type u_1} {β : Type u_1} (f : α → β) (x : List α) :
    list.traverse (id.mk ∘ f) x = id.mk (f <$> x) :=
  sorry

protected theorem naturality {F : Type u → Type u} {G : Type u → Type u} [Applicative F]
    [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G]
    (η : applicative_transformation F G) {α : Type u_1} {β : Type u} (f : α → F β) (x : List α) :
    coe_fn η (List β) (list.traverse f x) = list.traverse (coe_fn η β ∘ f) x :=
  sorry

protected instance is_lawful_traversable : is_lawful_traversable List :=
  is_lawful_traversable.mk list.id_traverse list.comp_traverse list.traverse_eq_map_id
    list.naturality

@[simp] theorem traverse_nil {F : Type u → Type u} [Applicative F] {α' : Type u} {β' : Type u}
    (f : α' → F β') : traverse f [] = pure [] :=
  rfl

@[simp] theorem traverse_cons {F : Type u → Type u} [Applicative F] {α' : Type u} {β' : Type u}
    (f : α' → F β') (a : α') (l : List α') :
    traverse f (a :: l) = (fun (_x : β') (_y : List β') => _x :: _y) <$> f a <*> traverse f l :=
  rfl

@[simp] theorem traverse_append {F : Type u → Type u} [Applicative F] {α' : Type u} {β' : Type u}
    (f : α' → F β') [is_lawful_applicative F] (as : List α') (bs : List α') :
    traverse f (as ++ bs) = append <$> traverse f as <*> traverse f bs :=
  sorry

theorem mem_traverse {α' : Type u} {β' : Type u} {f : α' → set β'} (l : List α') (n : List β') :
    n ∈ traverse f l ↔ forall₂ (fun (b : β') (a : α') => b ∈ f a) n l :=
  sorry

end list

namespace sum

protected theorem traverse_map {σ : Type u} {G : Type u → Type u} [Applicative G] {α : Type u}
    {β : Type u} {γ : Type u} (g : α → β) (f : β → G γ) (x : σ ⊕ α) :
    sum.traverse f (g <$> x) = sum.traverse (f ∘ g) x :=
  sorry

protected theorem id_traverse {σ : Type u_1} {α : Type u_1} (x : σ ⊕ α) :
    sum.traverse id.mk x = x :=
  sum.cases_on x (fun (x : σ) => Eq.refl (sum.traverse id.mk (inl x)))
    fun (x : α) => Eq.refl (sum.traverse id.mk (inr x))

protected theorem comp_traverse {σ : Type u} {F : Type u → Type u} {G : Type u → Type u}
    [Applicative F] [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G]
    {α : Type u_1} {β : Type u} {γ : Type u} (f : β → F γ) (g : α → G β) (x : σ ⊕ α) :
    sum.traverse (functor.comp.mk ∘ Functor.map f ∘ g) x =
        functor.comp.mk (sum.traverse f <$> sum.traverse g x) :=
  sorry

protected theorem traverse_eq_map_id {σ : Type u} {α : Type u} {β : Type u} (f : α → β)
    (x : σ ⊕ α) : sum.traverse (id.mk ∘ f) x = id.mk (f <$> x) :=
  sorry

protected theorem map_traverse {σ : Type u} {G : Type u → Type u} [Applicative G]
    [is_lawful_applicative G] {α : Type u_1} {β : Type u} {γ : Type u} (g : α → G β) (f : β → γ)
    (x : σ ⊕ α) : Functor.map f <$> sum.traverse g x = sum.traverse (Functor.map f ∘ g) x :=
  sorry

protected theorem naturality {σ : Type u} {F : Type u → Type u} {G : Type u → Type u}
    [Applicative F] [Applicative G] [is_lawful_applicative F] [is_lawful_applicative G]
    (η : applicative_transformation F G) {α : Type u_1} {β : Type u} (f : α → F β) (x : σ ⊕ α) :
    coe_fn η (σ ⊕ β) (sum.traverse f x) = sum.traverse (coe_fn η β ∘ f) x :=
  sorry

protected instance is_lawful_traversable {σ : Type u} : is_lawful_traversable (sum σ) :=
  is_lawful_traversable.mk sum.id_traverse sum.comp_traverse sum.traverse_eq_map_id sum.naturality

end Mathlib


set_option trace.Elab true
theorem ex (h : a = b) : (fun x => x) a = b := by
  simp (config := { beta := false })
  trace_state
  simp (config := { beta := true }) [h]


/-
Copyright (c) 2017 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import algebra.group.defs
import control.functor

/-!
# `applicative` instances

This file provides `applicative` instances for concrete functors:
* `id`
* `functor.comp`
* `functor.const`
* `functor.add_const`
-/

universes u v w

section lemmas

open function

variables {F : Type u → Type v}
variables [applicative F] [is_lawful_applicative F]
variables {α β γ σ : Type u}

lemma applicative.map_seq_map (f : α → β → γ) (g : σ → β) (x : F α) (y : F σ) :
  (f <$> x) <*> (g <$> y) = (flip (∘) g ∘ f) <$> x <*> y :=
by simp [flip] with functor_norm

lemma applicative.pure_seq_eq_map' (f : α → β) : (<*>) (pure f : F (α → β)) = (<$>) f :=
by ext; simp with functor_norm

theorem applicative.ext {F} : ∀ {A1 : applicative F} {A2 : applicative F}
  [@is_lawful_applicative F A1] [@is_lawful_applicative F A2]
  (H1 : ∀ {α : Type u} (x : α),
    @has_pure.pure _ A1.to_has_pure _ x = @has_pure.pure _ A2.to_has_pure _ x)
  (H2 : ∀ {α β : Type u} (f : F (α → β)) (x : F α),
    @has_seq.seq _ A1.to_has_seq _ _ f x = @has_seq.seq _ A2.to_has_seq _ _ f x),
  A1 = A2
| {to_functor := F1, seq := s1, pure := p1, seq_left := sl1, seq_right := sr1}
  {to_functor := F2, seq := s2, pure := p2, seq_left := sl2, seq_right := sr2} L1 L2 H1 H2 :=
begin
  obtain rfl : @p1 = @p2, {funext α x, apply H1},
  obtain rfl : @s1 = @s2, {funext α β f x, apply H2},
  cases L1, cases L2,
  obtain rfl : F1 = F2,
  { resetI, apply functor.ext, intros,
    exact (L1_pure_seq_eq_map _ _).symm.trans (L2_pure_seq_eq_map _ _) },
  congr; funext α β x y,
  { exact (L1_seq_left_eq _ _).trans (L2_seq_left_eq _ _).symm },
  { exact (L1_seq_right_eq _ _).trans (L2_seq_right_eq _ _).symm }
end

end lemmas

instance : is_comm_applicative id :=
by refine { .. }; intros; refl

namespace functor
namespace comp

open function (hiding comp)
open functor

variables {F : Type u → Type w} {G : Type v → Type u}

variables [applicative F] [applicative G]

variables [is_lawful_applicative F] [is_lawful_applicative G]
variables {α β γ : Type v}

lemma map_pure (f : α → β) (x : α) : (f <$> pure x : comp F G β) = pure (f x) :=
comp.ext $ by simp

lemma seq_pure (f : comp F G (α → β)) (x : α) :
  f <*> pure x = (λ g : α → β, g x) <$> f :=
comp.ext $ by simp [(∘)] with functor_norm

lemma pure_seq_eq_map (f : α → β) (x : comp F G α) :
  pure f <*> x = f <$> x :=
comp.ext $ by simp [applicative.pure_seq_eq_map'] with functor_norm

instance : is_lawful_applicative (comp F G) :=
{ pure_seq_eq_map := @comp.pure_seq_eq_map F G _ _ _ _,
  map_pure := @comp.map_pure F G _ _ _ _,
  seq_pure := @comp.seq_pure F G _ _ _ _,
  seq_assoc := @comp.seq_assoc F G _ _ _ _ }

theorem applicative_id_comp {F} [AF : applicative F] [LF : is_lawful_applicative F] :
  @comp.applicative id F _ _ = AF :=
@applicative.ext F _ _ (@comp.is_lawful_applicative id F _ _ _ _) _
  (λ α x, rfl) (λ α β f x, rfl)

theorem applicative_comp_id {F} [AF : applicative F] [LF : is_lawful_applicative F] :
  @comp.applicative F id _ _ = AF :=
@applicative.ext F _ _ (@comp.is_lawful_applicative F id _ _ _ _) _
  (λ α x, rfl) (λ α β f x, show id <$> f <*> x = f <*> x, by rw id_map)

open is_comm_applicative

instance {f : Type u → Type w} {g : Type v → Type u}
  [applicative f] [applicative g]
  [is_comm_applicative f] [is_comm_applicative g] :
  is_comm_applicative (comp f g) :=
by { refine { .. @comp.is_lawful_applicative f g _ _ _ _, .. },
     intros, casesm* comp _ _ _, simp! [map,has_seq.seq] with functor_norm,
     rw [commutative_map],
     simp [comp.mk,flip,(∘)] with functor_norm,
     congr, funext, rw [commutative_map], congr }

end comp
end functor

open functor

@[functor_norm]
lemma comp.seq_mk {α β : Type w}
  {f : Type u → Type v} {g : Type w → Type u}
  [applicative f] [applicative g]
  (h : f (g (α → β))) (x : f (g α)) :
  comp.mk h <*> comp.mk x = comp.mk (has_seq.seq <$> h <*> x) := rfl

instance {α} [has_one α] [has_mul α] : applicative (const α) :=
{ pure := λ β x, (1 : α),
  seq := λ β γ f x, (f * x : α) }

instance {α} [monoid α] : is_lawful_applicative (const α) :=
by refine { .. }; intros; simp [mul_assoc, (<$>), (<*>), pure]

instance {α} [has_zero α] [has_add α] : applicative (add_const α) :=
{ pure := λ β x, (0 : α),
  seq := λ β γ f x, (f + x : α) }

instance {α} [add_monoid α] : is_lawful_applicative (add_const α) :=
by refine { .. }; intros; simp [add_assoc, (<$>), (<*>), pure]


/-
Copyright (c) 2018 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Mario Carneiro
-/
import tactic.ext

open interactive

namespace tactic

/-
This file defines a `chain` tactic, which takes a list of tactics,
and exhaustively tries to apply them to the goals, until no tactic succeeds on any goal.

Along the way, it generates auxiliary declarations, in order to speed up elaboration time
of the resulting (sometimes long!) proofs.

This tactic is used by the `tidy` tactic.
-/

-- α is the return type of our tactics. When `chain` is called by `tidy`, this is string,
-- describing what that tactic did as an interactive tactic.
variable {α : Type}

inductive tactic_script (α : Type) : Type
| base : α → tactic_script
| work (index : ℕ) (first : α) (later : list tactic_script) (closed : bool) : tactic_script

meta def tactic_script.to_string : tactic_script string → string
| (tactic_script.base a) := a
| (tactic_script.work n a l c) :=  "work_on_goal " ++ (to_string n) ++
    " { " ++ (", ".intercalate (a :: l.map tactic_script.to_string)) ++ " }"

meta instance : has_to_string (tactic_script string) :=
{ to_string := λ s, s.to_string }

meta instance tactic_script_unit_has_to_string : has_to_string (tactic_script unit) :=
{ to_string := λ s, "[chain tactic]" }

meta def abstract_if_success (tac : expr → tactic α) (g : expr) : tactic α :=
do
  type ← infer_type g,
  is_lemma ← is_prop type,
  if is_lemma then -- there's no point making the abstraction, and indeed it's slower
    tac g
  else do
    m ← mk_meta_var type,
    a ← tac m,
    do {
      val ← instantiate_mvars m,
      guard (val.list_meta_vars = []),
      c  ← new_aux_decl_name,
      gs ← get_goals,
      set_goals [g],
      add_aux_decl c type val ff >>= unify g,
      set_goals gs }
    <|> unify m g,
    return a

/--
`chain_many tac` recursively tries `tac` on all goals, working depth-first on generated subgoals,
until it no longer succeeds on any goal. `chain_many` automatically makes auxiliary definitions.
-/
meta mutual def chain_single, chain_many, chain_iter {α} (tac : tactic α)
with chain_single : expr → tactic (α × list (tactic_script α)) | g :=
do set_goals [g],
  a ← tac,
  l ← get_goals >>= chain_many,
  return (a, l)
with chain_many : list expr → tactic (list (tactic_script α))
| [] := return []
| [g] := do {
  (a, l) ← chain_single g,
  return (tactic_script.base a :: l) } <|> return []
| gs := chain_iter gs []
with chain_iter : list expr → list expr → tactic (list (tactic_script α))
| [] _ := return []
| (g :: later_goals) stuck_goals := do {
  (a, l) ← abstract_if_success chain_single g,
  new_goals ← get_goals,
  let w := tactic_script.work stuck_goals.length a l (new_goals = []),
  let current_goals := stuck_goals.reverse ++ new_goals ++ later_goals,
  set_goals current_goals, -- we keep the goals up to date, so they are correct at the end
  l' ← chain_many current_goals,
  return (w :: l') } <|> chain_iter later_goals (g :: stuck_goals)

meta def chain_core {α : Type} [has_to_string (tactic_script α)] (tactics : list (tactic α)) :
  tactic (list string) :=
do results ← (get_goals >>= chain_many (first tactics)),
   when results.empty (fail "`chain` tactic made no progress"),
   return (results.map to_string)

variables [has_to_string (tactic_script α)] [has_to_format α]

declare_trace chain

meta def trace_output (t : tactic α) : tactic α :=
do tgt ← target,
   r ← t,
   name ← decl_name,
   trace format!"`chain` successfully applied a tactic during elaboration of {name}:",
   tgt ← pp tgt,
   trace format!"previous target: {tgt}",
   trace format!"tactic result: {r}",
   tgt ← try_core target,
   tgt ← match tgt with
          | (some tgt) := pp tgt
          | none       := return "no goals"
          end,
   trace format!"new target: {tgt}",
   pure r

meta def chain (tactics : list (tactic α)) : tactic (list string) :=
chain_core
  (if is_trace_enabled_for `chain then (tactics.map trace_output) else tactics)

end tactic


import data.buffer data.dlist

instance (α : Type) [has_to_string α] : has_to_string (buffer α) :=
⟨ fun b, to_string $ b.to_list ⟩

universes u v

inductive parse_result (α : Type u)
| done (pos : ℕ) (result : α) : parse_result
| fail (pos : ℕ) (expected : dlist string) : parse_result

def parser (elem : Type v) (α : Type u) :=
∀ (input : buffer elem) (start : ℕ), parse_result α

-- todo: refactor into parser core
namespace parser

-- Type polymorphism is restricted here because of monad.bind
variables {elem α β γ : Type}

protected def bind (p : parser elem α) (f : α → parser elem β) : parser elem β :=
λ input pos, match p input pos with
| parse_result.done pos a           := f a input pos
| parse_result.fail ._ pos expected := parse_result.fail β pos expected
end

protected def pure (a : α) : parser elem α :=
λ input pos, parse_result.done pos a

private lemma id_map (p : parser elem α) : parser.bind p parser.pure = p :=
begin
apply funext, intro input,
apply funext, intro pos,
dunfold parser.bind,
cases (p input pos); exact rfl
end

private lemma bind_assoc (p : parser elem α) (q : α → parser elem β) (r : β → parser elem γ) :
  parser.bind (parser.bind p q) r = parser.bind p (λ a, parser.bind (q a) r) :=
begin
apply funext, intro input,
apply funext, intro pos,
dunfold parser.bind,
cases (p input pos); try {dunfold bind},
cases (q result input pos_1); try {dunfold bind},
all_goals {refl}
end

protected def fail (msg : string) : parser elem α :=
λ _ pos, parse_result.fail α pos (dlist.singleton msg)

instance : monad_fail (parser elem) :=
{ pure := @parser.pure elem,
  bind := @parser.bind elem,
  fail := @parser.fail elem,
  id_map := @id_map elem,
  pure_bind := λ _ _ _ _, rfl,
  bind_assoc := @bind_assoc elem }

protected def failure : parser elem α :=
λ _ pos, parse_result.fail α pos dlist.empty

protected def orelse (p q : parser elem α) : parser elem α :=
λ input pos, match p input pos with
| parse_result.fail ._ pos₁ expected₁ :=
  if pos₁ ≠ pos then parse_result.fail _ pos₁ expected₁ else
  match q input pos with
  | parse_result.fail ._ pos₂ expected₂ :=
    if pos₁ < pos₂ then
      parse_result.fail _ pos₁ expected₁
    else if pos₂ < pos₁ then
      parse_result.fail _ pos₂ expected₂
    else -- pos₁ = pos₂
      parse_result.fail _ pos₁ (expected₁ ++ expected₂)
  | ok := ok
  end
  | ok := ok
end

instance : alternative (parser elem) :=
{ parser.monad_fail with
  failure := @parser.failure elem,
  orelse := @parser.orelse elem }

instance : inhabited (parser elem α) :=
⟨parser.failure⟩

/-- Overrides the expected token name, and does not consume input on failure. -/
def decorate_errors (msgs : thunk (list string)) (p : parser elem α) : parser elem α :=
λ input pos, match p input pos with
| parse_result.fail ._ _ expected :=
  parse_result.fail _  pos (dlist.lazy_of_list (msgs ()))
| ok := ok
end

/-- Overrides the expected token name, and does not consume input on failure. -/
def decorate_error (msg : thunk string) (p : parser elem α) : parser elem α :=
decorate_errors [msg ()] p

/-- Matches a single character satisfying the given predicate. -/
def sat (p : elem → Prop) [decidable_pred p] : parser elem elem :=
λ input pos,
if h : pos < input.size then
  let c := input.read ⟨pos, h⟩ in
  if p c then
    parse_result.done (pos+1) $ input.read ⟨pos, h⟩
  else
    parse_result.fail _ pos dlist.empty
else
  parse_result.fail _ pos dlist.empty

/-- Matches the empty word. -/
def eps : parser elem unit := return ()

/-- Matches the given character. -/
def el [decidable_eq elem] [has_to_string elem] (e : elem) : parser elem unit :=
decorate_error (to_string e) $ sat (= e) >> eps

/-- Matches a whole char_buffer.  Does not consume input in case of failure. -/
def buf [decidable_eq elem] [has_to_string elem] (buf : buffer elem) : parser elem unit :=
decorate_error (to_string buf) $ buf.to_list.mmap' el

/-- Matches one out of a list of characters. -/
def one_of [decidable_eq elem] [has_to_string elem] (cs : list elem) : parser elem elem :=
decorate_errors (do c ← cs, return (to_string c)) $
sat (∈ cs)

def one_of' [decidable_eq elem] [has_to_string elem] (cs : list elem) : parser elem unit :=
one_of cs >> eps

/-- Number of remaining input characters. -/
def remaining : parser elem ℕ :=
λ input pos, parse_result.done pos (input.size - pos)

/-- Matches the end of the input. -/
def eof : parser elem unit :=
decorate_error "<end-of-file>" $
do rem ← remaining, guard $ rem = 0

def foldr_core (f : α → β → β) (p : parser elem α) (b : β) : ∀ (reps : ℕ), parser elem β
| 0 := failure
| (reps+1) := (do x ← p, xs ← foldr_core reps, return (f x xs)) <|> return b

/-- Matches zero or more occurrences of `p`, and folds the result. -/
def foldr (f : α → β → β) (p : parser elem α) (b : β) : parser elem β :=
λ input pos, foldr_core f p b (input.size - pos + 1) input pos

def foldl_core (f : α → β → α) : ∀ (a : α) (p : parser elem β) (reps : ℕ), parser elem α
| a p 0 := failure
| a p (reps+1) := (do x ← p, foldl_core (f a x) p reps) <|> return a

/-- Matches zero or more occurrences of `p`, and folds the result. -/
def foldl (f : α → β → α) (a : α) (p : parser elem β) : parser elem α :=
λ input pos, foldl_core f a p (input.size - pos + 1) input pos

def choice (ps : list (parser elem α)) : parser elem α :=
  ps.foldr (<|>) failure

/-- Matches zero or more occurrences of `p`. -/
def many (p : parser elem α) : parser elem (list α) :=
foldr list.cons p []

/-- Matches zero or more occurrences of `p`. -/
def many' (p : parser elem α) : parser elem unit :=
many p >> eps

/-- Matches one or more occurrences of `p`. -/
def many1 (p : parser elem α) : parser elem (list α) :=
list.cons <$> p <*> many p

def many_char1 (p : parser elem char) : parser elem string :=
list.as_string <$> many1 p

/-- Matches one or more occurrences of `p`, separated by `sep`. -/
def sep_by1 (sep : parser elem unit) (p : parser elem α) : parser elem (list α) :=
list.cons <$> p <*> many (sep >> p)

/-- Matches zero or more occurrences of `p`, separated by `sep`. -/
def sep_by (sep : parser elem unit) (p : parser elem α) : parser elem (list α) :=
sep_by1 sep p <|> return []

/-- An implementation of `try` from other parser combinator libraries,
    ensures that the parser does not consume input. -/
def try {elem α : Type u} (p : parser elem α) : parser elem α :=
λ input pos, match p input pos with
  | parse_result.fail ._ _ expected1 := parse_result.fail _ pos expected1
  | succ := succ
  end

def fix_core (F : parser elem α → parser elem α) : ∀ (max_depth : ℕ), parser elem α
| 0             := failure
| (max_depth+1) := F (fix_core max_depth)

/-- Fixpoint combinator satisfying `fix F = F (fix F)`. -/
def fix (F : parser elem α → parser elem α) : parser elem α :=
λ input pos, fix_core F (input.size - pos + 1) input pos

def fix_core_fn {β : Type} (F : (β → parser elem α) → (β → parser elem α)) : ∀ (max_depth : ℕ), β → parser elem α
| 0             a := failure
| (max_depth+1) a := F (fix_core_fn max_depth) a

/-- Fixpoint combinator satisfying `fix F = F (fix F)`. -/
def fix_fn {β : Type} (F : (β → parser elem α) → (β → parser elem α)) : β → parser elem α :=
λ a input pos, fix_core_fn F (input.size - pos + 1) a input pos

private def make_monospaced : char → char
| '\n' := ' '
| '\t' := ' '
| '\x0d' := ' '
| c := c

def mk_error_msg {elem : Type} [has_to_string elem] (input : buffer elem) (pos : ℕ) (expected : dlist string) : char_buffer :=
let left_ctx := (input.take pos).take_right 10,
    right_ctx := (input.drop pos).take 10 in
(to_string left_ctx).to_char_buffer ++ (to_string right_ctx).to_char_buffer ++ "\n".to_char_buffer ++
/- left_ctx.map (λ _, ' ') ++ -/ "^\n".to_char_buffer ++
"\n".to_char_buffer ++
"expected: ".to_char_buffer
  ++ string.to_char_buffer (" | ".intercalate expected.to_list)
  ++ "\n".to_char_buffer

/-- Runs a parser on the given input.  The parser needs to match the complete input. -/
def run [has_to_string elem] (p : parser elem α) (input : buffer elem) : sum string α :=
match (p <* eof) input 0 with
| parse_result.done pos res := sum.inr res
| parse_result.fail ._ pos expected :=
  sum.inl $ (mk_error_msg input pos expected).to_string
end

end parser


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn, Robert Y. Lewis, Arthur Paulino

! This file was ported from Lean 3 source module tactic.lint.misc
! leanprover-community/mathlib commit 58d83ed5268d96bd37757ac03062a4d69e5aa435
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Bool.Basic
import Mathbin.Meta.RbMap
import Mathbin.Tactic.Lint.Basic

/-!
# Various linters

This file defines several small linters:
  - `ge_or_gt` checks that `>` and `≥` do not occur in the statement of theorems.
  - `dup_namespace` checks that no declaration has a duplicated namespace such as `list.list.monad`.
  - `unused_arguments` checks that definitions and theorems do not have unused arguments.
  - `doc_blame` checks that every definition has a documentation string.
  - `doc_blame_thm` checks that every theorem has a documentation string (not enabled by default).
  - `def_lemma` checks that a declaration is a lemma iff its type is a proposition.
  - `check_type` checks that the statement of a declaration is well-typed.
  - `check_univs` checks that there are no bad `max u v` universe levels.
  - `syn_taut` checks that declarations are not syntactic tautologies.
  - `unused_haves_suffices` checks that declarations produced via term mode do not have
    ineffectual `have` or `suffices` statements
-/

open Tactic Expr

/-!
## Linter against use of `>`/`≥`
-/

/-- The names of `≥` and `>`, mostly disallowed in lemma statements -/
private unsafe def illegal_ge_gt : List Name :=
  [`gt, `ge]
#align illegal_ge_gt illegal_ge_gt

/- ./././Mathport/Syntax/Translate/Basic.lean:334:40: warning: unsupported option eqn_compiler.max_steps -/
set_option eqn_compiler.max_steps 20000

/-- Checks whether `≥` and `>` occurs in an illegal way in the expression.
  The main ways we legally use these orderings are:
  - `f (≥)`
  - `∃ x ≥ t, b`. This corresponds to the expression
    `@Exists α (fun (x : α), (@Exists (x > t) (λ (H : x > t), b)))`
  This function returns `tt` when it finds `ge`/`gt`, except in the following patterns
  (which are the same for `gt`):
  - `f (@ge _ _)`
  - `f (&0 ≥ y) (λ x : t, b)`
  - `λ H : &0 ≥ t, b`
  Here `&0` is the 0-th de Bruijn variable.
-/
private unsafe def contains_illegal_ge_gt : expr → Bool
  | const nm us => if nm ∈ illegal_ge_gt then true else false
  | app f e@(app (app (const nm us) tp) tc) =>
    contains_illegal_ge_gt f || if nm ∈ illegal_ge_gt then false else contains_illegal_ge_gt e
  |
  app (app custom_binder (app (app (app (app (const nm us) tp) tc) (var 0)) t))
      e@(lam var_name bi var_type body) =>
    contains_illegal_ge_gt e || if nm ∈ illegal_ge_gt then false else contains_illegal_ge_gt e
  | app f x => contains_illegal_ge_gt f || contains_illegal_ge_gt x
  | lam `H bi (type@(app (app (app (app (const nm us) tp) tc) (var 0)) t)) body =>
    contains_illegal_ge_gt body || if nm ∈ illegal_ge_gt then false else contains_illegal_ge_gt type
  | lam var_name bi var_type body => contains_illegal_ge_gt var_type || contains_illegal_ge_gt body
  | pi `H bi (type@(app (app (app (app (const nm us) tp) tc) (var 0)) t)) body =>
    contains_illegal_ge_gt body || if nm ∈ illegal_ge_gt then false else contains_illegal_ge_gt type
  | pi var_name bi var_type body => contains_illegal_ge_gt var_type || contains_illegal_ge_gt body
  | elet var_name type assignment body =>
    contains_illegal_ge_gt type || contains_illegal_ge_gt assignment || contains_illegal_ge_gt body
  | _ => false
#align contains_illegal_ge_gt contains_illegal_ge_gt

/-- Checks whether a `>`/`≥` is used in the statement of `d`.

It first does a quick check to see if there is any `≥` or `>` in the statement, and then does a
slower check whether the occurrences of `≥` and `>` are allowed.
Currently it checks only the conclusion of the declaration, to eliminate false positive from
binders such as `∀ ε > 0, ...` -/
private unsafe def ge_or_gt_in_statement (d : declaration) : tactic (Option String) :=
  return <|
    if (d.type.contains_constant fun n => n ∈ illegal_ge_gt) && contains_illegal_ge_gt d.type then
      some "the type contains ≥/>. Use ≤/< instead."
    else none
#align ge_or_gt_in_statement ge_or_gt_in_statement

-- TODO: the commented out code also checks for classicality in statements, but needs fixing
-- TODO: this probably needs to also check whether the argument is a variable or @eq <var> _ _
-- meta def illegal_constants_in_statement (d : declaration) : tactic (option string) :=
-- return $ if d.type.contains_constant (λ n, (n.get_prefix = `classical ∧
--   n.last ∈ ["prop_decidable", "dec", "dec_rel", "dec_eq"]) ∨ n ∈ [`gt, `ge])
-- then
--   let illegal1 := [`classical.prop_decidable, `classical.dec, `classical.dec_rel,
--     `classical.dec_eq],
--       illegal2 := [`gt, `ge],
--       occur1 := illegal1.filter (λ n, d.type.contains_constant (eq n)),
--       occur2 := illegal2.filter (λ n, d.type.contains_constant (eq n)) in
--   some $ sformat!"the type contains the following declarations: {occur1 ++ occur2}." ++
--     (if occur1 = [] then "" else " Add decidability type-class arguments instead.") ++
--     (if occur2 = [] then "" else " Use ≤/< instead.")
-- else none
/-- A linter for checking whether illegal constants (≥, >) appear in a declaration's type. -/
@[linter]
unsafe def linter.ge_or_gt : linter
    where
  test := ge_or_gt_in_statement
  auto_decls := false
  no_errors_found := "Not using ≥/> in declarations."
  errors_found :=
    "The following declarations use ≥/>, probably in a way where we would prefer\n  to use ≤/< instead. See note [nolint_ge] for more information."
  is_fast := false
#align linter.ge_or_gt linter.ge_or_gt

library_note "nolint_ge"/-- Currently, the linter forbids the use of `>` and `≥` in definitions and
statements, as they cause problems in rewrites.
They are still allowed in statements such as `bounded (≥)` or `∀ ε > 0` or `⨆ n ≥ m`,
and the linter allows that.
If you write a pattern where you bind two or more variables, like `∃ n m > 0`, the linter will
flag this as illegal, but it is also allowed. In this case, add the line
```
@[nolint ge_or_gt] -- see Note [nolint_ge]
```
-/

/-!
## Linter for duplicate namespaces
-/

/-- Checks whether a declaration has a namespace twice consecutively in its name -/
private unsafe def dup_namespace (d : declaration) : tactic (Option String) :=
  is_instance d.to_name >>= fun is_inst =>
    return <|
      let nm := d.to_name.components
      if nm.Chain' (· ≠ ·) ∨ is_inst then none
      else
        let s := (nm.find fun n => nm.count n ≥ 2).iget.toString
        some <| "The namespace `" ++ s ++ "` is duplicated in the name"
#align dup_namespace dup_namespace

/-- A linter for checking whether a declaration has a namespace twice consecutively in its name. -/
@[linter]
unsafe def linter.dup_namespace : linter
    where
  test := dup_namespace
  auto_decls := false
  no_errors_found := "No declarations have a duplicate namespace."
  errors_found := "DUPLICATED NAMESPACES IN NAME:"
#align linter.dup_namespace linter.dup_namespace

attribute [nolint dup_namespace] Iff.iff

/-!
## Linter for unused arguments
-/

/-- Auxiliary definition for `check_unused_arguments` -/
private unsafe def check_unused_arguments_aux : List ℕ → ℕ → ℕ → expr → List ℕ
  | l, n, n_max, e =>
    if n > n_max then l
    else
      if ¬is_lambda e ∧ ¬is_pi e then l
      else
        let b := e.binding_body
        let l' := if b.has_var_idx 0 then l else n :: l
        check_unused_arguments_aux l' (n + 1) n_max b
#align check_unused_arguments_aux check_unused_arguments_aux

/-- Check which arguments of a declaration are not used.
Prints a list of natural numbers corresponding to which arguments are not used (e.g.
  this outputs [1, 4] if the first and fourth arguments are unused).
Checks both the type and the value of `d` for whether the argument is used
(in rare cases an argument is used in the type but not in the value).
We return [] if the declaration was automatically generated.
We print arguments that are larger than the arity of the type of the declaration
(without unfolding definitions). -/
unsafe def check_unused_arguments (d : declaration) : Option (List ℕ) :=
  let l := check_unused_arguments_aux [] 1 d.type.pi_arity d.value
  if l = [] then none
  else
    let l2 := check_unused_arguments_aux [] 1 d.type.pi_arity d.type
    (l.filterₓ fun n => n ∈ l2).reverse
#align check_unused_arguments check_unused_arguments

/-- Check for unused arguments, and print them with their position, variable name, type and whether
the argument is a duplicate.
See also `check_unused_arguments`.
This tactic additionally filters out all unused arguments of type `parse _`.
We skip all declarations that contain `sorry` in their value. -/
private unsafe def unused_arguments (d : declaration) : tactic (Option String) := do
  let ff ← d.to_name.contains_sorry |
    return none
  let ns := check_unused_arguments d
  let tt ← return ns.isSome |
    return none
  let ns := ns.iget
  let (ds, _) ← get_pi_binders d.type
  let ns := ns.map fun n => (n, (ds.get? <| n - 1).iget)
  let ns := ns.filterₓ fun x => x.2.type.get_app_fn ≠ const `interactive.parse []
  let ff ← return ns.Empty |
    return none
  let ds' ← ds.mapM pp
  let ns ←
    ns.mapM fun ⟨n, b⟩ =>
        (fun s =>
            to_fmt "argument " ++ to_fmt n ++ ": " ++ s ++
              if (ds.countp fun b' => b.type = b'.type) ≥ 2 then " (duplicate)" else "") <$>
          pp b
  return <| some <| ns tt
#align unused_arguments unused_arguments

/-- A linter object for checking for unused arguments. This is in the default linter set. -/
@[linter]
unsafe def linter.unused_arguments : linter
    where
  test := unused_arguments
  auto_decls := false
  no_errors_found := "No unused arguments."
  errors_found := "UNUSED ARGUMENTS."
#align linter.unused_arguments linter.unused_arguments

attribute [nolint unused_arguments] imp_intro

/-!
## Linter for documentation strings
-/

/-- Reports definitions and constants that are missing doc strings -/
private unsafe def doc_blame_report_defn : declaration → tactic (Option String)
  | declaration.defn n _ _ _ _ _ => doc_string n >> return none <|> return "def missing doc string"
  | declaration.cnst n _ _ _ => doc_string n >> return none <|> return "constant missing doc string"
  | _ => return none
#align doc_blame_report_defn doc_blame_report_defn

/-- Reports definitions and constants that are missing doc strings -/
private unsafe def doc_blame_report_thm : declaration → tactic (Option String)
  | declaration.thm n _ _ _ => doc_string n >> return none <|> return "theorem missing doc string"
  | _ => return none
#align doc_blame_report_thm doc_blame_report_thm

/-- A linter for checking definition doc strings -/
@[linter]
unsafe def linter.doc_blame : linter
    where
  test d :=
    condM (not <$> has_attribute' `instance d.to_name) (doc_blame_report_defn d) (return none)
  auto_decls := false
  no_errors_found := "No definitions are missing documentation."
  errors_found := "DEFINITIONS ARE MISSING DOCUMENTATION STRINGS:"
#align linter.doc_blame linter.doc_blame

/-- A linter for checking theorem doc strings. This is not in the default linter set. -/
unsafe def linter.doc_blame_thm : linter
    where
  test := doc_blame_report_thm
  auto_decls := false
  no_errors_found := "No theorems are missing documentation."
  errors_found := "THEOREMS ARE MISSING DOCUMENTATION STRINGS:"
  is_fast := false
#align linter.doc_blame_thm linter.doc_blame_thm

/-!
## Linter for correct usage of `lemma`/`def`
-/

/-- Checks whether the correct declaration constructor (definition or theorem) by
comparing it to its sort. Instances will not be printed.

This test is not very quick: maybe we can speed-up testing that something is a proposition?
This takes almost all of the execution time.
-/
private unsafe def incorrect_def_lemma (d : declaration) : tactic (Option String) :=
  if d.is_constant ∨ d.is_axiom then return none
  else do
    let is_instance_d ← is_instance d.to_name
    if is_instance_d then return none
      else do
        let-- the following seems to be a little quicker than `is_prop d.type`.
            expr.sort
            n
          ← infer_type d
        let is_pattern ← has_attribute' `pattern d
        return <|
            if d ↔ n = level.zero then none
            else
              if d then "is a lemma/theorem, should be a def"
              else
                if is_pattern then none
                else-- declarations with `@[pattern]` are allowed to be a `def`.
                  "is a def, should be a lemma/theorem"
#align incorrect_def_lemma incorrect_def_lemma

/-- A linter for checking whether the correct declaration constructor (definition or theorem)
has been used. -/
@[linter]
unsafe def linter.def_lemma : linter
    where
  test := incorrect_def_lemma
  auto_decls := false
  no_errors_found := "All declarations correctly marked as def/lemma."
  errors_found := "INCORRECT DEF/LEMMA:"
#align linter.def_lemma linter.def_lemma

/-!
## Linter that checks whether declarations are well-typed
-/

/-- Checks whether the statement of a declaration is well-typed. -/
unsafe def check_type (d : declaration) : tactic (Option String) :=
  type_check d.type >> return none <|> return "The statement doesn't type-check"
#align check_type check_type

/-- A linter for missing checking whether statements of declarations are well-typed. -/
@[linter]
unsafe def linter.check_type : linter
    where
  test := check_type
  auto_decls := false
  no_errors_found :=
    "The statements of all declarations type-check with default reducibility settings."
  errors_found :=
    "THE STATEMENTS OF THE FOLLOWING DECLARATIONS DO NOT TYPE-CHECK.\nSome definitions in the statement are marked `@[irreducible]`, which means that the statement " ++
          "is now ill-formed. It is likely that these definitions were locally marked as `@[reducible]` " ++
        "or `@[semireducible]`. This can especially cause problems with type class inference or " ++
      "`@[simps]`."
  is_fast := true
#align linter.check_type linter.check_type

/-!
## Linter for universe parameters
-/

open Native

/-- `univ_params_grouped e` computes for each `level` `u` of `e` the parameters that occur in `u`,
  and returns the corresponding set of lists of parameters.
  In pseudo-mathematical form, this returns `{ { p : parameter | p ∈ u } | (u : level) ∈ e }`
  We use `list name` instead of `name_set`, since `name_set` does not have an order.
  It will ignore `nm₀._proof_i` declarations.
-/
unsafe def expr.univ_params_grouped (e : expr) (nm₀ : Name) : rb_set (List Name) :=
  e.fold mk_rb_set fun e n l =>
    match e with
    | e@(sort u) => l.insert u.params.toList
    | e@(const nm us) =>
      if nm.getPrefix = nm₀ ∧ nm.getLast.startsWith "_proof_" then l
      else l.union <| rb_set.of_list <| us.map fun u : level => u.params.toList
    | _ => l
#align expr.univ_params_grouped expr.univ_params_grouped

/-- The good parameters are the parameters that occur somewhere in the `rb_set` as a singleton or
  (recursively) with only other good parameters.
  All other parameters in the `rb_set` are bad.
-/
unsafe def bad_params : rb_set (List Name) → List Name
  | l =>
    let good_levels : name_set :=
      l.fold mk_name_set fun us prev => if us.length = 1 then prev.insert us.headI else prev
    if good_levels.Empty then l.fold [] List.union
    else
      bad_params <|
        rb_set.of_list <| l.toList.map fun us => us.filterₓ fun nm => !good_levels.contains nm
#align bad_params bad_params

/-- Checks whether all universe levels `u` in the type of `d` are "good".
This means that `u` either occurs in a `level` of `d` by itself, or (recursively)
with only other good levels.
When this fails, usually this means that there is a level `max u v`, where neither `u` nor `v`
occur by themselves in a level. It is ok if *one* of `u` or `v` never occurs alone. For example,
`(α : Type u) (β : Type (max u v))` is a occasionally useful method of saying that `β` lives in
a higher universe level than `α`.
-/
unsafe def check_univs (d : declaration) : tactic (Option String) := do
  let l := d.type.univ_params_grouped d.to_name
  let bad := bad_params l
  if bad then return none
    else return <| some <| "universes " ++ toString bad ++ " only occur together."
#align check_univs check_univs

/-- A linter for checking that there are no bad `max u v` universe levels. -/
@[linter]
unsafe def linter.check_univs : linter
    where
  test := check_univs
  auto_decls := false
  no_errors_found := "All declarations have good universe levels."
  errors_found :=
    "THE STATEMENTS OF THE FOLLOWING DECLARATIONS HAVE BAD UNIVERSE LEVELS. " ++
                  "This usually means that there is a `max u v` in the type where neither `u` nor `v` " ++
                "occur by themselves. Solution: Find the type (or type bundled with data) that has this " ++
              "universe argument and provide the universe level explicitly. If this happens in an implicit " ++
            "argument of the declaration, a better solution is to move this argument to a `variables` " ++
          "command (then it's not necessary to provide the universe level).\nIt is possible that this linter gives a false positive on definitions where the value of the " ++
        "definition has the universes occur separately, and the definition will usually be used with " ++
      "explicit universe arguments. In this case, feel free to add `@[nolint check_univs]`."
  is_fast := true
#align linter.check_univs linter.check_univs

/-!
## Linter for syntactic tautologies
-/

/-- Checks whether a lemma is a declaration of the form `∀ a b ... z, e₁ = e₂`
where `e₁` and `e₂` are identical exprs.
We call declarations of this form syntactic tautologies.
Such lemmas are (mostly) useless and sometimes introduced unintentionally when proving basic facts
with rfl when elaboration results in a different term than the user intended.
-/
unsafe def syn_taut (d : declaration) : tactic (Option String) :=
  (do
      let (el, er) ← d.type.pi_codomain.is_eq
      guardb (el == er)
      return <| some "LHS equals RHS syntactically") <|>
    return none
#align syn_taut syn_taut

/-- A linter for checking that declarations aren't syntactic tautologies. -/
@[linter]
unsafe def linter.syn_taut : linter where
  test := syn_taut
  auto_decls := false
  -- many false positives with this enabled
  no_errors_found := "No declarations are syntactic tautologies."
  errors_found :=
    "THE FOLLOWING DECLARATIONS ARE SYNTACTIC TAUTOLOGIES. " ++
              "This usually means that they are of the form `∀ a b ... z, e₁ = e₂` where `e₁` and `e₂` are " ++
            "identical expressions. We call declarations of this form syntactic tautologies. " ++
          "Such lemmas are (mostly) useless and sometimes introduced unintentionally when proving " ++
        "basic facts using `rfl`, when elaboration results in a different term than the user intended. " ++
      "You should check that the declaration really says what you think it does."
  is_fast := true
#align linter.syn_taut linter.syn_taut

attribute [nolint syn_taut] rfl

/-!
## Linters for ineffectual have and suffices statements in term mode
-/

/--
Check if an expression contains `var 0` by folding over the expression and matching the binder depth
-/
unsafe def expr.has_zero_var (e : expr) : Bool :=
  e.fold false fun e' d res =>
    res ||
      match e' with
      | var k => k = d
      | _ => false
#align expr.has_zero_var expr.has_zero_var

/-- Return a list of unused have and suffices terms in an expression
-/
unsafe def find_unused_have_suffices_macros : expr → tactic (List String)
  | app a b =>
    (· ++ ·) <$> find_unused_have_suffices_macros a <*> find_unused_have_suffices_macros b
  | lam var_name bi var_type body => find_unused_have_suffices_macros body
  | pi var_name bi var_type body => find_unused_have_suffices_macros body
  | elet var_name type assignment body =>
    (· ++ ·) <$> find_unused_have_suffices_macros assignment <*>
      find_unused_have_suffices_macros body
  | m@(macro md [l@(lam ppnm bi vt bd)]) => do
    -- term mode have statements are tagged with a macro
          -- if the macro annotation is `have then this lambda came from a term mode have statement
          (· ++ ·)
          (if m = `have ∧ ¬bd then ["unnecessary have " ++ ppnm ++ " : " ++ vt] else []) <$>
        find_unused_have_suffices_macros l
  | m@(macro md [app (l@(lam ppnm bi vt bd)) arg]) => do
    -- term mode suffices statements are tagged with a macro
          -- if the macro annotation is `suffices then this lambda came from a term mode suffices statement
          (· ++ ·)
          (if m = `suffices ∧ ¬bd then ["unnecessary suffices " ++ ppnm ++ " : " ++ vt] else []) <$>
        ((· ++ ·) <$> find_unused_have_suffices_macros l <*> find_unused_have_suffices_macros arg)
  | macro md l => List.join <$> l.mapM find_unused_have_suffices_macros
  | _ => return []
#align find_unused_have_suffices_macros find_unused_have_suffices_macros

/-- Return a list of unused have and suffices terms in a declaration
-/
unsafe def unused_have_of_decl : declaration → tactic (List String)
  | declaration.defn _ _ _ bd _ _ => find_unused_have_suffices_macros bd
  | declaration.thm _ _ _ bd => find_unused_have_suffices_macros bd.get
  | _ => return []
#align unused_have_of_decl unused_have_of_decl

/--
Checks whether a declaration contains term mode have statements that have no effect on the resulting
term.
-/
unsafe def has_unused_haves_suffices (d : declaration) : tactic (Option String) := do
  let ns ← unused_have_of_decl d
  if ns = 0 then return none else return (", ".intercalate (ns toString))
#align has_unused_haves_suffices has_unused_haves_suffices

/-- A linter for checking that declarations don't have unused term mode have statements. We do not
tag this as `@[linter]` so that it is not in the default linter set as it is slow and an uncommon
problem. -/
unsafe def linter.unused_haves_suffices : linter
    where
  test := has_unused_haves_suffices
  auto_decls := false
  no_errors_found := "No declarations have unused term mode have statements."
  errors_found :=
    "THE FOLLOWING DECLARATIONS HAVE INEFFECTUAL TERM MODE HAVE/SUFFICES BLOCKS. " ++
                      "In the case of `have` this is a term of the form `have h := foo, bar` where `bar` does not " ++
                    "refer to `foo`. Such statements have no effect on the generated proof, and can just be " ++
                  "replaced by `bar`, in addition to being ineffectual, they may make unnecessary assumptions " ++
                "in proofs appear as if they are used. " ++
              "For `suffices` this is a term of the form `suffices h : foo, proof_of_goal, proof_of_foo` where" ++
            " `proof_of_goal` does not refer to `foo`. " ++
          "Such statements have no effect on the generated proof, and can just be replaced by " ++
        "`proof_of_goal`, in addition to being ineffectual, they may make unnecessary assumptions in " ++
      "proofs appear as if they are used. "
  is_fast := false
#align linter.unused_haves_suffices linter.unused_haves_suffices

/-!
## Linter for unprintable interactive tactics
-/

/-- Ensures that every interactive tactic has arguments for which `interactive.param_desc` succeeds.
This is used to generate the parser documentation that appears in hovers on interactive tactics.
-/
unsafe def unprintable_interactive (d : declaration) : tactic (Option String) :=
  match d.to_name with
  | Name.mk_string _ (Name.mk_string "interactive" (Name.mk_string _ Name.anonymous)) => do
    let (ds, _) ← mk_local_pis d.type
    let ds ← ds.filterM fun d => not <$> succeeds (interactive.param_desc d.local_type)
    let ff ← return ds.Empty |
      return none
    let ds ← ds.mapM (pp ∘ to_binder)
    return <| some <| ds tt
  | _ => return none
#align unprintable_interactive unprintable_interactive

/-- A linter for checking that interactive tactics have parser documentation. -/
@[linter]
unsafe def linter.unprintable_interactive : linter
    where
  test := unprintable_interactive
  auto_decls := true
  no_errors_found := "No tactics are unprintable."
  errors_found :=
    "THE FOLLOWING TACTICS ARE UNPRINTABLE. " ++
              "This means that an interactive tactic is using `parse p` where `p` does not have " ++
            "an associated description. You can fix this by wrapping `p` as `with_desc \"p\" p`, " ++
          "and provide the description there, or you can stick to \"approved\" tactic combinators " ++
        "like `?` `*>` `<*` `<*>` `<|>` and `<$>` (but not `>>=` or `do` blocks) " ++
      "that automatically generate a description."
  is_fast := true
#align linter.unprintable_interactive linter.unprintable_interactive

/-!
## Linter for iff's
-/

open BinderInfo

/-- Recursively consumes a Pi expression while accumulating names and the complement of de-Bruijn
indexes of explicit variables, ultimately obtaining the remaining non-Pi expression as well.
-/
unsafe def unravel_explicits_of_pi : expr → ℕ → List Name → List ℕ → List Name × List ℕ × expr
  | pi n default _ e, i, ln, li => unravel_explicits_of_pi e (i + 1) (n :: ln) (i :: li)
  | pi n _ _ e, i, ln, li => unravel_explicits_of_pi e (i + 1) ln li
  | e, _, ln, li => (ln, li, e)
#align unravel_explicits_of_pi unravel_explicits_of_pi

/-- This function works as follows:
1. Call `unravel_explicits_of_pi` to obtain the names, complements of de-Bruijn indexes and the
remaining non-Pi expression;
2. Check if the remaining non-Pi expression is an iff, already obtaining the respective left and
right expressions if this is the case. Returns `none` otherwise;
3. Filter the explicit variables that appear on the left *and* right side of the iff;
4. If no variable satisfies the condition above, return `none`;
5. Return a message mentioning the variables that do, otherwise.
-/
unsafe def explicit_vars_of_iff (d : declaration) : tactic (Option String) := do
  let (ln, li, e) := unravel_explicits_of_pi d.type 0 [] []
  match e with
    | none => return none
    | some (el, er) => do
      let li := li fun i => d - i - 1
      let-- fixing for the actual de-Bruijn indexes
      l := (ln li).filterₓ fun t => el t.2 && er t.2
      if l = [] then return none
        else
          return <|
            "The following variables are used on both sides of an iff and ".append <|
              "should be made implicit: ".append <| ", ".intercalate (l fun t => toString t.1)
#align explicit_vars_of_iff explicit_vars_of_iff

/-- A linter for checking if variables appearing on both sides of an iff are explicit. Ideally, such
variables should be implicit instead.
-/
unsafe def linter.explicit_vars_of_iff : linter
    where
  test := explicit_vars_of_iff
  auto_decls := false
  no_errors_found := "No explicit variables on both sides of iff"
  errors_found := "EXPLICIT VARIABLES ON BOTH SIDES OF IFF"
#align linter.explicit_vars_of_iff linter.explicit_vars_of_iff


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import tactic.doc_commands

namespace tactic
namespace interactive
open interactive interactive.types expr lean.parser

local postfix `?`:9001 := optional

/--
This is a "finishing" tactic modification of `simp`. It has two forms.

* `simpa [rules, ...] using e` will simplify the goal and the type of
  `e` using `rules`, then try to close the goal using `e`.

  Simplifying the type of `e` makes it more likely to match the goal
  (which has also been simplified). This construction also tends to be
  more robust under changes to the simp lemma set.

* `simpa [rules, ...]` will simplify the goal and the type of a
  hypothesis `this` if present in the context, then try to close the goal using
  the `assumption` tactic. -/
meta def simpa (use_iota_eqn : parse $ (tk "!")?) (trace_lemmas : parse $ (tk "?")?)
  (no_dflt : parse only_flag) (hs : parse simp_arg_list) (attr_names : parse with_ident_list)
  (tgt : parse (tk "using" *> texpr)?) (cfg : simp_config_ext := {}) : tactic unit :=
let simp_at lc (close_tac : tactic unit) := focus1 $
  simp use_iota_eqn trace_lemmas no_dflt hs attr_names (loc.ns lc)
    {fail_if_unchanged := ff, ..cfg} >>
  (((close_tac <|> trivial) >> done) <|> fail "simpa failed") in
match tgt with
| none := get_local `this >> simp_at [some `this, none] assumption <|> simp_at [none] assumption
| some e := focus1 $ do
  e ← i_to_expr e <|> do {
    ty ← target,
    -- for positional error messages, we don't care about the result
    e ← i_to_expr_strict ``(%%e : %%ty),
    pty ← pp ty, ptgt ← pp e,
    -- Fail deliberately, to advise regarding `simp; exact` usage
    fail ("simpa failed, 'using' expression type not directly " ++
      "inferrable. Try:\n\nsimpa ... using\nshow " ++
      to_fmt pty ++ ",\nfrom " ++ ptgt : format) },
  match e with
  | local_const _ lc _ _ := simp_at [some lc, none] (get_local lc >>= tactic.exact)
  | e := do
    t ← infer_type e,
    assertv `this t e,
    simp_at [some `this, none] (get_local `this >>= tactic.exact),
    all_goals (try apply_instance)
  end
end

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

end interactive
end tactic


import Lean
import Lean.Parser.Syntax

open Lean Elab Command Term

/- ## `Syntax`: Solutions -/

/- ### 1. -/

namespace a
  scoped notation:71 lhs:50 " 💀 " rhs:72 => lhs - rhs
end a

namespace b
  set_option quotPrecheck false
  scoped infixl:71 " 💀 " => fun lhs rhs => lhs - rhs
end b

namespace c
  scoped syntax:71 term:50 " 💀 " term:72 : term
  scoped macro_rules | `($l:term 💀 $r:term) => `($l - $r)
end c

open a
#eval 5 * 8 💀 4 -- 20
#eval 8 💀 6 💀 1 -- 1

/- ### 2. -/

syntax "good morning" : term
syntax "hello" : command
syntax "yellow" : tactic

-- Note: the following are highlighted in red, however that's just because we haven't implemented the semantics ("elaboration function") yet - the syntax parsing stage works.

#eval good morning -- works
-- good morning -- error: `expected command`

hello -- works
-- #eval hello -- error: `expected term`

example : 2 + 2 = 4 := by
  yellow -- works
-- yellow -- error: `expected command`
-- #eval yellow -- error: `unknown identifier 'yellow'`

/- ### 3. -/

syntax (name := colors) (("blue"+) <|> ("red"+)) num : command

@[command_elab colors]
def elabColors : CommandElab := fun stx => Lean.logInfo "success!"

blue blue 443
red red red 4

/- ### 4. -/

syntax (name := help) "#better_help" "option" (ident)? : command

@[command_elab help]
def elabHelp : CommandElab := fun stx => Lean.logInfo "success!"

#better_help option
#better_help option pp.r
#better_help option some.other.name

/- ### 5. -/

-- Note: std4 has to be in dependencies of your project for this to work.
syntax (name := bigsumin) "∑ " Std.ExtendedBinder.extBinder "in " term "," term : term

@[term_elab bigsumin]
def elabSum : TermElab := fun stx tp =>
  return mkNatLit 666

#eval ∑ x in { 1, 2, 3 }, x^2

def hi := (∑ x in { "apple", "banana", "cherry" }, x.length) + 1
#eval hi


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Minchao Wu
-/
import meta.rb_map
import tactic.core
/-!
# `#explode` command

Displays a proof term in a line by line format somewhat akin to a Fitch style
proof or the Metamath proof style.
-/

open expr tactic

namespace tactic
namespace explode

@[derive inhabited]
inductive status : Type | reg | intro | lam | sintro

/--
A type to distinguish introduction or elimination rules represented as
strings from theorems referred to by their names.
-/
meta inductive thm : Type
| expr (e : expr)
| name (n : name)
| string (s : string)

/--
Turn a thm into a string.
-/
meta def thm.to_string : thm → string
| (thm.expr e) := e.to_string
| (thm.name n) := n.to_string
| (thm.string s) := s

meta structure entry : Type :=
(expr : expr)
(line : nat)
(depth : nat)
(status : status)
(thm : thm)
(deps : list nat)

meta def pad_right (l : list string) : list string :=
let n := l.foldl (λ r (s:string), max r s.length) 0 in
l.map $ λ s, nat.iterate (λ s, s.push ' ') (n - s.length) s

@[derive inhabited]
meta structure entries : Type := mk' ::
(s : expr_map entry)
(l : list entry)

meta def entries.find (es : entries) (e : expr) : option entry := es.s.find e
meta def entries.size (es : entries) : ℕ := es.s.size

meta def entries.add : entries → entry → entries
| es@⟨s, l⟩ e := if s.contains e.expr then es else ⟨s.insert e.expr e, e :: l⟩

meta def entries.head (es : entries) : option entry := es.l.head'

meta def format_aux : list string → list string → list string → list entry → tactic format
| (line :: lines) (dep :: deps) (thm :: thms) (en :: es) := do
  fmt ← do
  { let margin := string.join (list.replicate en.depth " │"),
    let margin := match en.status with
      | status.sintro := " ├" ++ margin
      | status.intro := " │" ++ margin ++ " ┌"
      | status.reg := " │" ++ margin ++ ""
      | status.lam := " │" ++ margin ++ ""
      end,
    p ← infer_type en.expr >>= pp,
    let lhs :=  line ++ "│" ++ dep ++ "│ " ++ thm ++ margin ++ " ",
    return $ format.of_string lhs ++ (p.nest lhs.length).group ++ format.line },
  (++ fmt) <$> format_aux lines deps thms es
| _ _ _ _ := return format.nil

meta instance : has_to_tactic_format entries :=
⟨λ es : entries,
  let lines := pad_right $ es.l.map (λ en, to_string en.line),
      deps  := pad_right $ es.l.map (λ en, string.intercalate "," (en.deps.map to_string)),
      thms  := pad_right $ es.l.map (λ en, (entry.thm en).to_string) in
  format_aux lines deps thms es.l⟩

meta def append_dep (filter : expr → tactic unit)
 (es : entries) (e : expr) (deps : list nat) : tactic (list nat) :=
do { ei ← es.find e,
  filter ei.expr,
  return (ei.line :: deps) }
<|> return deps

meta def may_be_proof (e : expr) : tactic bool :=
do expr.sort u ← infer_type e >>= infer_type,
   return $ bnot u.nonzero

end explode
open explode

meta mutual def explode.core, explode.args (filter : expr → tactic unit)
with explode.core : expr → bool → nat → entries → tactic entries
| e@(lam n bi d b) si depth es := do
  m ← mk_fresh_name,
  let l := local_const m n bi d,
  let b' := instantiate_var b l,
  if si then
    let en : entry := ⟨l, es.size, depth, status.sintro, thm.name n, []⟩ in do
    es' ← explode.core b' si depth (es.add en),
    return $ es'.add ⟨e, es'.size, depth, status.lam, thm.string "∀I", [es.size, es'.size - 1]⟩
  else do
    let en : entry := ⟨l, es.size, depth, status.intro, thm.name n, []⟩,
    es' ← explode.core b' si (depth + 1) (es.add en),
    -- in case of a "have" clause, the b' here has an annotation
    deps' ← explode.append_dep filter es' b'.erase_annotations [],
    deps' ← explode.append_dep filter es' l deps',
    return $ es'.add ⟨e, es'.size, depth, status.lam, thm.string "∀I", deps'⟩
| e@(elet n t a b) si depth es := explode.core (reduce_lets e) si depth es
| e@(macro n l) si depth es := explode.core l.head si depth es
| e si depth es := filter e >>
  match get_app_fn_args e with
  | (nm@(const n _), args) :=
    explode.args e args depth es (thm.expr nm) []
  | (fn, []) := do
    let en : entry := ⟨fn, es.size, depth, status.reg, thm.expr fn, []⟩,
    return (es.add en)
  | (fn, args) := do
    es' ← explode.core fn ff depth es,
    -- in case of a "have" clause, the fn here has an annotation
    deps ← explode.append_dep filter es' fn.erase_annotations [],
    explode.args e args depth es' (thm.string "∀E") deps
  end
with explode.args : expr → list expr → nat → entries → thm → list nat → tactic entries
| e (arg :: args) depth es thm deps := do
  es' ← explode.core arg ff depth es <|> return es,
  deps' ← explode.append_dep filter es' arg deps,
  explode.args e args depth es' thm deps'
| e [] depth es thm deps :=
  return (es.add ⟨e, es.size, depth, status.reg, thm, deps.reverse⟩)

meta def explode_expr (e : expr) (hide_non_prop := tt) : tactic entries :=
let filter := if hide_non_prop then λ e, may_be_proof e >>= guardb else λ _, skip in
tactic.explode.core filter e tt 0 default

meta def explode (n : name) : tactic unit :=
do const n _ ← resolve_name n | fail "cannot resolve name",
  d ← get_decl n,
  v ← match d with
  | (declaration.defn _ _ _ v _ _) := return v
  | (declaration.thm _ _ _ v)      := return v.get
  | _                  := fail "not a definition"
  end,
  t ← pp d.type,
  explode_expr v <* trace (to_fmt n ++ " : " ++ t) >>= trace

setup_tactic_parser

/--
`#explode decl_name` displays a proof term in a line-by-line format somewhat akin to a Fitch-style
proof or the Metamath proof style.
`#explode_widget decl_name` renders a widget that displays an `#explode` proof.

`#explode iff_true_intro` produces

```lean
iff_true_intro : ∀ {a : Prop}, a → (a ↔ true)
0│   │ a         ├ Prop
1│   │ h         ├ a
2│   │ hl        │ ┌ a
3│   │ trivial   │ │ true
4│2,3│ ∀I        │ a → true
5│   │ hr        │ ┌ true
6│5,1│ ∀I        │ true → a
7│4,6│ iff.intro │ a ↔ true
8│1,7│ ∀I        │ a → (a ↔ true)
9│0,8│ ∀I        │ ∀ {a : Prop}, a → (a ↔ true)
```

In more detail:

The output of `#explode` is a Fitch-style proof in a four-column diagram modeled after Metamath
proof displays like [this](http://us.metamath.org/mpeuni/ru.html). The headers of the columns are
"Step", "Hyp", "Ref", "Type" (or "Expression" in the case of Metamath):
* Step: An increasing sequence of numbers to number each step in the proof, used in the Hyp field.
* Hyp: The direct children of the current step. Most theorems are implications like `A -> B -> C`,
  and so on the step proving `C` the Hyp field will refer to the steps that prove `A` and `B`.
* Ref: The name of the theorem being applied. This is well-defined in Metamath, but in Lean there
  are some special steps that may have long names because the structure of proof terms doesn't
  exactly match this mold.
  * If the theorem is `foo (x y : Z) : A x -> B y -> C x y`:
    * the Ref field will contain `foo`,
    * `x` and `y` will be suppressed, because term construction is not interesting, and
    * the Hyp field will reference steps proving `A x` and `B y`. This corresponds to a proof term
      like `@foo x y pA pB` where `pA` and `pB` are subproofs.
  * If the head of the proof term is a local constant or lambda, then in this case the Ref will
    say `∀E` for forall-elimination. This happens when you have for example `h : A -> B` and
    `ha : A` and prove `b` by `h ha`; we reinterpret this as if it said `∀E h ha` where `∀E` is
    (n-ary) modus ponens.
  * If the proof term is a lambda, we will also use `∀I` for forall-introduction, referencing the
    body of the lambda. The indentation level will increase, and a bracket will surround the proof
    of the body of the lambda, starting at a proof step labeled with the name of the lambda variable
    and its type, and ending with the `∀I` step. Metamath doesn't have steps like this, but the
    style is based on Fitch proofs in first-order logic.
* Type: This contains the type of the proof term, the theorem being proven at the current step.
  This proof layout differs from `#print` in using lots of intermediate step displays so that you
  can follow along and don't have to see term construction steps because they are implicitly in the
  intermediate step displays.

Also, it is common for a Lean theorem to begin with a sequence of lambdas introducing local
constants of the theorem. In order to minimize the indentation level, the `∀I` steps at the end of
the proof will be introduced in a group and the indentation will stay fixed. (The indentation
brackets are only needed in order to delimit the scope of assumptions, and these assumptions
have global scope anyway so detailed tracking is not necessary.)
-/
@[user_command]
meta def explode_cmd (_ : parse $ tk "#explode") : parser unit :=
do n ← ident,
  explode n
.

add_tactic_doc
{ name       := "#explode / #explode_widget",
  category   := doc_category.cmd,
  decl_names := [`tactic.explode_cmd, `tactic.explode_widget_cmd],
  inherit_description_from := `tactic.explode_cmd,
  tags       := ["proof display", "widgets"] }

end tactic


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

/-!
This file provides an alternative implementation for `apply` to fix the so-called "apply bug".

The issue arises when the goals is a Π-type -- whether it is visible or hidden behind a definition.

For instance, consider the following proof:

```
example {α β} (x y z : α → β) (h₀ : x ≤ y) (h₁ : y ≤ z) : x ≤ z :=
begin
  apply le_trans,
end
```

Because `x ≤ z` is definitionally equal to `∀ i, x i ≤ z i`, `apply` will fail. The alternative
definition, `apply'` fixes this. When `apply` would work, `apply` is used and otherwise,
a different strategy is deployed
-/

namespace tactic

/-- With `gs` a list of proof goals, `reorder_goals gs new_g` will use the `new_goals` policy
`new_g` to rearrange the dependent goals to either drop them, push them to the end of the list
or leave them in place. The `bool` values in `gs` indicates whether the goal is dependent or not. -/
def reorder_goals {α} (gs : list (bool × α)) : new_goals → list α
| new_goals.non_dep_first :=
  let ⟨dep,non_dep⟩ := gs.partition (coe ∘ prod.fst) in
  non_dep.map prod.snd ++ dep.map prod.snd
| new_goals.non_dep_only := (gs.filter (coe ∘ bnot ∘ prod.fst)).map prod.snd
| new_goals.all := gs.map prod.snd

private meta def has_opt_auto_param_inst_for_apply (ms : list (name × expr)) : tactic bool :=
ms.mfoldl
 (λ r m, do type ← infer_type m.2,
            b ← is_class type,
            return $ r || type.is_napp_of `opt_param 2 || type.is_napp_of `auto_param 2 || b)
 ff

private meta def try_apply_opt_auto_param_instance_for_apply (cfg : apply_cfg)
  (ms : list (name × expr)) : tactic unit :=
mwhen (has_opt_auto_param_inst_for_apply ms) $ do
  gs ← get_goals,
  ms.mmap' (λ m, mwhen (bnot <$> (is_assigned m.2)) $
                   set_goals [m.2] >>
                   try apply_instance >>
                   when cfg.opt_param (try apply_opt_param) >>
                   when cfg.auto_param (try apply_auto_param)),
  set_goals gs

private meta def retry_apply_aux :
  Π (e : expr) (cfg : apply_cfg), list (bool × name ×  expr) → tactic (list (name × expr))
| e cfg gs :=
focus1 (do
   { tgt : expr ← target, t ← infer_type e,
     unify t tgt,
     exact e,
     gs' ← get_goals,
     let r := reorder_goals gs.reverse cfg.new_goals,
     set_goals (gs' ++ r.map prod.snd),
     return r }) <|>
do (expr.pi n bi d b) ← infer_type e >>= whnf | apply_core e cfg,
   v ← mk_meta_var d,
   let b := b.has_var,
   e ← head_beta $ e v,
   retry_apply_aux e cfg ((b, n, v) :: gs)

private meta def retry_apply (e : expr) (cfg : apply_cfg) : tactic (list (name × expr)) :=
apply_core e cfg <|> retry_apply_aux e cfg []

/-- `apply'` mimics the behavior of `apply_core`. When
`apply_core` fails, it is retried by providing the term with meta
variables as additional arguments. The meta variables can then
become new goals depending on the `cfg.new_goals` policy.

`apply'` also finds instances and applies opt_params and auto_params. -/
meta def apply' (e : expr) (cfg : apply_cfg := {}) : tactic (list (name × expr)) :=
do r ← retry_apply e cfg,
   try_apply_opt_auto_param_instance_for_apply cfg r,
   return r

/-- Same as `apply'` but __all__ arguments that weren't inferred are added to goal list. -/
meta def fapply' (e : expr) : tactic (list (name × expr)) :=
apply' e {new_goals := new_goals.all}
/-- Same as `apply'` but only goals that don't depend on other goals are added to goal list. -/
meta def eapply' (e : expr) : tactic (list (name × expr)) :=
apply' e {new_goals := new_goals.non_dep_only}

/-- `relation_tactic` finds a proof rule for the relation found in the goal and uses `apply'`
to make one proof step. -/
private meta def relation_tactic (md : transparency) (op_for : environment → name → option name)
  (tac_name : string) : tactic unit :=
do tgt   ← target >>= instantiate_mvars,
   env   ← get_env,
   let r := expr.get_app_fn tgt,
   match op_for env (expr.const_name r) with
   | (some refl) := do r ← mk_const refl,
                       retry_apply r {md := md, new_goals := new_goals.non_dep_only },
                       return ()
   | none        := fail $ tac_name ++
     " tactic failed, target is not a relation application with the expected property."
   end

/-- Similar to `reflexivity` with the difference that `apply'` is used instead of `apply` -/
meta def reflexivity' (md := semireducible) : tactic unit :=
relation_tactic md environment.refl_for "reflexivity"

/-- Similar to `symmetry` with the difference that `apply'` is used instead of `apply` -/
meta def symmetry' (md := semireducible) : tactic unit :=
relation_tactic md environment.symm_for "symmetry"

/-- Similar to `transitivity` with the difference that `apply'` is used instead of `apply` -/
meta def transitivity' (md := semireducible) : tactic unit :=
relation_tactic md environment.trans_for "transitivity"

namespace interactive

setup_tactic_parser

/--
Similarly to `apply`, the `apply'` tactic tries to match the current goal against the conclusion
of the type of term.

It differs from `apply` in that it does not unfold definition in order to find out what the
assumptions of the provided term is. It is especially useful when defining relations on function
spaces (e.g. `≤`) so that rules like transitivity on `le : (α → β) → (α → β) → (α → β)` will be
considered to have three parameters and two assumptions (i.e. `f g h : α → β`, `H₀ : f ≤ g`,
`H₁ : g ≤ h`) instead of three parameters, two assumptions and then one more parameter
(i.e. `f g h : α → β`, `H₀ : f ≤ g`, `H₁ : g ≤ h`, `x : α`). Whereas `apply` would expect the goal
`f x ≤ h x`, `apply'` will work with the goal `f ≤ h`.
-/
meta def apply' (q : parse texpr) : tactic unit :=
concat_tags (do h ← i_to_expr_for_apply q, tactic.apply' h)

/--
Similar to the `apply'` tactic, but does not reorder goals.
-/
meta def fapply' (q : parse texpr) : tactic unit :=
concat_tags (i_to_expr_for_apply q >>= tactic.fapply')

/--
Similar to the `apply'` tactic, but only creates subgoals for non-dependent premises that have not
been fixed by type inference or type class resolution.
-/
meta def eapply' (q : parse texpr) : tactic unit :=
concat_tags (i_to_expr_for_apply q >>= tactic.eapply')

/--
Similar to the `apply'` tactic, but allows the user to provide a `apply_cfg` configuration object.
-/
meta def apply_with' (q : parse parser.pexpr) (cfg : apply_cfg) : tactic unit :=
concat_tags (do e ← i_to_expr_for_apply q, tactic.apply' e cfg)

/--
Similar to the `apply'` tactic, but uses matching instead of unification.
`mapply' t` is equivalent to `apply_with' t {unify := ff}`
-/
meta def mapply' (q : parse texpr) : tactic unit :=
concat_tags (do e ← i_to_expr_for_apply q, tactic.apply' e {unify := ff})

/--
Similar to `reflexivity` with the difference that `apply'` is used instead of `apply`.
-/
meta def reflexivity' : tactic unit :=
tactic.reflexivity'

/--
Shorter name for the tactic `reflexivity'`.
-/
meta def refl' : tactic unit :=
tactic.reflexivity'

/--
`symmetry'` behaves like `symmetry` but also offers the option `symmetry' at h` to apply symmetry
to assumption `h`
-/
meta def symmetry' : parse location → tactic unit
| l@loc.wildcard := l.try_apply symmetry_hyp tactic.symmetry'
| (loc.ns hs) := (loc.ns hs.reverse).apply symmetry_hyp tactic.symmetry'

/--
Similar to `transitivity` with the difference that `apply'` is used instead of `apply`.
-/
meta def transitivity' (q : parse texpr?) : tactic unit :=
tactic.transitivity' >> match q with
| none := skip
| some q :=
  do (r, lhs, rhs) ← target_lhs_rhs,
     t ← infer_type lhs,
     i_to_expr ``(%%q : %%t) >>= unify rhs
end

end interactive

end tactic


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

/-
Auxiliary elaboration functions: AKA custom elaborators
-/

namespace Lean.Elab.Term
open Meta

@[builtinTermElab binrel] def elabBinRel : TermElab :=  fun stx expectedType? => do
  match (← resolveId? stx[1]) with
  | some f =>
    let s ← saveState
    let (lhs, rhs) ← withSynthesize (mayPostpone := true) do
      let mut lhs ← elabTerm stx[2] none
      let mut rhs ← elabTerm stx[3] none
      if lhs.isAppOfArity ``OfNat.ofNat 3 then
        lhs ← ensureHasType (← inferType rhs) lhs
      else if rhs.isAppOfArity ``OfNat.ofNat 3 then
        rhs ← ensureHasType (← inferType lhs) rhs
      return (lhs, rhs)
    let lhsType ← inferType lhs
    let rhsType ← inferType rhs
    let (lhs, rhs) ←
      try
        pure (lhs, ← withRef stx[3] do ensureHasType lhsType rhs)
      catch _ =>
        try
          pure (← withRef stx[2] do ensureHasType rhsType lhs, rhs)
        catch _ =>
          s.restore
          -- Use default approach
          let lhs ← elabTerm stx[2] none
          let rhs ← elabTerm stx[3] none
          let lhsType ← inferType lhs
          let rhsType ← inferType rhs
          pure (lhs, ← withRef stx[3] do ensureHasType lhsType rhs)
    elabAppArgs f #[] #[Arg.expr lhs, Arg.expr rhs] expectedType? (explicit := false) (ellipsis := false)
  | none   => throwUnknownConstant stx[1].getId

@[builtinTermElab forInMacro] def elabForIn : TermElab :=  fun stx expectedType? => do
  match stx with
  | `(forIn% $col $init $body) =>
      match (← isLocalIdent? col) with
      | none   => elabTerm (← `(let col := $col; forIn% col $init $body)) expectedType?
      | some colFVar =>
        tryPostponeIfNoneOrMVar expectedType?
        let m ← getMonad expectedType?
        let colType ← inferType colFVar
        let elemType ← mkFreshExprMVar (mkSort (mkLevelSucc (← mkFreshLevelMVar)))
        let forInInstance ←
          try
            mkAppM ``ForIn #[m, colType, elemType]
          catch
            ex => tryPostpone; throwError "failed to construct 'ForIn' instance for collection{indentExpr colType}\nand monad{indentExpr m}"
        match (← trySynthInstance forInInstance) with
        | LOption.some val =>
          let ref ← getRef
          let forInFn ← mkConst ``forIn
          elabAppArgs forInFn #[] #[Arg.stx col, Arg.stx init, Arg.stx body] expectedType? (explicit := false) (ellipsis := false)
        | LOption.undef    => tryPostpone; throwFailure forInInstance
        | LOption.none     => throwFailure forInInstance
  | _ => throwUnsupportedSyntax
where
  getMonad (expectedType? : Option Expr) : TermElabM Expr := do
    match expectedType? with
    | none => throwError "invalid 'forIn%' notation, expected type is not available"
    | some expectedType =>
      match (← isTypeApp? expectedType) with
      | some (m, _) => return m
      | none => throwError "invalid 'forIn%' notation, expected type is not of of the form `M α`{indentExpr expectedType}"
  throwFailure (forInInstance : Expr) : TermElabM Expr :=
    throwError "failed to synthesize instance for 'forIn%' notation{indentExpr forInInstance}"

namespace BinOp
/-

The elaborator for `binop%` terms works as follows:

1- Expand macros.
2- Convert `Syntax` object corresponding to the `binop%` term into a `Tree`.
   The `toTree` method visits nested `binop%` terms and parentheses.
3- Synthesize pending metavariables without applying default instances and using the
   `(mayPostpone := true)`.
4- Tries to compute a maximal type for the tree computed at step 2.
   We say a type α is smaller than type β if there is a (nondependent) coercion from α to β.
   We are currently ignoring the case we may have cycles in the coercion graph.
   If there are "uncomparable" types α and β in the tree, we skip the next step.
   We say two types are "uncomparable" if there isn't a coercion between them.
   Note that two types may be "uncomparable" because some typing information may still be missing.
5- We traverse the tree and inject coercions to the "maximal" type when needed.

Recall that the coercions are expanded eagerly by the elaborator.

Properties:

a) Given `n : Nat` and `i : Nat`, it can successfully elaborate `n + i` and `i + n`. Recall that Lean 3
   fails on the former.

b) The coercions are inserted in the "leaves" like in Lean 3.

c) There are no coercions "hidden" inside instances, and we can elaborate
```
axiom Int.add_comm (i j : Int) : i + j = j + i

example (n : Nat) (i : Int) : n + i = i + n := by
  rw [Int.add_comm]
```
Recall that the `rw` tactic used to fail because our old `binop%` elaborator would hide
coercions inside of a `HAdd` instance.

Remarks:

In the new `binop%` elaborator the decision whether a coercion will be inserted or not
is made at `binop%` elaboration time. This was not the case in the old elaborator.
For example, an instance, such as `HAdd Int ?m ?n`, could be created when executing
the `binop%` elaborator, and only resolved much later. We try to minimize this problem
by synthesizing pending metavariables at step 3.

For types containing heterogeneous operators (e.g., matrix multiplication), step 4 will fail
and we will skip coercion insertion. For example, `x : Matrix Real 5 4` and `y : Matrix Real 4 8`,
there is no coercion `Matrix Real 5 4` from `Matrix Real 4 8` and vice-versa, but
`x * y` is elaborated successfully and has type `Matrix Real 5 8`.
-/

private inductive Tree where
  | term  (ref : Syntax) (val : Expr)
  | op    (ref : Syntax) (lazy : Bool) (f : Expr) (lhs rhs : Tree)

private partial def toTree (s : Syntax) : TermElabM Tree := do
  let result ← go (← liftMacroM <| expandMacros s)
  synthesizeSyntheticMVars (mayPostpone := true)
  return result
where
  go (s : Syntax) := do
    match s with
    | `(binop% $f $lhs $rhs) => processOp (lazy := false) f lhs rhs
    | `(binop_lazy% $f $lhs $rhs) => processOp (lazy := true) f lhs rhs
    | `(($e)) => (← go e)
    | _ =>
       return Tree.term s (← elabTerm s none)

  processOp (f lhs rhs : Syntax) (lazy : Bool) := do
    let some f ← resolveId? f | throwUnknownConstant f.getId
    return Tree.op s (lazy := lazy) f (← go lhs) (← go rhs)

-- Auxiliary function used at `analyze`
private def hasCoe (fromType toType : Expr) : TermElabM Bool := do
  if (← getEnv).contains ``CoeHTCT then
    let u ← getLevel fromType
    let v ← getLevel toType
    let coeInstType := mkAppN (Lean.mkConst ``CoeHTCT [u, v]) #[fromType, toType]
    match ← trySynthInstance coeInstType (some (maxCoeSize.get (← getOptions))) with
    | LOption.some _ => return true
    | LOption.none   => return false
    | LOption.undef  => return false -- TODO: should we do something smarter here?
  else
    return false

private structure AnalyzeResult where
  max?            : Option Expr := none
  hasUncomparable : Bool := false -- `true` if there are two types `α` and `β` where we don't have coercions in any direction.

private def isUnknow : Expr → Bool
  | Expr.mvar ..        => true
  | Expr.app f ..       => isUnknow f
  | Expr.letE _ _ _ b _ => isUnknow b
  | Expr.mdata _ b _    => isUnknow b
  | _                   => false

private def analyze (t : Tree) (expectedType? : Option Expr) : TermElabM AnalyzeResult := do
  let max? ←
    match expectedType? with
    | none => pure none
    | some expectedType =>
      let expectedType ← instantiateMVars expectedType
      if isUnknow expectedType then pure none else pure (some expectedType)
  (go t *> get).run' { max? }
where
   go (t : Tree) : StateRefT AnalyzeResult TermElabM Unit := do
     unless (← get).hasUncomparable do
       match t with
       | Tree.op _ _ _ lhs rhs => go lhs; go rhs
       | Tree.term _ val =>
         let type ← instantiateMVars (← inferType val)
         unless isUnknow type do
           match (← get).max? with
           | none     => modify fun s => { s with max? := type }
           | some max =>
             unless (← withNewMCtxDepth <| isDefEqGuarded max type) do
               if (← hasCoe type max) then
                 return ()
               else if (← hasCoe max type) then
                 modify fun s => { s with max? := type }
               else
                 trace[Elab.binop] "uncomparable types: {max}, {type}"
                 modify fun s => { s with hasUncomparable := true }

private def mkOp (f : Expr) (lhs rhs : Expr) : TermElabM Expr :=
  elabAppArgs f #[] #[Arg.expr lhs, Arg.expr rhs] (expectedType? := none) (explicit := false) (ellipsis := false)

private def toExpr (t : Tree) : TermElabM Expr := do
  match t with
  | Tree.term _ e               => return e
  | Tree.op ref true f lhs rhs  => withRef ref <| mkOp f (← toExpr lhs) (← mkFunUnit (← toExpr rhs))
  | Tree.op ref false f lhs rhs => withRef ref <| mkOp f (← toExpr lhs) (← toExpr rhs)

private def applyCoe (t : Tree) (maxType : Expr) : TermElabM Tree := do
  go t
where
  go (t : Tree) : TermElabM Tree := do
    match t with
    | Tree.op ref lazy f lhs rhs => return Tree.op ref lazy f (← go lhs) (← go rhs)
    | Tree.term ref e       =>
      let type ← inferType e
      trace[Elab.binop] "visiting {e} : {type} =?= {maxType}"
      if (← isDefEqGuarded maxType type) then
        return t
      else
        trace[Elab.binop] "added coercion: {e} : {type} => {maxType}"
        withRef ref <| return Tree.term ref (← mkCoe maxType type e)

@[builtinTermElab binop]
def elabBinOp : TermElab :=  fun stx expectedType? => do
  let tree ← toTree stx
  let r    ← analyze tree expectedType?
  trace[Elab.binop] "hasUncomparable: {r.hasUncomparable}, maxType: {r.max?}"
  if r.hasUncomparable || r.max?.isNone then
    let result ← toExpr tree
    ensureHasType expectedType? result
  else
    let result ← toExpr (← applyCoe tree r.max?.get!)
    trace[Elab.binop] "result: {result}"
    ensureHasType expectedType? result

@[builtinTermElab binop_lazy]
def elabBinOpLazy : TermElab := elabBinOp

/--
  Decompose `e` into `(r, a, b)`.

  Remark: it assumes the last two arguments are explicit. -/
private def relation? (e : Expr) : MetaM (Option (Expr × Expr × Expr)) :=
  if e.getAppNumArgs < 2 then
    return none
  else
    return some (e.appFn!.appFn!, e.appFn!.appArg!, e.appArg!)

@[builtinTermElab «calc»]
def elabBinCalc : TermElab :=  fun stx expectedType? => do
  let stepStxs := stx[1].getArgs
  let mut proofs := #[]
  let mut types  := #[]
  for stepStx in stepStxs do
    let type  ← elabType stepStx[0]
    let some (_, lhs, _) ← relation? type |
      throwErrorAt stepStx[0] "invalid 'calc' step, relation expected{indentExpr type}"
    if types.size > 0 then
      let some (_, _, prevRhs) ← relation? types.back | unreachable!
      unless (← isDefEqGuarded lhs prevRhs) do
        throwErrorAt stepStx[0] "invalid 'calc' step, left-hand-side is {indentD m!"{lhs} : {← inferType lhs}"}\nprevious right-hand-side is{indentD m!"{prevRhs} : {← inferType prevRhs}"}"
    types := types.push type
    let proof ← elabTermEnsuringType stepStx[2] type
    synthesizeSyntheticMVars
    proofs := proofs.push proof
  let mut result := proofs[0]
  let mut resultType := types[0]
  for i in [1:proofs.size] do
    let some (r, a, b) ← relation? resultType | unreachable!
    let some (s, _, c) ← relation? (← instantiateMVars types[i]) | unreachable!
    let (α, β, γ)       := (← inferType a, ← inferType b, ← inferType c)
    let (u_1, u_2, u_3) := (← getLevel α, ← getLevel β, ← getLevel γ)
    let t ← mkFreshExprMVar (← mkArrow α (← mkArrow γ (mkSort levelZero)))
    let selfType := mkAppN (Lean.mkConst ``Trans [u_1, u_2, u_3]) #[α, β, γ, r, s, t]
    match (← trySynthInstance selfType) with
    | LOption.some self =>
      result := mkAppN (Lean.mkConst ``Trans.trans [u_1, u_2, u_3]) #[α, β, γ, r, s, t, self, a, b, c, result, proofs[i]]
      resultType := (← instantiateMVars (← inferType result)).headBeta
      unless (← relation? resultType).isSome do
        throwErrorAt stepStxs[i] "invalid 'calc' step, step result is not a relation{indentExpr resultType}"
    | _ => throwErrorAt stepStxs[i] "invalid 'calc' step, failed to synthesize `Trans` instance{indentExpr selfType}"
    pure ()
  ensureHasType expectedType? result

builtin_initialize
  registerTraceClass `Elab.binop

end BinOp

end Lean.Elab.Term