/-
Copyright (c) 2020 Minchao Wu. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Minchao Wu
-/
import tactic.explode
import tactic.interactive_expr

/-!
# `#explode_widget` command

Render a widget that displays an `#explode` proof, providing more
interactivity such as jumping to definitions and exploding constants
occurring in the exploded proofs.
-/
open widget tactic tactic.explode

meta instance widget.string_to_html {α} : has_coe string (html α) :=
⟨λ s, s⟩

namespace tactic
namespace explode_widget
open widget_override.interactive_expression
open tagged_format
open widget.html widget.attr

/-- Redefine some of the style attributes for better formatting. -/
meta def get_block_attrs {γ}: sf → tactic (sf × list (attr γ))
| (sf.block i a) := do
  let s : attr (γ) := style [
    ("display", "inline-block"),
    ("white-space", "pre-wrap"),
    ("vertical-align", "top")
  ],
  (a,rest) ← get_block_attrs a,
  pure (a, s :: rest)
| (sf.highlight c a) := do
  (a, rest) ← get_block_attrs a,
  pure (a, (cn c.to_string) :: rest)
| a := pure (a,[])

/-- Explode button for subsequent exploding. -/
meta def insert_explode {γ} : expr → tactic (list (html (action γ)))
| (expr.const n _) := (do
    pure $ [h "button" [
      cn "pointer ba br3 mr1",
      on_click (λ _, action.effect $ widget.effect.insert_text ("#explode_widget " ++ n.to_string)),
      attr.val "title" "explode"] ["💥"]]
  ) <|> pure []
| e := pure []

/--
Render a subexpression as a list of html elements.
-/
meta def view {γ} (tooltip_component : tc subexpr (action γ))
  (click_address : option expr.address)
  (select_address : option expr.address) :
  subexpr → sf → tactic (list (html (action γ)))
| ⟨ce, current_address⟩ (sf.tag_expr ea e m) := do
  let new_address := current_address ++ ea,
  let select_attrs : list (attr (action γ)) :=
    if some new_address = select_address then
       [className "highlight"] else [],
  click_attrs  : list (attr (action γ)) ←
    if some new_address = click_address then do
      content ← tc.to_html tooltip_component (e, new_address),
      efmt : string ← format.to_string <$> tactic.pp e,
      gd_btn ← goto_def_button e,
      epld_btn ← insert_explode e,
      pure [tooltip $ h "div" [] [
          h "div" [cn "fr"] (gd_btn ++ epld_btn ++ [
            h "button" [cn "pointer ba br3 mr1", on_click
                       (λ _, action.effect $ widget.effect.copy_text efmt),
                       attr.val "title" "copy expression to clipboard"] ["📋"],
            h "button" [cn "pointer ba br3", on_click
                       (λ _, action.on_close_tooltip),
                       attr.val "title" "close"] ["×"]
          ]),
          content
      ]]
    else pure [],
  (m, block_attrs) ← get_block_attrs m,
  let as := [className "expr-boundary", key (ea)] ++ select_attrs ++
            click_attrs ++ block_attrs,
  inner ← view (e,new_address) m,
  pure [h "span" as inner]
| ca (sf.compose x y) := pure (++) <*> view ca x <*> view ca y
| ca (sf.of_string s) := pure
  [h "span" [
    on_mouse_enter (λ _, action.on_mouse_enter ca),
    on_click (λ _, action.on_click ca),
    key s
  ] [html.of_string s]]
| ca b@(sf.block _ _) := do
  (a, attrs) ← get_block_attrs b,
  inner ← view ca a,
  pure [h "span" attrs inner]
| ca b@(sf.highlight _ _) := do
  (a, attrs) ← get_block_attrs b,
  inner ← view ca a,
  pure [h "span" attrs inner]

/-- Make an interactive expression. -/
meta def mk {γ} (tooltip : tc subexpr γ) : tc expr γ :=
let tooltip_comp :=
   component.with_should_update
   (λ (x y : tactic_state × expr × expr.address), x.2.2 ≠ y.2.2)
   $ component.map_action (action.on_tooltip_action) tooltip in
   component.filter_map_action
   (λ _ (a : γ ⊕ widget.effect), sum.cases_on a some (λ _, none))
$ component.with_effects (λ _ (a : γ ⊕ widget.effect),
  match a with
  | (sum.inl g) := []
  | (sum.inr s) := [s]
  end
)
$ tc.mk_simple
  (action γ)
  (option subexpr × option subexpr)
  (λ e, pure $ (none, none))
  (λ e ⟨ca, sa⟩ act, pure $
    match act with
    | (action.on_mouse_enter ⟨e, ea⟩) := ((ca, some (e, ea)), none)
    | (action.on_mouse_leave_all)     := ((ca, none), none)
    | (action.on_click ⟨e, ea⟩)       := if some (e,ea) = ca then
                                         ((none, sa), none) else
                                         ((some (e, ea), sa), none)
    | (action.on_tooltip_action g)    := ((none, sa), some $ sum.inl g)
    | (action.on_close_tooltip)       := ((none, sa), none)
    | (action.effect e)               := ((ca,sa), some $ sum.inr $ e)
    end
  )
  (λ e ⟨ca, sa⟩, do
    m ← sf.of_eformat <$> tactic.pp_tagged e,
    let m := m.elim_part_apps,
    let m := m.flatten,
    let m := m.tag_expr [] e,
    v ← view tooltip_comp (prod.snd <$> ca) (prod.snd <$> sa) ⟨e, []⟩ m,
    pure $
    [ h "span" [
          className "expr",
          key e.hash,
          on_mouse_leave (λ _, action.on_mouse_leave_all) ] $ v
      ]
  )

/-- Render the implicit arguments for an expression in fancy, little pills. -/
meta def implicit_arg_list (tooltip : tc subexpr empty) (e : expr) : tactic $ html empty := do
  fn ← (mk tooltip) $ expr.get_app_fn e,
  args ← list.mmap (mk tooltip) $ expr.get_app_args e,
  pure $ h "div" []
    ( (h "span" [className "bg-blue br3 ma1 ph2 white"] [fn]) ::
      list.map (λ a, h "span" [className "bg-gray br3 ma1 ph2 white"] [a]) args
    )

/--
Component for the type tooltip.
-/
meta def type_tooltip : tc subexpr empty :=
tc.stateless (λ ⟨e,ea⟩, do
    y ← tactic.infer_type e,
    y_comp ← mk type_tooltip y,
    implicit_args ← implicit_arg_list type_tooltip e,
    pure [h "div" [style [("minWidth", "12rem")]] [
          h "div" [cn "pl1"] [y_comp],
          h "hr" [] [],
          implicit_args
        ]
      ]
  )

/--
Component that shows a type.
-/
meta def show_type_component : tc expr empty :=
tc.stateless (λ x, do
  y ← infer_type x,
  y_comp ← mk type_tooltip $ y,
  pure y_comp
)

/--
Component that shows a constant.
-/
meta def show_constant_component : tc expr empty :=
tc.stateless (λ x, do
  y_comp ← mk type_tooltip x,
  pure y_comp
)

/--
Search for an entry that has the specified line number.
-/
meta def lookup_lines : entries → nat → entry
| ⟨_, []⟩ n := ⟨default, 0, 0, status.sintro, thm.string "", []⟩
| ⟨rb, (hd::tl)⟩ n := if hd.line = n then hd else lookup_lines ⟨rb, tl⟩ n

/--
Render a row that shows a goal.
-/
meta def goal_row (e : expr) (show_expr := tt): tactic (list (html empty)) :=
do t ← explode_widget.show_type_component e,
return $ [h "td" [cn "ba bg-dark-green tc"] "Goal",
          h "td" [cn "ba tc"]
          (if show_expr then [html.of_name e.local_pp_name, " : ", t] else t)]

/--
Render a row that shows the ID of a goal.
-/
meta def id_row {γ} (l : nat): tactic (list (html γ)) :=
return $ [h "td" [cn "ba bg-dark-green tc"] "ID",
          h "td" [cn "ba tc"] (to_string l)]

/--
Render a row that shows the rule or theorem being applied.
-/
meta def rule_row : thm →  tactic (list (html empty))
| (thm.expr e) := do t ← explode_widget.show_constant_component e,
                     return $ [h "td" [cn "ba bg-dark-green tc"] "Rule",
                               h "td" [cn "ba tc"] t]
| t := return $ [h "td" [cn "ba bg-dark-green tc"] "Rule",
                 h "td" [cn "ba tc"] t.to_string]

/--
Render a row that contains the sub-proofs, i.e., the proofs of the
arguments.
-/
meta def proof_row {γ} (args : list (html γ)): list (html γ) :=
[h "td" [cn "ba bg-dark-green tc"] "Proofs", h "td" [cn "ba tc"]
    [h "details" [] $
        (h "summary"
            [attr.style [("color", "orange")]]
                "Details")::args]
]

/--
Combine the goal row, id row, rule row and proof row to make them a table.
-/
meta def assemble_table {γ} (gr ir rr) : list (html γ) → html γ
| [] :=
h "table" [cn "collapse"]
    [h "tbody" []
        [h "tr" [] gr, h "tr" [] ir, h "tr" [] rr]
    ]
| pr :=
h "table" [cn "collapse"]
    [h "tbody" []
        [h "tr" [] gr, h "tr" [] ir, h "tr" [] rr, h "tr" [] pr]
    ]

/--
Render a table for a given entry.
-/
meta def assemble (es : entries): entry → tactic (html empty)
| ⟨e, l, d, status.sintro, t, ref⟩ := do
    gr ← goal_row e, ir ← id_row l, rr ← rule_row $ thm.string "Assumption",
    return $ assemble_table gr ir rr []
| ⟨e, l, d, status.intro, t, ref⟩ := do
    gr ← goal_row e, ir ← id_row l, rr ← rule_row $ thm.string  "Assumption",
    return $ assemble_table gr ir rr []
| ⟨e, l, d, st, t, ref⟩ := do
    gr ← goal_row e ff, ir ← id_row l, rr ← rule_row t,
    let el : list entry := list.map (lookup_lines es) ref,
    ls ← monad.mapm assemble el,
    let pr := proof_row $ ls.intersperse (h "br" [] []),
    return $ assemble_table gr ir rr pr

/--
Render a widget from given entries.
-/
meta def explode_component (es : entries) : tactic (html empty) :=
let concl := lookup_lines es (es.l.length - 1) in assemble es concl

/--
Explode a theorem and return entries.
-/
meta def explode_entries (n : name) (hide_non_prop := tt) : tactic entries :=
do expr.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 hide_non_prop

end explode_widget

open explode_widget

setup_tactic_parser

/--
User command of the explode widget.
-/
@[user_command]
meta def explode_widget_cmd (_ : parse $ tk "#explode_widget") : lean.parser unit :=
do ⟨li,co⟩ ← cur_pos,
    n ← ident,
    es ← explode_entries n,
    comp ← parser.of_tactic (do html ← explode_component es,
    c ← pure $ component.stateless (λ _, [html]),
    pure $ component.ignore_props $ component.ignore_action $ c),
    save_widget ⟨li, co - "#explode_widget".length - 1⟩ comp,
    trace "successfully rendered widget",
    skip
    .

end tactic


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import morphisms.closed_immersion
import ring_theory.ring_hom.finite
import ring_theory.local_properties
import for_mathlib.epi_finite

/-!

# Finite morphisms

A morphism of schemes is finite if it is affine and the component of the sheaf map on finite opens
is finite.
We show that this property is local, and is stable under compositions and base-changes.

-/

noncomputable theory

open category_theory category_theory.limits opposite topological_space

universe u

namespace algebraic_geometry

variables {X Y : Scheme.{u}} (f : X ⟶ Y)

/--
A morphism is `finite` if the preimages of finite open sets are finite.
-/
@[mk_iff]
class finite (f : X ⟶ Y) extends affine f : Prop :=
(is_finite_of_affine : ∀ U : opens Y.carrier, is_affine_open U → (f.1.c.app (op U)).finite)

def finite.affine_property : affine_target_morphism_property :=
affine_and @ring_hom.finite

lemma finite_eq_affine_property :
  @finite = target_affine_locally finite.affine_property :=
by { ext, rw [finite_iff, finite.affine_property,
  affine_and_target_affine_locally_iff ring_hom.finite_respects_iso] }

lemma finite.affine_property_is_local :
  finite.affine_property.is_local :=
is_local_affine_and _ ring_hom.finite_respects_iso localization_finite finite_of_localization_span

lemma finite_is_local_at_target :
  property_is_local_at_target @finite :=
finite_eq_affine_property.symm ▸ finite.affine_property_is_local.target_affine_locally_is_local

lemma finite_respects_iso : morphism_property.respects_iso @finite :=
finite_is_local_at_target.respects_iso

lemma finite_stable_under_composition : morphism_property.stable_under_composition @finite :=
by { rw finite_eq_affine_property, exact affine_and_stable_under_composition @ring_hom.finite
  ring_hom.finite_stable_under_composition }

lemma finite_stable_under_base_change : morphism_property.stable_under_base_change @finite :=
by { rw finite_eq_affine_property, exact affine_and_stable_under_base_change _
  ring_hom.finite_respects_iso localization_finite finite_of_localization_span
  ring_hom.finite_stable_under_base_change }

lemma finite_le_affine : @finite ≤ @affine :=
by { rw finite_eq_affine_property, exact target_affine_locally_affine_and_le_affine _ }

-- move me
lemma _root_.category_theory.morphism_property.respects_iso.inf {C} [category C]
  {P₁ P₂ : morphism_property C} (h₁ : P₁.respects_iso) (h₂ : P₂.respects_iso) :
    (P₁ ⊓ P₂).respects_iso :=
⟨λ _ _ _ _ _ ⟨H₁, H₂⟩, ⟨h₁.1 _ _ H₁, h₂.1 _ _ H₂⟩,
    λ _ _ _ _ _ ⟨H₁, H₂⟩, ⟨h₁.2 _ _ H₁, h₂.2 _ _ H₂⟩⟩

-- move me
lemma property_is_local_at_target.inf {P₁ P₂} (h₁ : property_is_local_at_target P₁)
  (h₂ : property_is_local_at_target P₂) : property_is_local_at_target (P₁ ⊓ P₂) :=
⟨h₁.1.inf h₂.1, λ X Y f U H, ⟨h₁.2 _ _ H.1, h₂.2 _ _ H.2⟩, λ X Y f 𝒰 H,
  ⟨h₁.3 _ 𝒰 $ λ i, (H i).1, h₂.3 _ 𝒰 $ λ i, (H i).2⟩⟩

lemma finite_Spec_iff {R S : CommRing} (f : R ⟶ S) :
  finite (Scheme.Spec.map f.op) ↔ ring_hom.finite f :=
begin
  rw [finite_eq_affine_property,
    finite.affine_property_is_local.affine_target_iff,
    finite.affine_property, affine_and_Spec_iff ring_hom.finite_respects_iso]
end

lemma is_closed_immersion_eq_finite_inf_mono :
  @is_closed_immersion = @finite ⊓ @mono Scheme _ :=
begin
  apply property_ext_of_le_affine is_closed_immersion_le_affine
    (inf_le_left.trans finite_le_affine) is_closed_immersion.is_local_at_target
    (finite_is_local_at_target.inf mono_is_local_at_target),
  intros R S f,
  simp_rw [is_closed_immersion_Spec_iff, pi.inf_apply, finite_Spec_iff],
  split,
  { rintro H,
    haveI := (is_closed_immersion_Spec_iff _).mpr H,
    exact ⟨ring_hom.finite.of_surjective _ H, infer_instance⟩ },
  { rintro ⟨h₁, h₂⟩,
    rw functor.mono_map_iff_mono at h₂,
    resetI,
    refine ring_hom.surjective_of_epi_of_finite _ _ h₁,
    convert @@category_theory.unop_epi_of_mono _ f.op h₂; exact CommRing.of_eq _ }
end

@[priority 100]
instance is_closed_immersion.to_finite {X Y : Scheme} (f : X ⟶ Y) [H : is_closed_immersion f] :
  finite f :=
by { rw is_closed_immersion_eq_finite_inf_mono at H, exact H.1 }

instance finite_comp {X Y Z : Scheme} (f : X ⟶ Y) (g : Y ⟶ Z)
  [finite f] [finite g] : finite (f ≫ g) :=
finite_stable_under_composition _ _ infer_instance infer_instance

-- lemma finite.affine_open_cover_tfae {X Y : Scheme.{u}} (f : X ⟶ Y) :
--   tfae [finite f,
--     ∃ (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)],
--       ∀ (i : 𝒰.J), is_affine (pullback f (𝒰.map i)) ∧
--         ring_hom.finite (Scheme.Γ.map (pullback.snd : pullback f (𝒰.map i) ⟶ _).op),
--     ∀ (𝒰 : Scheme.open_cover.{u} Y) [∀ i, is_affine (𝒰.obj i)] (i : 𝒰.J),
--       is_affine (pullback f (𝒰.map i)) ∧
--         ring_hom.finite (Scheme.Γ.map (pullback.snd : pullback f (𝒰.map i) ⟶ _).op),
--     ∀ {U : Scheme} (g : U ⟶ Y) [is_affine U] [is_open_immersion g],
--       is_affine (pullback f g) ∧
--         ring_hom.finite (Scheme.Γ.map (pullback.snd : pullback f g ⟶ _).op)] :=
-- finite_eq_affine_property.symm ▸
--   finite.affine_property_is_local.affine_open_cover_tfae f

-- lemma finite.open_cover_tfae {X Y : Scheme.{u}} (f : X ⟶ Y) :
--   tfae [finite f,
--     ∃ (𝒰 : Scheme.open_cover.{u} Y), ∀ (i : 𝒰.J),
--       finite (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
--     ∀ (𝒰 : Scheme.open_cover.{u} Y) (i : 𝒰.J),
--       finite (pullback.snd : (𝒰.pullback_cover f).obj i ⟶ 𝒰.obj i),
--     ∀ (U : opens Y.carrier), finite (f ∣_ U),
--     ∀ {U : Scheme} (g : U ⟶ Y) [is_open_immersion g],
--       finite (pullback.snd : pullback f g ⟶ _)] :=
-- affine_eq_affine_property.symm ▸
--   affine_affine_property_is_local.open_cover_tfae f

lemma finite_over_affine_iff [is_affine Y] :
  finite f ↔ is_affine X ∧ ring_hom.finite (Scheme.Γ.map f.op) :=
finite_eq_affine_property.symm ▸
  finite.affine_property_is_local.affine_target_iff f

lemma finite.affine_open_cover_iff {X Y : Scheme.{u}} (𝒰 : Scheme.open_cover.{u} Y)
  [∀ i, is_affine (𝒰.obj i)] (f : X ⟶ Y) :
  finite f ↔ ∀ i, is_affine (pullback f (𝒰.map i)) ∧
    ring_hom.finite (Scheme.Γ.map (pullback.snd : pullback f (𝒰.map i) ⟶ _).op) :=
finite_eq_affine_property.symm ▸
  finite.affine_property_is_local.affine_open_cover_iff f 𝒰

lemma finite.open_cover_iff {X Y : Scheme.{u}} (𝒰 : Scheme.open_cover.{u} Y)
  [∀ i, is_affine (𝒰.obj i)] (f : X ⟶ Y) :
  finite f ↔ ∀ i, finite (pullback.snd : pullback f (𝒰.map i) ⟶ _) :=
finite_eq_affine_property.symm ▸
  finite.affine_property_is_local.target_affine_locally_is_local.open_cover_iff f 𝒰

instance {X Y S : Scheme} (f : X ⟶ S) (g : Y ⟶ S) [finite g] :
  finite (pullback.fst : pullback f g ⟶ X) :=
finite_stable_under_base_change (is_pullback.of_has_pullback f g).flip infer_instance

instance {X Y S : Scheme} (f : X ⟶ S) (g : Y ⟶ S) [finite f] :
  finite (pullback.snd : pullback f g ⟶ Y) :=
finite_stable_under_base_change (is_pullback.of_has_pullback f g) infer_instance

end algebraic_geometry


/-
## Rewriting MLIR fragments with PDL

This file implements some framework support for PDL rewrites, which is used to
formalize and prove rewrite operations. We interpret the matching section of
PDL rewrites with the framework's basic pattern-matching tools, which allows us
to unify (enrich) them with constraints specified by the dialect. This is
important because we later need to reason on the semantics of matched programs,
which are only defined if the constraints are met.

The end goal is to output a template theorem that looks like this:

```lean4
-- (unification variables)
∀ (value_1: Value) (type_1: Type) (op_1: Operation),
  -- (non-unification-based constraints)
  is_float_type type_1 →

  semantics_of [mlir_bb|
    -- (symbolic pattern, almost verbatim from the `pdl.pattern` description)
    op_1 (value_1: type_1) 2
  ] =
  semantics_of [mlir_bb|
    -- (rewritten version of above)
    output_op_1 ...
  ]
```

For readability/accessibility reasons, this statement would probably be
synthetized into Lean code rather than being a general theorem instantiated
with that particular PDL rewrite. The second option would require considering
"any matching basic block" and then painstakingly proving that such a match has
the structure underlined by the PDL rewrite, which seems annoying.

Operations of PDL that we support right now:

* `pdl.operand`:
  Used as unification variable. Supports type requirement.
* `pdl.operation`:
  Used as unification term.
* `pdl.pattern`:
  Input operation for the whole rewriting workflow.
* `pdl.result`:
  Utility to reference results from `pdl.operation` pointers
* `pdl.type`:
  Used as unification variable.

Operations of PDL that we should partially or totally express:

* `pdl.attribute`:
  We don't have attributes yet
* `pdl.erase`:
  We don't compute the target yet
* `pdl.operation`:
  We should support attributes. And we don't handle the output either
* `pdl.replace`:
  We don't compute the target yet
* `pdl.rewrite`:
  One of the main components of the specification. We might not care about the
  root selection since we don't implement the pattern matching/search.

Operations or features of PDL that we don't try to express (yet):

* `pdl.operands`, `pdl.results`, `pdl.types`
  Anything related to ranges
* `pdl.apply_native_constraint`, `pdl.apply_native_rewrite`:
  This is possible in principle, but requires the native constraints/rewrites
  to be rewritten in Lean, which is slightly inconvenient.
* Use of native rewrite function in `pdl.rewrite`:
  Same as above
* Using variadic arguments or matching operands with variadic arguments
-/

import MLIR.Semantics.Types
import MLIR.Semantics.Matching
import MLIR.Semantics.Unification
import MLIR.AST
import MLIR.EDSL
import Lean.Exception
import Lean.Elab.Term
open Lean

open MLIR.AST
open MLIR.EDSL

-- TODO: We updated to new matching but did not add regular type checks

/- Utilities -/

private def MLIR.AST.SSAVal.str: MLIR.AST.SSAVal → String
  | SSAVal.SSAVal s => s

-- Get the n-th category of arguments from the specified variadic list by using
-- the operand segment size attribute
private def operandSegment (args: List SSAVal) (oss: TensorElem) (n: Nat) :=
  -- Flatten segment sizes
  let oss := match oss with
  | TensorElem.nested l => l.map (
      match · with | TensorElem.int i => i.toNat | _ => 0)
  | _ => []
  -- Accumulate
  let (oss, _) := oss.foldl
    (fun (segments, acc) size => (segments ++ [(acc, size)], acc + size))
    ([], 0)
  -- Get the segment for that argument
  let (start, size) := oss.getD n (0,0)
  (List.range size).filterMap (fun i => args.get? (i + start))

/-
### Monad for the analysis of PDL programs

While PDL programs are mostly similar to match terms, the translation involves
some bookkeeping and fresh name generation. The Translation structure keeps
track of this information, which is carried around in a state monad called
TranslationM.
-/

structure Translation (δ: Dialect α σ ε) where mk ::
  -- Unification problem
  u: Unification δ
  -- All variables defined so far (for fresh name generation)
  allvars: List String
  -- Typing judgements (to be inserted into operation terms)
  judgements: List (String × MTerm δ)
  -- List of operations that we want to collect after unification
  operations: List (MTerm δ)
  -- Names of results for each operation, and their types
  opresults: List (String × List (String × MTerm δ))
  -- Whether translation completed successfully
  success: Bool

def Translation.empty: Translation δ :=
  { u           := Unification.empty,
    allvars     := [],
    judgements  := [],
    operations  := [],
    opresults   := [],
    success     := false }

instance {δ: Dialect α σ ε} : Inhabited (Translation δ) := ⟨Translation.empty⟩

def Translation.str: Translation δ → String := fun tr =>
  "Unification problem:\n" ++
    (toString tr.u) ++
  "\nAll variables:\n " ++
    (String.join $ tr.allvars.map (s!" %{·}")) ++
  "\nTyping judgements:\n" ++
    (String.join $ tr.judgements.map (fun (v,t) => s!"  %{v}: {t}\n")) ++
  "Operation results:\n" ++
    (String.join $ tr.opresults.map (fun (n,l) => s!"  %{n}: {l}\n"))

abbrev TranslationM (δ: Dialect α σ ε) := StateT (Translation δ) IO

def TranslationM.toIO {α} (tr: Translation δ) (x: TranslationM δ α): IO α :=
  Prod.fst <$> StateT.run x tr

def TranslationM.error {α} (s: String): TranslationM δ α :=
  throw <| IO.userError (s ++ " o(x_x)o")

/-
#### Name recording and name generation

The following monad functions are concerned with tracking variables,
guaranteeing uniqueness, and generating fresh names.
-/

-- Record that [name] is now used in the problem, and check uniqueness
def TranslationM.addName (name: String): TranslationM δ Unit := do
  let tr ← get
  if name ∈ tr.allvars then
    error s!"addName: {name} is already used!"
  else
    set { tr with allvars := tr.allvars ++ [name] }

-- Check that [name] is known
def TranslationM.checkNameDefined (name: String): TranslationM δ Unit := do
  let tr ← get
  if ! name ∈ tr.allvars then
    error s!"checkNameDefined: {name} is undefined!"

-- Make up to [n] attempts at finding a fresh name by suffixing [s]
private def TranslationM.freshNameAux (s: String) (n p: Nat):
    TranslationM δ String := do
  let tr ← get
  match n with
  | 0 =>
      return s
  | m+1 =>
      let s' := s!"{s}{p}"
      if tr.allvars.all (· != s') then
        set { tr with allvars := tr.allvars ++ [s'] }
        return s'
      else
        freshNameAux s m (p+1)

-- Generate a new fresh name based on [name]; if not available, resort to
-- adding numbered suffixes
def TranslationM.makeFreshName (name: String): TranslationM δ String := do
  let tr ← get
  if tr.allvars.all (· != name) then
    addName name
    return name
  else
    let f ← freshNameAux name (tr.allvars.length+1) 0
    addName f
    return f

-- Generate [n] fresh names based on [name]
def TranslationM.makeFreshNames (name: String) (n: Nat):
    TranslationM δ (List String) :=
  (List.range n).mapM (fun idx => makeFreshName (name ++ toString idx))

-- Generate a copy of the operation with the specified prefix and fresh names.
-- Returns a pair with the new term and the list of all variables involved.
def TranslationM.makeFreshOp (prefix_: String) (op: MTerm δ) (priority: Nat):
    TranslationM δ (MTerm δ) := do
  let renameVars (done: List String) (vars: List (String × MSort)):
      TranslationM δ (List (String × MTerm δ) × List String) :=
    vars.foldlM
      (fun (repl, done) (var, sort) => do
        if var ∈ done then
          return (repl, done)
        else
          let var' ← makeFreshName (prefix_ ++ var)
          return (repl ++ [(var, MTerm.Var priority var' sort)], done ++ [var]))
      ([], done)

  let (repl, done) ← renameVars [] op.varsWithSorts
  return op.substVars repl

/-
#### Access to translation data

The following utilities query data recorded in the translation state.
-/

def TranslationM.addEquation (equation: UEq δ): TranslationM δ Unit := do
  let tr ← get
  set { tr with u := { equations := tr.u.equations ++ [equation] } }

def TranslationM.addOperation (op: MTerm δ): TranslationM δ Unit := do
  let tr ← get
  set { tr with operations := tr.operations ++ [op] }

def TranslationM.addJudgement (s: String) (type: MTerm δ): TranslationM δ Unit := do
  let tr ← get
  set { tr with judgements := tr.judgements ++ [(s, type)] }

def TranslationM.addOpResults (name: String) (results: List (String × MTerm δ)):
    TranslationM δ Unit := do
  let tr ← get
  set { tr with opresults := tr.opresults ++ [(name, results)] }

def TranslationM.findJudgement? (s: String): TranslationM δ (Option (MTerm δ)) := do
  let cmpName := fun (name, type) => if name = s then some type else none
  return (← get).judgements.findSome? cmpName

def TranslationM.findJudgement (s: String): TranslationM δ (MTerm δ) := do
  match ← findJudgement? s with
  | some type   => return type
  | none        => error s!"findJudgement: no type information for {s}!"

def TranslationM.findJudgements (l: List String):
    TranslationM δ (List (String × MTerm δ)) :=
  l.mapM (fun var => do return (var, ← findJudgement var))

def TranslationM.findOpResult? (op: String) (idx: Nat):
    TranslationM δ (Option (String × MTerm δ)) := do
  let cmpName := fun (name, rets) => if name = op then rets.get? idx else none
  return (← get).opresults.findSome? cmpName

def TranslationM.findOpResult (op: String) (idx: Nat):
    TranslationM δ (String × MTerm δ) := do
  match ← findOpResult? op idx with
  | some info   => return info
  | none        => error s!"findOpResultName: no return #{idx} for {op}!"

/-
### Translation of PDL statements to match problems

Interpretation PDL programs as match problems is fairly straightforward; most
PDL operations simply add new names or equations to the. Most of the work is
spent on parsing the input, adding new names and keeping track of information.

PDL has a lot of restrictions on what you can write; you can't use the same
variable at two different places (implicit unification), you can't have a
declaration operation (pdl.value, pdl.type, etc) without binding it to a
variable, etc. This allows us to make assumptions on the shape of the input.
-/

section
open TranslationM

-- TODO: Provide dialect data properly once implemented
private def PDLToMatch.readStatement (operationMatchTerms: List (MTerm builtin))
    (op: Op builtin): TranslationM builtin Unit := do
  let tr ← get

  match op with
  -- %name = pdl.type
  | Op.mk "pdl.type" [⟨SSAVal.SSAVal name, .undefined "pdl.type"⟩]
         [] [] (AttrDict.mk []) => do
      IO.println s!"Found new type variable: {name}"
      addName name

  -- %name = pdl.type: TYPE
  | Op.mk "pdl.type" [⟨SSAVal.SSAVal name, .undefined "pdl.type"⟩]
         [] [] (AttrDict.mk [AttrEntry.mk "type" (AttrValue.type τ)]) => do
      IO.println s!"Found new type variable: {name} (= {τ})"
      addName name
      addEquation (.Var 1 name .MMLIRType, .ConstMLIRType τ)

  -- %name = pdl.operand
  | Op.mk "pdl.operand" [⟨SSAVal.SSAVal name, .undefined "pdl.value"⟩]
         [] [] (AttrDict.mk []) => do
      IO.println s!"Found new variable: {name}"
      addName name
      let typeName ← makeFreshName (name ++ "_T")
      IO.println s!"→ Generated type name: {typeName}"
      addJudgement name (.Var 1 typeName .MMLIRType)

  -- %name = pdl.operand: %typeName
  | Op.mk "pdl.operand" [⟨SSAVal.SSAVal name, .undefined "pdl.value"⟩]
        [⟨SSAVal.SSAVal typeName, .undefined "pdl.type"⟩] [] (AttrDict.mk []) => do
      IO.println s!"Found new variable: {name} of type {typeName}"
      addName name
      checkNameDefined typeName
      addJudgement name (.Var 0 typeName .MMLIRType)

  -- %name = pdl.operation "OPNAME"(ARGS) -> TYPE
  | Op.mk "pdl.operation" [⟨SSAVal.SSAVal name, _⟩] args [] attrs => do
      let (attributeNames, opname, operand_segment_sizes) :=
        (attrs.find "attributeNames",
         attrs.find "name",
         attrs.find "operand_segment_sizes")
      let argsVal := args.map Prod.fst

      match attributeNames, opname, operand_segment_sizes with
      | some (.list _),
        some (.str opname),
        some (builtin.dense_vector_attr oss _ _ _) =>
          let values := (operandSegment argsVal oss 0).map (·.str)
          let types  := (operandSegment argsVal oss 2).map (·.str)
          IO.println s!"Found new operation: {name} matching {opname}"
          addName name

          IO.println s!"→ Arguments: {values}, return types: {types}"
          values.forM checkNameDefined
          types.forM checkNameDefined

          let valuesTypes ← findJudgements values
          let retNames ← makeFreshNames (name ++ "_res") types.length
          IO.println s!"→ Arg types: {valuesTypes}, return names: {retNames}"

          let insPattern := operationMatchTerms.find? fun
            | .App .OP [.ConstString n, _, _] => n = opname
            | _ => false
          if insPattern.isNone then
            error s!"pdl.operation: no pattern known for {opname}!"
          let insPattern := insPattern.get!

          IO.println s!"→ Using match term: {insPattern}"
          let ins ← makeFreshOp (name ++ "_") insPattern 2
          addOperation ins
          IO.println s!"→ Instantiated match term: {ins}"

          let operands_args: List (MTerm _) := valuesTypes.map (fun (v,t) =>
            .App .OPERAND [.Var 0 v .MSSAVal, t])
          let operands_rets: List (MTerm _) :=
            List.zip retNames types |>.map (fun (v, t) =>
              .App .OPERAND [.Var 1 v .MSSAVal, .Var 0 t .MMLIRType])
          let op_mterm :=
            .App .OP [
              .ConstString opname,
              .App (.LIST .MOperand) operands_args,
              .App (.LIST .MOperand) operands_rets
            ]
          addEquation (op_mterm, ins)

          let opResults := List.zip retNames (types.map (.Var 0 · .MMLIRType))
          addOpResults name opResults

      | _, _, _ =>
          error s!"pdl.operation: unexpected attributes: {attrs}"

    -- %name = pdl.result INDEX of %op
  | Op.mk "pdl.result" [⟨SSAVal.SSAVal name, .undefined "pdl.value"⟩]
        [⟨SSAVal.SSAVal opname, .undefined "pdl.operation"⟩] []  attrs => do
      match attrs.find "index" with
      | some (AttrValue.int index (MLIRType.int _ _)) =>
          IO.println
            s!"Found new variable: {name} aliasing result {index} of {opname}"
          checkNameDefined opname
          addName name

          let (resName, resType) ← findOpResult opname index.toNat
          addJudgement name resType
          addEquation (.Var 0 name .MSSAVal, .Var 1 resName .MSSAVal)

      | _ =>
          error s!"pdl.result: unexpected attributes on {opname}: {attrs}"

  | Op.mk "pdl.rewrite" [] args regions attrs =>
      return ()

  | _ => do
      error s!"{op.name}: unrecognized PDL operation"

def PDLToMatch.convert (PDLProgram: Op builtin)
    (operationMatchTerms: List (MTerm builtin)):
    TranslationM builtin Unit :=
  match PDLProgram with
  | Op.mk "pdl.pattern" _ [] [region] attrs =>
      match region with
      | Region.mk name [] stmts => do
          stmts.forM (readStatement operationMatchTerms)
          set { ← get with success := true }
      | Region.mk _ _ _ => do
          error (s!"PDLToMatch.convert: expected only one BB with no " ++
            "arguments in the pattern region")
  | Op.mk "pdl.pattern" _ _ _ _ => do
      error (s!"PDLToMatch.convert: expected operation to have exactly one " ++
        "argument (a region):\n{pattern}")
  | _ => do
      error s!"PDLToMatch.convert: not a PDL program: {PDLProgram}"

def PDLToMatch.unify: TranslationM δ Unit := do
  let tr ← get
  if ! tr.success then
    error "unify: translation did not complete successfully"
  if let some u_unified ← tr.u.solve then
    set { tr with u := u_unified }
  else
    error "unify: unification failed"

def PDLToMatch.getOperationMatchTerms: TranslationM δ (List (MTerm δ)) := do
  let tr ← get
  return tr.operations.map tr.u.applyOnTerm

end

/-
### Example PDL program
-/

private def ex_pdl: Op builtin := [mlir_op|
  "pdl.pattern"() ({
    -- %T0 = pdl.type
    %T0 = "pdl.type"() : () -> !"pdl.type"
    -- %T1 = pdl.type: i32
    %T1 = "pdl.type"() {type = i32} : () -> !"pdl.type"
    -- %v2 = pdl.operand
    %v2 = "pdl.operand"() : () -> !"pdl.value"
    -- %O3 = pdl.operation "foo.op1"(%v2) -> %T0
    %O3 = "pdl.operation"(%v2, %T0) {attributeNames = [], name = "foo.op1", operand_segment_sizes = dense<[1, 0, 1]> : vector<3×i32>} : (!"pdl.value", !"pdl.type") -> !"pdl.operation"
    -- %v4 = pdl.result 0 of %O3
    %v4 = "pdl.result"(%O3) {index = 0 : i32} : (!"pdl.operation") -> !"pdl.value"
    -- %v5 = pdl.operand: %T0
    %v5 = "pdl.operand"(%T0) : (!"pdl.type") -> !"pdl.value"
    -- %O6 = pdl.operation "foo.op2"(%v4, %v5) -> %T1
    %O6 = "pdl.operation"(%v4, %v5, %T1) {attributeNames = [], name = "foo.op2", operand_segment_sizes = dense<[2, 0, 1]> : vector<3×i32>} : (!"pdl.value", !"pdl.value", !"pdl.type") -> !"pdl.operation"

    -- TODO
    "pdl.rewrite"(%O6) ({
      "pdl.replace"(%O6, %v2) {operand_segment_sizes = dense<[1, 0, 1]> : vector<3×i32>} : (!"pdl.operation", !"pdl.value") -> ()
    }) {operand_segment_sizes = dense<[1, 0]> : vector<2×i32>} : (!"pdl.operation") -> ()
  }) {benefit = 1 : i16} : () -> ()
]

-- %res:!T = "foo.op1"(%x:!T)
private def foo_op1_pattern: MTerm builtin :=
  .App .OP [
    .ConstString "foo.op1",
    .App (.LIST .MOperand) [
      .App .OPERAND [.Var 1 "x" .MSSAVal, .Var 1 "T" .MMLIRType]],
    .App (.LIST .MOperand) [
      .App .OPERAND [.Var 1 "ret" .MSSAVal, .Var 1 "T" .MMLIRType]]
  ]
#eval foo_op1_pattern

-- %res:!T = "foo.op2"(%x:!T, %y:i32)
private def foo_op2_pattern: MTerm builtin :=
  .App .OP [
    .ConstString "foo.op2",
    .App (.LIST .MOperand) [
      .App .OPERAND [.Var 1 "x" .MSSAVal, .Var 1 "T" .MMLIRType],
      .App .OPERAND [.Var 1 "y" .MSSAVal, .ConstMLIRType .i32]],
    .App (.LIST .MOperand) [
      .App .OPERAND [.Var 1 "ret" .MSSAVal, .Var 1 "T" .MMLIRType]]
  ]
#eval foo_op2_pattern

private def foo_dialect := [foo_op1_pattern, foo_op2_pattern]

#eval show IO Unit from do
  TranslationM.toIO Translation.empty do
    PDLToMatch.convert ex_pdl foo_dialect
    IO.println $ "\n## Translation result ##\n\n" ++ (← get).str
    PDLToMatch.unify
    let matchTerms ← PDLToMatch.getOperationMatchTerms
    IO.println "\n## Final operation match terms ##\n"
    IO.println $ "\n".intercalate (matchTerms.map toString)


import meta.tactic
import util.control.applicative
import util.meta.tactic

namespace tactic

open list applicative (mmapp)

meta def add_selector (obj : expr) (fs : list name) (n : name) (ft : expr) : tactic unit :=
do let t := (obj.imp ft),
   (_,val) ← solve_aux t (do
       x ← intro1, vs ← induction x fs, get_local n >>= apply),
   val ← instantiate_mvars val,
   add_decl $ mk_theorem (obj.const_name ++ n) [ ] t val

meta def const_pis : list (expr × expr) → expr → tactic expr
 | [ ] e := return e
 | ((c, t) :: vs) e :=
   do expr.const v _ ← pure c,
      l ← mk_local_def v t,
      const_pis vs ((e.subst c l).abstract_local v)

meta def mk_implicit (bi : binder_info) : expr → expr
 | (expr.local_const n u _ t) := expr.local_const n u bi t
 | e := e

meta def mk_rec_of (c : name) : tactic (expr × list name) :=
do env  ← get_env,
   let r := c <.> "rec",
   decl ← env.get r,
   let ps := decl.univ_params,
   return (expr.const r $ map level.param ps, ps)

meta def mk_cases_on (n : name) (ps : list expr) (cs : list (list expr)) : tactic unit :=
do r ← tactic.mk_app n ps,
   let u := level.param `l,
   C ← mk_local' `C binder_info.implicit (expr.sort u),
   rec ← resolve_name (n <.> "rec"),
   let ps' := map (mk_implicit binder_info.implicit) ps,
   let inds := map (λ fs, expr.pis fs C) cs,
   vs ← mmap (mk_local_def `_) inds,
   let t := expr.pis (ps' ++ [C]) (r.imp (expr.pis vs C)),
   i ← mk_local_def `i r,
   d' ← to_expr ``(%%(foldl expr.app rec $ map to_pexpr vs) %%i : %%C),
   let d := expr.lambdas (map (mk_implicit binder_info.implicit) ps ++ [C,i] ++ vs) d',
   add_decl (mk_definition (n <.> "cases_on") [`l] t d)

meta def mk_drec (n : name) (ps : list expr) (fs : list expr) : tactic unit :=
do r ← tactic.mk_app n ps,
   (rec,ls) ← mk_rec_of (n),
   let u := level.param ls.head,
   C ← mk_local' `C binder_info.implicit (r.imp (expr.sort u)),
   mk ← mk_const (n <.> "mk"),
   let C' : expr := C $ mk.mk_app (ps ++ fs),
   let ind := expr.pis fs C',
   let ind_val := expr.pis fs C',
   let ps' := map (mk_implicit binder_info.implicit) ps,
   let fs' := map (mk_implicit binder_info.implicit) fs,
   i ← mk_local_def `i r,
   h ← mk_local_def `h ind,
   let t' := expr.pis (ps' ++ [C]) (expr.pis [i] (ind.imp $ C i)),
   let t := expr.pis (ps' ++ [C]) (ind.imp (expr.pis [i] $ C i)),
   h' ← to_expr ``(%%(h.mk_app fs) : %%C'),
   let d' := (rec.mk_app ps (C i)) (expr.lambdas fs h') i,
   d ← instantiate_mvars $ expr.lambdas (ps' ++ [C,h,i]) d',
   infer_type d >>= unify t,
   add_decl (mk_definition (n <.> "drec") [`l] t d),
   (_,d') ← solve_aux t' (intros >> apply d ; auto),
   d' ← instantiate_mvars d',
   add_decl (mk_definition (n <.> "drec_on") [`l] t' d')

meta def add_enum_type (n : name) (vals : list name) : tactic unit :=
do updateex_env $ λ e₀, return $ e₀.add_namespace n,
   let t : expr := expr.const n [ ],
   let constrs := map (λ c : name, (c.update_prefix n, t)) vals,
   add_inductive n [ ] 0 `(Type) constrs ff,
   mk_cases_on n [ ] ([ ] <$ vals)

meta def add_record
  (n : name) (ps : list expr) (rt : expr)
  (fs : list expr)
  (gen_drec : bool := ff)
: tactic unit :=
do updateex_env $ λ e₀, return $ e₀.add_namespace n,
   let t : expr := expr.mk_app (expr.const n [ ]) ps,
   let ts := expr.pis fs t,
   let ts := expr.pis ps ts,
   let type_type := expr.pis ps rt,
   add_inductive n [ ] ps.length type_type [(n <.> "mk", ts)] ff,
   mk_cases_on n ps [fs],
   when gen_drec $ mk_drec n ps fs

meta inductive record_param
 | var : expr → record_param
 | record (var : expr) (record : name) (cases_on : name) (params fields : list expr) : record_param

meta def record_param.params : record_param → list expr
 | (record_param.var _) := [ ]
 | (record_param.record _ _ _ ps _) := ps

meta def record_param.vars : record_param → list expr
 | (record_param.var x) := [x]
 | (record_param.record _ _ _ _ fs) := fs

meta def record_param.local : record_param → expr
 | (record_param.var x) := x
 | (record_param.record x _ _ _ _) := x

meta def cases_on_records' : list record_param → expr → list expr → tactic unit
 | (record_param.var x :: xs) e vs := intro1 >>= λ v, cases_on_records' xs e (v :: vs)
 | (record_param.record v n c ps fs :: xs) e₀ vs :=
 do v' ← intro1,
    cs ← induction v',
    mmap' (λ c : list _ × _, cases_on_records' xs e₀ $ c.1.reverse ++ vs) cs
 | [ ] e vs :=
   do exact $ e.mk_app vs.reverse

meta def record_param.primed : record_param → tactic record_param
 | (record_param.var v) := record_param.var <$> primed_local v
 | (record_param.record v n cases ps vs) :=
do v' ← primed_local v,
   record_param.record v' n cases ps <$> mmap primed_local vs

meta def mk_pred (n : name) (ps : list record_param) (pred : list (name × pexpr)) : tactic pexpr :=
do let vars := ps.bind record_param.vars,
   pred' ← mmapp (λ n t, to_expr t >>= mk_local_def n) pred,
   add_record n.primed vars `(Prop) pred' tt,
   pred ← resolve_name n.primed >>= to_expr,
   let vs := map record_param.local ps,
   let t := expr.pis vs `(Prop),
   (_,d) ← solve_aux t $ cases_on_records' ps pred [ ],
   infer_type d >>= unify t,
   d ← instantiate_mvars d,
   add_decl (mk_definition n [ ] t d),
   resolve_name n

end tactic


def HList (αs : List (Type u)) : Type u := αs.foldr Prod.{u, u} PUnit

@[match_pattern] def HList.nil : HList [] := ⟨⟩
@[match_pattern] def HList.cons (a : α) (as : HList αs): HList (α :: αs) := (a, as)

def HList.set : {αs : _} → HList αs → (i : Fin αs.length) → αs.get i → HList αs
  | _ :: _, cons a as, ⟨0,          h⟩, b => cons b as
  | _ :: _, cons a as, ⟨Nat.succ n, h⟩, b => cons a (set as ⟨n, Nat.le_of_succ_le_succ h⟩ b)
  | [],     nil,       _,               _ => nil

instance : EmptyCollection (HList ∅) where
  emptyCollection := HList.nil

notation:30 Γ " ⊢ " α => HList Γ → α

-- simplify well-founded recursion proofs by ignoring context sizes
local instance : SizeOf (List α) := ⟨fun _ => 0⟩ in

-- m: base monad
-- ω: `return` type, `m ω` is the type of the entire `do` block
-- Γ: `do`-local immutable context
-- Δ: `do`-local mutable context
-- b: `break` allowed
-- c: `continue` allowed
-- α: local result type, `m α` is the type of the statement
inductive Stmt (m : Type u → Type _) (ω : Type u) : (Γ Δ : List (Type u)) → (b c : Bool) → (α : Type u) → Type _ where
  | expr (e : Γ ⊢ Δ ⊢ m α) : Stmt m ω Γ Δ b c α
  | bind (s₁ : Stmt m ω Γ Δ b c α) (s₂ : Stmt m ω (α :: Γ) Δ b c β) : Stmt m ω Γ Δ b c β
  | letmut (e : Γ ⊢ Δ ⊢ α) (s : Stmt m ω Γ (α :: Δ) b c β) : Stmt m ω Γ Δ b c β
  | ass (x : Fin Δ.length) (e : Γ ⊢ Δ ⊢ Δ.get x) : Stmt m ω Γ Δ b c PUnit
  | ite (e : Γ ⊢ Δ ⊢ Bool) (s₁ s₂ : Stmt m ω Γ Δ b c α) : Stmt m ω Γ Δ b c α
  | ret (e : Γ ⊢ Δ ⊢ ω) : Stmt m ω Γ Δ b c α
  --| sfor [ForM m γ α] (e : Σ Γ → γ) (body : α → Stmt m ω Γ Δ true PUnit) : Stmt m ω Γ Δ b c PUnit
  | sfor (e : Γ ⊢ Δ ⊢ List α) (body : Stmt m ω (α :: Γ) Δ true true PUnit) : Stmt m ω Γ Δ b c PUnit
  | sbreak : Stmt m ω Γ Δ true c α
  | scont : Stmt m ω Γ Δ b true α

-- normal and abnormal result values
inductive Res (ω α : Type _) : (b c : Bool) → Type _ where
  | val (a : α) : Res ω α b c
  | ret (o : ω) : Res ω α b c
  | rbreak : Res ω α true c
  | rcont : Res ω α b true

instance : Coe α (Res ω α b c) := ⟨Res.val⟩
instance : Coe (Id α) (Res ω α b c) := ⟨Res.val⟩

def Ctx.extendBot (x : α) : {Γ : _} → HList Γ → HList (Γ ++ [α])
  | [],     _               => HList.cons x HList.nil
  | _ :: _, HList.cons a as => HList.cons a (extendBot x as)

def Ctx.extend (x : α) : HList Γ → HList (α :: Γ) :=
  fun σ => HList.cons x σ

def Ctx.drop : HList (α :: Γ) → HList Γ
  | HList.cons a as => as

-- custom wf tactic
theorem Nat.le_add_right_of_le (n m : Nat) : n ≤ m → n ≤ m + k :=
  fun h => add_le_add h (Nat.zero_le _)

macro_rules
| `(tactic| decreasing_tactic) =>
 `(tactic|
   (simp_wf
    repeat (first | apply PSigma.Lex.right | apply PSigma.Lex.left)
    simp [Nat.add_comm (n := 1), Nat.succ_add, Nat.mul_succ]
    try apply Nat.lt_succ_of_le
    repeat apply Nat.le_step
    first
    | repeat first | apply Nat.le_add_left | apply Nat.le_add_right_of_le
    | assumption
    all_goals apply Nat.le_refl
))

@[simp]
def Stmt.mapCtx (f : HList Γ' → HList Γ) : Stmt m ω Γ Δ b c β → Stmt m ω Γ' Δ b c β
  | expr e => expr (e ∘ f)
  | bind s₁ s₂ => bind (s₁.mapCtx f) (s₂.mapCtx (fun | HList.cons a as => HList.cons a (f as)))
  | letmut e s => letmut (e ∘ f) (s.mapCtx f)
  | ass x e => ass x (e ∘ f)
  | ite e s₁ s₂ => ite (e ∘ f) (s₁.mapCtx f) (s₂.mapCtx f)
  | ret e => ret (e ∘ f)
  | sfor e body => sfor (e ∘ f) (body.mapCtx (fun | HList.cons a as => HList.cons a (f as)))
  | sbreak => sbreak
  | scont => scont
termination_by mapCtx _ s => sizeOf s


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.limits.shapes.pullbacks
import category_theory.limits.shapes.strong_epi
import category_theory.limits.shapes.equalizers

/-!
# Definitions and basic properties of regular monomorphisms and epimorphisms.

A regular monomorphism is a morphism that is the equalizer of some parallel pair.

We give the constructions
* `split_mono → regular_mono` and
* `regular_mono → mono`
as well as the dual constructions for regular epimorphisms. Additionally, we give the construction
* `regular_epi ⟶ strong_epi`.

We also define classes `regular_mono_category` and `regular_epi_category` for categories in which
every monomorphism or epimorphism is regular, and deduce that these categories are
`strong_mono_category`s resp. `strong_epi_category`s.

-/

noncomputable theory

namespace category_theory
open category_theory.limits

universes v₁ u₁ u₂

variables {C : Type u₁} [category.{v₁} C]

variables {X Y : C}

/-- A regular monomorphism is a morphism which is the equalizer of some parallel pair. -/
class regular_mono (f : X ⟶ Y) :=
(Z : C)
(left right : Y ⟶ Z)
(w : f ≫ left = f ≫ right)
(is_limit : is_limit (fork.of_ι f w))

attribute [reassoc] regular_mono.w

/-- Every regular monomorphism is a monomorphism. -/
@[priority 100]
instance regular_mono.mono (f : X ⟶ Y) [regular_mono f] : mono f :=
mono_of_is_limit_parallel_pair regular_mono.is_limit

instance equalizer_regular (g h : X ⟶ Y) [has_limit (parallel_pair g h)] :
  regular_mono (equalizer.ι g h) :=
{ Z := Y,
  left := g,
  right := h,
  w := equalizer.condition g h,
  is_limit := fork.is_limit.mk _ (λ s, limit.lift _ s) (by simp) (λ s m w, by { ext1, simp [←w] }) }

/-- Every split monomorphism is a regular monomorphism. -/
@[priority 100]
instance regular_mono.of_split_mono (f : X ⟶ Y) [split_mono f] : regular_mono f :=
{ Z     := Y,
  left  := 𝟙 Y,
  right := retraction f ≫ f,
  w     := by tidy,
  is_limit := split_mono_equalizes f }

/-- If `f` is a regular mono, then any map `k : W ⟶ Y` equalizing `regular_mono.left` and
    `regular_mono.right` induces a morphism `l : W ⟶ X` such that `l ≫ f = k`. -/
def regular_mono.lift' {W : C} (f : X ⟶ Y) [regular_mono f] (k : W ⟶ Y)
  (h : k ≫ (regular_mono.left : Y ⟶ @regular_mono.Z _ _ _ _ f _) = k ≫ regular_mono.right) :
  {l : W ⟶ X // l ≫ f = k} :=
fork.is_limit.lift' regular_mono.is_limit _ h

/--
The second leg of a pullback cone is a regular monomorphism if the right component is too.

See also `pullback.snd_of_mono` for the basic monomorphism version, and
`regular_of_is_pullback_fst_of_regular` for the flipped version.
-/
def regular_of_is_pullback_snd_of_regular {P Q R S : C} {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S}
  {k : R ⟶ S} [hr : regular_mono h] (comm : f ≫ h = g ≫ k)
  (t : is_limit (pullback_cone.mk _ _ comm)) :
regular_mono g :=
{ Z := hr.Z,
  left := k ≫ hr.left,
  right := k ≫ hr.right,
  w := by rw [← reassoc_of comm, ← reassoc_of comm, hr.w],
  is_limit :=
  begin
    apply fork.is_limit.mk' _ _,
    intro s,
    have l₁ : (fork.ι s ≫ k) ≫ regular_mono.left = (fork.ι s ≫ k) ≫ regular_mono.right,
      rw [category.assoc, s.condition, category.assoc],
    obtain ⟨l, hl⟩ := fork.is_limit.lift' hr.is_limit _ l₁,
    obtain ⟨p, hp₁, hp₂⟩ := pullback_cone.is_limit.lift' t _ _ hl,
    refine ⟨p, hp₂, _⟩,
    intros m w,
    have z : m ≫ g = p ≫ g := w.trans hp₂.symm,
    apply t.hom_ext,
    apply (pullback_cone.mk f g comm).equalizer_ext,
    { erw [← cancel_mono h, category.assoc, category.assoc, comm, reassoc_of z] },
    { exact z },
  end }

/--
The first leg of a pullback cone is a regular monomorphism if the left component is too.

See also `pullback.fst_of_mono` for the basic monomorphism version, and
`regular_of_is_pullback_snd_of_regular` for the flipped version.
-/
def regular_of_is_pullback_fst_of_regular {P Q R S : C} {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S}
  {k : R ⟶ S} [hr : regular_mono k] (comm : f ≫ h = g ≫ k)
  (t : is_limit (pullback_cone.mk _ _ comm)) :
regular_mono f :=
regular_of_is_pullback_snd_of_regular comm.symm (pullback_cone.flip_is_limit t)

@[priority 100]
instance strong_mono_of_regular_mono (f : X ⟶ Y) [regular_mono f] : strong_mono f :=
{ mono := by apply_instance,
  has_lift :=
  begin
    introsI,
    have : v ≫ (regular_mono.left : Y ⟶ regular_mono.Z f) = v ≫ regular_mono.right,
    { apply (cancel_epi z).1,
      simp only [regular_mono.w, ← reassoc_of h] },
    obtain ⟨t, ht⟩ := regular_mono.lift' _ _ this,
    refine arrow.has_lift.mk ⟨t, (cancel_mono f).1 _, ht⟩,
    simp only [arrow.mk_hom, arrow.hom_mk'_left, category.assoc, ht, h]
  end }

/-- A regular monomorphism is an isomorphism if it is an epimorphism. -/
lemma is_iso_of_regular_mono_of_epi (f : X ⟶ Y) [regular_mono f] [e : epi f] : is_iso f :=
is_iso_of_epi_of_strong_mono _

section
variables (C)

/-- A regular mono category is a category in which every monomorphism is regular. -/
class regular_mono_category :=
(regular_mono_of_mono : ∀ {X Y : C} (f : X ⟶ Y) [mono f], regular_mono f)

end

/-- In a category in which every monomorphism is regular, we can express every monomorphism as
    an equalizer. This is not an instance because it would create an instance loop. -/
def regular_mono_of_mono [regular_mono_category C] (f : X ⟶ Y) [mono f] : regular_mono f :=
regular_mono_category.regular_mono_of_mono _

@[priority 100]
instance regular_mono_category_of_split_mono_category [split_mono_category C] :
  regular_mono_category C :=
{ regular_mono_of_mono := λ _ _ f _,
  by { haveI := by exactI split_mono_of_mono f, apply_instance } }

@[priority 100]
instance strong_mono_category_of_regular_mono_category [regular_mono_category C] :
  strong_mono_category C :=
{ strong_mono_of_mono := λ _ _ f _,
    by { haveI := by exactI regular_mono_of_mono f, apply_instance } }

/-- A regular epimorphism is a morphism which is the coequalizer of some parallel pair. -/
class regular_epi (f : X ⟶ Y) :=
(W : C)
(left right : W ⟶ X)
(w : left ≫ f = right ≫ f)
(is_colimit : is_colimit (cofork.of_π f w))

attribute [reassoc] regular_epi.w

/-- Every regular epimorphism is an epimorphism. -/
@[priority 100]
instance regular_epi.epi (f : X ⟶ Y) [regular_epi f] : epi f :=
epi_of_is_colimit_parallel_pair regular_epi.is_colimit

instance coequalizer_regular (g h : X ⟶ Y) [has_colimit (parallel_pair g h)] :
  regular_epi (coequalizer.π g h) :=
{ W := X,
  left := g,
  right := h,
  w := coequalizer.condition g h,
  is_colimit := cofork.is_colimit.mk _ (λ s, colimit.desc _ s) (by simp)
    (λ s m w, by { ext1, simp [←w] }) }

/-- Every split epimorphism is a regular epimorphism. -/
@[priority 100]
instance regular_epi.of_split_epi (f : X ⟶ Y) [split_epi f] : regular_epi f :=
{ W     := X,
  left  := 𝟙 X,
  right := f ≫ section_ f,
  w     := by tidy,
  is_colimit := split_epi_coequalizes f }

/-- If `f` is a regular epi, then every morphism `k : X ⟶ W` coequalizing `regular_epi.left` and
    `regular_epi.right` induces `l : Y ⟶ W` such that `f ≫ l = k`. -/
def regular_epi.desc' {W : C} (f : X ⟶ Y) [regular_epi f] (k : X ⟶ W)
  (h : (regular_epi.left : regular_epi.W f ⟶ X) ≫ k = regular_epi.right ≫ k) :
  {l : Y ⟶ W // f ≫ l = k} :=
cofork.is_colimit.desc' (regular_epi.is_colimit) _ h

/--
The second leg of a pushout cocone is a regular epimorphism if the right component is too.

See also `pushout.snd_of_epi` for the basic epimorphism version, and
`regular_of_is_pushout_fst_of_regular` for the flipped version.
-/
def regular_of_is_pushout_snd_of_regular
  {P Q R S : C} {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S} {k : R ⟶ S}
  [gr : regular_epi g] (comm : f ≫ h = g ≫ k) (t : is_colimit (pushout_cocone.mk _ _ comm)) :
regular_epi h :=
{ W := gr.W,
  left := gr.left ≫ f,
  right := gr.right ≫ f,
  w := by rw [category.assoc, category.assoc, comm, reassoc_of gr.w],
  is_colimit :=
  begin
    apply cofork.is_colimit.mk' _ _,
    intro s,
    have l₁ : gr.left ≫ f ≫ s.π = gr.right ≫ f ≫ s.π,
      rw [← category.assoc, ← category.assoc, s.condition],
    obtain ⟨l, hl⟩ := cofork.is_colimit.desc' gr.is_colimit (f ≫ cofork.π s) l₁,
    obtain ⟨p, hp₁, hp₂⟩ := pushout_cocone.is_colimit.desc' t _ _ hl.symm,
    refine ⟨p, hp₁, _⟩,
    intros m w,
    have z := w.trans hp₁.symm,
    apply t.hom_ext,
    apply (pushout_cocone.mk _ _ comm).coequalizer_ext,
    { exact z },
    { erw [← cancel_epi g, ← reassoc_of comm, ← reassoc_of comm, z], refl },
  end }

/--
The first leg of a pushout cocone is a regular epimorphism if the left component is too.

See also `pushout.fst_of_epi` for the basic epimorphism version, and
`regular_of_is_pushout_snd_of_regular` for the flipped version.
-/
def regular_of_is_pushout_fst_of_regular
  {P Q R S : C} {f : P ⟶ Q} {g : P ⟶ R} {h : Q ⟶ S} {k : R ⟶ S}
  [fr : regular_epi f] (comm : f ≫ h = g ≫ k) (t : is_colimit (pushout_cocone.mk _ _ comm)) :
regular_epi k :=
regular_of_is_pushout_snd_of_regular comm.symm (pushout_cocone.flip_is_colimit t)

@[priority 100]
instance strong_epi_of_regular_epi (f : X ⟶ Y) [regular_epi f] : strong_epi f :=
{ epi := by apply_instance,
  has_lift :=
  begin
    introsI,
    have : (regular_epi.left : regular_epi.W f ⟶ X) ≫ u = regular_epi.right ≫ u,
    { apply (cancel_mono z).1,
      simp only [category.assoc, h, regular_epi.w_assoc] },
    obtain ⟨t, ht⟩ := regular_epi.desc' f u this,
    exact arrow.has_lift.mk ⟨t, ht, (cancel_epi f).1
      (by simp only [←category.assoc, ht, ←h, arrow.mk_hom, arrow.hom_mk'_right])⟩,
  end }

/-- A regular epimorphism is an isomorphism if it is a monomorphism. -/
lemma is_iso_of_regular_epi_of_mono (f : X ⟶ Y) [regular_epi f] [m : mono f] : is_iso f :=
is_iso_of_mono_of_strong_epi _

section
variables (C)

/-- A regular epi category is a category in which every epimorphism is regular. -/
class regular_epi_category :=
(regular_epi_of_epi : ∀ {X Y : C} (f : X ⟶ Y) [epi f], regular_epi f)

end

/-- In a category in which every epimorphism is regular, we can express every epimorphism as
    a coequalizer. This is not an instance because it would create an instance loop. -/
def regular_epi_of_epi [regular_epi_category C] (f : X ⟶ Y) [epi f] : regular_epi f :=
regular_epi_category.regular_epi_of_epi _

@[priority 100]
instance regular_epi_category_of_split_epi_category [split_epi_category C] :
  regular_epi_category C :=
{ regular_epi_of_epi := λ _ _ f _, by { haveI := by exactI split_epi_of_epi f, apply_instance } }

@[priority 100]
instance strong_epi_category_of_regular_epi_category [regular_epi_category C] :
  strong_epi_category C :=
{ strong_epi_of_epi := λ _ _ f _, by { haveI := by exactI regular_epi_of_epi f, apply_instance } }

end category_theory


/-
Copyright (c) 2022 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Mario Carneiro
-/
prelude
import Init.Notation
set_option linter.missingDocs true -- keep it documented

namespace Lean.Parser.Tactic
/--
`with_annotate_state stx t` annotates the lexical range of `stx : Syntax` with
the initial and final state of running tactic `t`.
-/
scoped syntax (name := withAnnotateState)
  "with_annotate_state " rawStx ppSpace tactic : tactic

/--
Introduces one or more hypotheses, optionally naming and/or pattern-matching them.
For each hypothesis to be introduced, the remaining main goal's target type must
be a `let` or function type.

* `intro` by itself introduces one anonymous hypothesis, which can be accessed
  by e.g. `assumption`.
* `intro x y` introduces two hypotheses and names them. Individual hypotheses
  can be anonymized via `_`, or matched against a pattern:
  ```lean
  -- ... ⊢ α × β → ...
  intro (a, b)
  -- ..., a : α, b : β ⊢ ...
  ```
* Alternatively, `intro` can be combined with pattern matching much like `fun`:
  ```lean
  intro
  | n + 1, 0 => tac
  | ...
  ```
-/
syntax (name := intro) "intro " notFollowedBy("|") (colGt term:max)* : tactic

/--
`intros x...` behaves like `intro x...`, but then keeps introducing (anonymous)
hypotheses until goal is not of a function type.
-/
syntax (name := intros) "intros " (colGt (ident <|> hole))* : tactic

/--
`rename t => x` renames the most recent hypothesis whose type matches `t`
(which may contain placeholders) to `x`, or fails if no such hypothesis could be found.
-/
syntax (name := rename) "rename " term " => " ident : tactic

/--
`revert x...` is the inverse of `intro x...`: it moves the given hypotheses
into the main goal's target type.
-/
syntax (name := revert) "revert " (colGt term:max)+ : tactic

/--
`clear x...` removes the given hypotheses, or fails if there are remaining
references to a hypothesis.
-/
syntax (name := clear) "clear " (colGt term:max)+ : tactic

/--
`subst x...` substitutes each `x` with `e` in the goal if there is a hypothesis
of type `x = e` or `e = x`.
If `x` is itself a hypothesis of type `y = e` or `e = y`, `y` is substituted instead.
-/
syntax (name := subst) "subst " (colGt term:max)+ : tactic

/--
Applies `subst` to all hypotheses of the form `h : x = t` or `h : t = x`.
-/
syntax (name := substVars) "subst_vars" : tactic

/--
`assumption` tries to solve the main goal using a hypothesis of compatible type, or else fails.
Note also the `‹t›` term notation, which is a shorthand for `show t by assumption`.
-/
syntax (name := assumption) "assumption" : tactic

/--
`contradiction` closes the main goal if its hypotheses are "trivially contradictory".
- Inductive type/family with no applicable constructors
```lean
example (h : False) : p := by contradiction
```
- Injectivity of constructors
```lean
example (h : none = some true) : p := by contradiction  --
```
- Decidable false proposition
```lean
example (h : 2 + 2 = 3) : p := by contradiction
```
- Contradictory hypotheses
```lean
example (h : p) (h' : ¬ p) : q := by contradiction
```
- Other simple contradictions such as
```lean
example (x : Nat) (h : x ≠ x) : p := by contradiction
```
-/
syntax (name := contradiction) "contradiction" : tactic

/--
`apply e` tries to match the current goal against the conclusion of `e`'s type.
If it succeeds, then the tactic returns as many subgoals as the number of premises that
have not been fixed by type inference or type class resolution.
Non-dependent premises are added before dependent ones.

The `apply` tactic uses higher-order pattern matching, type class resolution,
and first-order unification with dependent types.
-/
syntax (name := apply) "apply " term : tactic

/--
`exact e` closes the main goal if its target type matches that of `e`.
-/
syntax (name := exact) "exact " term : tactic

/--
`refine e` behaves like `exact e`, except that named (`?x`) or unnamed (`?_`)
holes in `e` that are not solved by unification with the main goal's target type
are converted into new goals, using the hole's name, if any, as the goal case name.
-/
syntax (name := refine) "refine " term : tactic

/--
`refine' e` behaves like `refine e`, except that unsolved placeholders (`_`)
and implicit parameters are also converted into new goals.
-/
syntax (name := refine') "refine' " term : tactic

/--
If the main goal's target type is an inductive type, `constructor` solves it with
the first matching constructor, or else fails.
-/
syntax (name := constructor) "constructor" : tactic

/--
* `case tag => tac` focuses on the goal with case name `tag` and solves it using `tac`,
  or else fails.
* `case tag x₁ ... xₙ => tac` additionally renames the `n` most recent hypotheses
  with inaccessible names to the given names.
* `case tag₁ | tag₂ => tac` is equivalent to `(case tag₁ => tac); (case tag₂ => tac)`.
-/
syntax (name := case) "case " sepBy1(caseArg, " | ") " => " tacticSeq : tactic

/--
`case'` is similar to the `case tag => tac` tactic, but does not ensure the goal
has been solved after applying `tac`, nor admits the goal if `tac` failed.
Recall that `case` closes the goal using `sorry` when `tac` fails, and
the tactic execution is not interrupted.
-/
syntax (name := case') "case' " sepBy1(caseArg, " | ") " => " tacticSeq : tactic

/--
`next => tac` focuses on the next goal and solves it using `tac`, or else fails.
`next x₁ ... xₙ => tac` additionally renames the `n` most recent hypotheses with
inaccessible names to the given names.
-/
macro "next " args:binderIdent* " => " tac:tacticSeq : tactic => `(tactic| case _ $args* => $tac)

/-- `all_goals tac` runs `tac` on each goal, concatenating the resulting goals, if any. -/
syntax (name := allGoals) "all_goals " tacticSeq : tactic

/--
`any_goals tac` applies the tactic `tac` to every goal, and succeeds if at
least one application succeeds.
-/
syntax (name := anyGoals) "any_goals " tacticSeq : tactic

/--
`focus tac` focuses on the main goal, suppressing all other goals, and runs `tac` on it.
Usually `· tac`, which enforces that the goal is closed by `tac`, should be preferred.
-/
syntax (name := focus) "focus " tacticSeq : tactic

/-- `skip` does nothing. -/
syntax (name := skip) "skip" : tactic

/-- `done` succeeds iff there are no remaining goals. -/
syntax (name := done) "done" : tactic

/-- `trace_state` displays the current state in the info view. -/
syntax (name := traceState) "trace_state" : tactic

/-- `trace msg` displays `msg` in the info view. -/
syntax (name := traceMessage) "trace " str : tactic

/-- `fail_if_success t` fails if the tactic `t` succeeds. -/
syntax (name := failIfSuccess) "fail_if_success " tacticSeq : tactic

/--
`(tacs)` executes a list of tactics in sequence, without requiring that
the goal be closed at the end like `· tacs`. Like `by` itself, the tactics
can be either separated by newlines or `;`.
-/
syntax (name := paren) "(" withoutPosition(tacticSeq) ")" : tactic

/--
`with_reducible tacs` excutes `tacs` using the reducible transparency setting.
In this setting only definitions tagged as `[reducible]` are unfolded.
-/
syntax (name := withReducible) "with_reducible " tacticSeq : tactic

/--
`with_reducible_and_instances tacs` excutes `tacs` using the `.instances` transparency setting.
In this setting only definitions tagged as `[reducible]` or type class instances are unfolded.
-/
syntax (name := withReducibleAndInstances) "with_reducible_and_instances " tacticSeq : tactic

/--
`with_unfolding_all tacs` excutes `tacs` using the `.all` transparency setting.
In this setting all definitions that are not opaque are unfolded.
-/
syntax (name := withUnfoldingAll) "with_unfolding_all " tacticSeq : tactic

/-- `first | tac | ...` runs each `tac` until one succeeds, or else fails. -/
syntax (name := first) "first " withPosition((colGe "|" tacticSeq)+) : tactic

/--
`rotate_left n` rotates goals to the left by `n`. That is, `rotate_left 1`
takes the main goal and puts it to the back of the subgoal list.
If `n` is omitted, it defaults to `1`.
-/
syntax (name := rotateLeft) "rotate_left" (num)? : tactic

/--
Rotate the goals to the right by `n`. That is, take the goal at the back
and push it to the front `n` times. If `n` is omitted, it defaults to `1`.
-/
syntax (name := rotateRight) "rotate_right" (num)? : tactic

/-- `try tac` runs `tac` and succeeds even if `tac` failed. -/
macro "try " t:tacticSeq : tactic => `(tactic| first | $t | skip)

/--
`tac <;> tac'` runs `tac` on the main goal and `tac'` on each produced goal,
concatenating all goals produced by `tac'`.
-/
macro:1 x:tactic tk:" <;> " y:tactic:2 : tactic => `(tactic|
  focus
    $x:tactic
    -- annotate token with state after executing `x`
    with_annotate_state $tk skip
    all_goals $y:tactic)

/-- `eq_refl` is equivalent to `exact rfl`, but has a few optimizations. -/
syntax (name := refl) "eq_refl" : tactic

/--
`rfl` tries to close the current goal using reflexivity.
This is supposed to be an extensible tactic and users can add their own support
for new reflexive relations.
-/
macro "rfl" : tactic => `(tactic| eq_refl)

/--
`rfl'` is similar to `rfl`, but disables smart unfolding and unfolds all kinds of definitions,
theorems included (relevant for declarations defined by well-founded recursion).
-/
macro "rfl'" : tactic => `(tactic| set_option smartUnfolding false in with_unfolding_all rfl)

/--
`ac_rfl` proves equalities up to application of an associative and commutative operator.
```
instance : IsAssociative (α := Nat) (.+.) := ⟨Nat.add_assoc⟩
instance : IsCommutative (α := Nat) (.+.) := ⟨Nat.add_comm⟩

example (a b c d : Nat) : a + b + c + d = d + (b + c) + a := by ac_rfl
```
-/
syntax (name := acRfl) "ac_rfl" : tactic

/--
The `sorry` tactic closes the goal using `sorryAx`. This is intended for stubbing out incomplete
parts of a proof while still having a syntactically correct proof skeleton. Lean will give
a warning whenever a proof uses `sorry`, so you aren't likely to miss it, but
you can double check if a theorem depends on `sorry` by using
`#print axioms my_thm` and looking for `sorryAx` in the axiom list.
-/
macro "sorry" : tactic => `(tactic| exact @sorryAx _ false)

/-- `admit` is a shorthand for `exact sorry`. -/
macro "admit" : tactic => `(tactic| exact @sorryAx _ false)

/--
`infer_instance` is an abbreviation for `exact inferInstance`.
It synthesizes a value of any target type by typeclass inference.
-/
macro "infer_instance" : tactic => `(tactic| exact inferInstance)

/-- Optional configuration option for tactics -/
syntax config := atomic(" (" &"config") " := " withoutPosition(term) ")"

/-- The `*` location refers to all hypotheses and the goal. -/
syntax locationWildcard := "*"

/--
A hypothesis location specification consists of 1 or more hypothesis references
and optionally `⊢` denoting the goal.
-/
syntax locationHyp := (colGt term:max)+ patternIgnore("⊢" <|> "|-")?

/--
Location specifications are used by many tactics that can operate on either the
hypotheses or the goal. It can have one of the forms:
* 'empty' is not actually present in this syntax, but most tactics use
  `(location)?` matchers. It means to target the goal only.
* `at h₁ ... hₙ`: target the hypotheses `h₁`, ..., `hₙ`
* `at h₁ h₂ ⊢`: target the hypotheses `h₁` and `h₂`, and the goal
* `at *`: target all hypotheses and the goal
-/
syntax location := withPosition(" at " (locationWildcard <|> locationHyp))

/--
* `change tgt'` will change the goal from `tgt` to `tgt'`,
  assuming these are definitionally equal.
* `change t' at h` will change hypothesis `h : t` to have type `t'`, assuming
  assuming `t` and `t'` are definitionally equal.
-/
syntax (name := change) "change " term (location)? : tactic

/--
* `change a with b` will change occurrences of `a` to `b` in the goal,
  assuming `a` and `b` are are definitionally equal.
* `change a with b at h` similarly changes `a` to `b` in the type of hypothesis `h`.
-/
syntax (name := changeWith) "change " term " with " term (location)? : tactic

/--
If `thm` is a theorem `a = b`, then as a rewrite rule,
* `thm` means to replace `a` with `b`, and
* `← thm` means to replace `b` with `a`.
-/
syntax rwRule    := patternIgnore("← " <|> "<- ")? term
/-- A `rwRuleSeq` is a list of `rwRule` in brackets. -/
syntax rwRuleSeq := " [" withoutPosition(rwRule,*,?) "]"

/--
`rewrite [e]` applies identity `e` as a rewrite rule to the target of the main goal.
If `e` is preceded by left arrow (`←` or `<-`), the rewrite is applied in the reverse direction.
If `e` is a defined constant, then the equational theorems associated with `e` are used.
This provides a convenient way to unfold `e`.
- `rewrite [e₁, ..., eₙ]` applies the given rules sequentially.
- `rewrite [e] at l` rewrites `e` at location(s) `l`, where `l` is either `*` or a
  list of hypotheses in the local context. In the latter case, a turnstile `⊢` or `|-`
  can also be used, to signify the target of the goal.
-/
syntax (name := rewriteSeq) "rewrite" (config)? rwRuleSeq (location)? : tactic

/--
`rw` is like `rewrite`, but also tries to close the goal by "cheap" (reducible) `rfl` afterwards.
-/
macro (name := rwSeq) "rw" c:(config)? s:rwRuleSeq l:(location)? : tactic =>
  match s with
  | `(rwRuleSeq| [$rs,*]%$rbrak) =>
    -- We show the `rfl` state on `]`
    `(tactic| (rewrite $(c)? [$rs,*] $(l)?; with_annotate_state $rbrak (try (with_reducible rfl))))
  | _ => Macro.throwUnsupported

/--
The `injection` tactic is based on the fact that constructors of inductive data
types are injections.
That means that if `c` is a constructor of an inductive datatype, and if `(c t₁)`
and `(c t₂)` are two terms that are equal then  `t₁` and `t₂` are equal too.
If `q` is a proof of a statement of conclusion `t₁ = t₂`, then injection applies
injectivity to derive the equality of all arguments of `t₁` and `t₂` placed in
the same positions. For example, from `(a::b) = (c::d)` we derive `a=c` and `b=d`.
To use this tactic `t₁` and `t₂` should be constructor applications of the same constructor.
Given `h : a::b = c::d`, the tactic `injection h` adds two new hypothesis with types
`a = c` and `b = d` to the main goal.
The tactic `injection h with h₁ h₂` uses the names `h₁` and `h₂` to name the new hypotheses.
-/
syntax (name := injection) "injection " term (" with " (colGt (ident <|> hole))+)? : tactic

/-- `injections` applies `injection` to all hypotheses recursively
(since `injection` can produce new hypotheses). Useful for destructing nested
constructor equalities like `(a::b::c) = (d::e::f)`. -/
-- TODO: add with
syntax (name := injections) "injections" (colGt (ident <|> hole))* : tactic

/--
The discharger clause of `simp` and related tactics.
This is a tactic used to discharge the side conditions on conditional rewrite rules.
-/
syntax discharger := atomic(" (" patternIgnore(&"discharger" <|> &"disch")) " := " withoutPosition(tacticSeq) ")"

/-- Use this rewrite rule before entering the subterms -/
syntax simpPre   := "↓"
/-- Use this rewrite rule after entering the subterms -/
syntax simpPost  := "↑"
/--
A simp lemma specification is:
* optional `↑` or `↓` to specify use before or after entering the subterm
* optional `←` to use the lemma backward
* `thm` for the theorem to rewrite with
-/
syntax simpLemma := (simpPre <|> simpPost)? patternIgnore("← " <|> "<- ")? term
/-- An erasure specification `-thm` says to remove `thm` from the simp set -/
syntax simpErase := "-" term:max
/-- The simp lemma specification `*` means to rewrite with all hypotheses -/
syntax simpStar  := "*"
/--
The `simp` tactic uses lemmas and hypotheses to simplify the main goal target or
non-dependent hypotheses. It has many variants:
- `simp` simplifies the main goal target using lemmas tagged with the attribute `[simp]`.
- `simp [h₁, h₂, ..., hₙ]` simplifies the main goal target using the lemmas tagged
  with the attribute `[simp]` and the given `hᵢ`'s, where the `hᵢ`'s are expressions.
  If an `hᵢ` is a defined constant `f`, then the equational lemmas associated with
  `f` are used. This provides a convenient way to unfold `f`.
- `simp [*]` simplifies the main goal target using the lemmas tagged with the
  attribute `[simp]` and all hypotheses.
- `simp only [h₁, h₂, ..., hₙ]` is like `simp [h₁, h₂, ..., hₙ]` but does not use `[simp]` lemmas.
- `simp [-id₁, ..., -idₙ]` simplifies the main goal target using the lemmas tagged
  with the attribute `[simp]`, but removes the ones named `idᵢ`.
- `simp at h₁ h₂ ... hₙ` simplifies the hypotheses `h₁ : T₁` ... `hₙ : Tₙ`. If
  the target or another hypothesis depends on `hᵢ`, a new simplified hypothesis
  `hᵢ` is introduced, but the old one remains in the local context.
- `simp at *` simplifies all the hypotheses and the target.
- `simp [*] at *` simplifies target and all (propositional) hypotheses using the
  other hypotheses.
-/
syntax (name := simp) "simp" (config)? (discharger)? (&" only")?
  (" [" withoutPosition((simpStar <|> simpErase <|> simpLemma),*) "]")? (location)? : tactic
/--
`simp_all` is a stronger version of `simp [*] at *` where the hypotheses and target
are simplified multiple times until no simplication is applicable.
Only non-dependent propositional hypotheses are considered.
-/
syntax (name := simpAll) "simp_all" (config)? (discharger)? (&" only")?
  (" [" withoutPosition((simpErase <|> simpLemma),*) "]")? : tactic

/--
The `dsimp` tactic is the definitional simplifier. It is similar to `simp` but only
applies theorems that hold by reflexivity. Thus, the result is guaranteed to be
definitionally equal to the input.
-/
syntax (name := dsimp) "dsimp" (config)? (discharger)? (&" only")?
  (" [" withoutPosition((simpErase <|> simpLemma),*) "]")? (location)? : tactic

/--
`delta id1 id2 ...` delta-expands the definitions `id1`, `id2`, ....
This is a low-level tactic, it will expose how recursive definitions have been
compiled by Lean.
-/
syntax (name := delta) "delta " (colGt ident)+ (location)? : tactic

/--
* `unfold id` unfolds definition `id`.
* `unfold id1 id2 ...` is equivalent to `unfold id1; unfold id2; ...`.

For non-recursive definitions, this tactic is identical to `delta`.
For definitions by pattern matching, it uses "equation lemmas" which are
autogenerated for each match arm.
-/
syntax (name := unfold) "unfold " (colGt ident)+ (location)? : tactic

/--
Auxiliary macro for lifting have/suffices/let/...
It makes sure the "continuation" `?_` is the main goal after refining.
-/
macro "refine_lift " e:term : tactic => `(tactic| focus (refine no_implicit_lambda% $e; rotate_right))

/--
`have h : t := e` adds the hypothesis `h : t` to the current goal if `e` a term
of type `t`.
* If `t` is omitted, it will be inferred.
* If `h` is omitted, the name `this` is used.
* The variant `have pattern := e` is equivalent to `match e with | pattern => _`,
  and it is convenient for types that have only one applicable constructor.
  For example, given `h : p ∧ q ∧ r`, `have ⟨h₁, h₂, h₃⟩ := h` produces the
  hypotheses `h₁ : p`, `h₂ : q`, and `h₃ : r`.
-/
macro "have " d:haveDecl : tactic => `(tactic| refine_lift have $d:haveDecl; ?_)

/--
Given a main goal `ctx ⊢ t`, `suffices h : t' from e` replaces the main goal with `ctx ⊢ t'`,
`e` must have type `t` in the context `ctx, h : t'`.

The variant `suffices h : t' by tac` is a shorthand for `suffices h : t' from by tac`.
If `h :` is omitted, the name `this` is used.
 -/
macro "suffices " d:sufficesDecl : tactic => `(tactic| refine_lift suffices $d; ?_)
/--
`let h : t := e` adds the hypothesis `h : t := e` to the current goal if `e` a term of type `t`.
If `t` is omitted, it will be inferred.
The variant `let pattern := e` is equivalent to `match e with | pattern => _`,
and it is convenient for types that have only applicable constructor.
Example: given `h : p ∧ q ∧ r`, `let ⟨h₁, h₂, h₃⟩ := h` produces the hypotheses
`h₁ : p`, `h₂ : q`, and `h₃ : r`.
-/
macro "let " d:letDecl : tactic => `(tactic| refine_lift let $d:letDecl; ?_)
/--
`show t` finds the first goal whose target unifies with `t`. It makes that the main goal,
 performs the unification, and replaces the target with the unified version of `t`.
-/
macro "show " e:term : tactic => `(tactic| refine_lift show $e from ?_) -- TODO: fix, see comment
/-- `let rec f : t := e` adds a recursive definition `f` to the current goal.
The syntax is the same as term-mode `let rec`. -/
syntax (name := letrec) withPosition(atomic("let " &"rec ") letRecDecls) : tactic
macro_rules
  | `(tactic| let rec $d) => `(tactic| refine_lift let rec $d; ?_)

/-- Similar to `refine_lift`, but using `refine'` -/
macro "refine_lift' " e:term : tactic => `(tactic| focus (refine' no_implicit_lambda% $e; rotate_right))
/-- Similar to `have`, but using `refine'` -/
macro "have' " d:haveDecl : tactic => `(tactic| refine_lift' have $d:haveDecl; ?_)
/-- Similar to `have`, but using `refine'` -/
macro (priority := high) "have'" x:ident " := " p:term : tactic => `(tactic| have' $x : _ := $p)
/-- Similar to `let`, but using `refine'` -/
macro "let' " d:letDecl : tactic => `(tactic| refine_lift' let $d:letDecl; ?_)

/--
The left hand side of an induction arm, `| foo a b c` or `| @foo a b c`
where `foo` is a constructor of the inductive type and `a b c` are the arguments
to the contstructor.
-/
syntax inductionAltLHS := "| " (("@"? ident) <|> hole) (ident <|> hole)*
/--
In induction alternative, which can have 1 or more cases on the left
and `_`, `?_`, or a tactic sequence after the `=>`.
-/
syntax inductionAlt  := ppDedent(ppLine) inductionAltLHS+ " => " (hole <|> syntheticHole <|> tacticSeq)
/--
After `with`, there is an optional tactic that runs on all branches, and
then a list of alternatives.
-/
syntax inductionAlts := "with " (tactic)? withPosition((colGe inductionAlt)+)

/--
Assuming `x` is a variable in the local context with an inductive type,
`induction x` applies induction on `x` to the main goal,
producing one goal for each constructor of the inductive type,
in which the target is replaced by a general instance of that constructor
and an inductive hypothesis is added for each recursive argument to the constructor.
If the type of an element in the local context depends on `x`,
that element is reverted and reintroduced afterward,
so that the inductive hypothesis incorporates that hypothesis as well.

For example, given `n : Nat` and a goal with a hypothesis `h : P n` and target `Q n`,
`induction n` produces one goal with hypothesis `h : P 0` and target `Q 0`,
and one goal with hypotheses `h : P (Nat.succ a)` and `ih₁ : P a → Q a` and target `Q (Nat.succ a)`.
Here the names `a` and `ih₁` are chosen automatically and are not accessible.
You can use `with` to provide the variables names for each constructor.
- `induction e`, where `e` is an expression instead of a variable,
  generalizes `e` in the goal, and then performs induction on the resulting variable.
- `induction e using r` allows the user to specify the principle of induction that should be used.
  Here `r` should be a theorem whose result type must be of the form `C t`,
  where `C` is a bound variable and `t` is a (possibly empty) sequence of bound variables
- `induction e generalizing z₁ ... zₙ`, where `z₁ ... zₙ` are variables in the local context,
  generalizes over `z₁ ... zₙ` before applying the induction but then introduces them in each goal.
  In other words, the net effect is that each inductive hypothesis is generalized.
- Given `x : Nat`, `induction x with | zero => tac₁ | succ x' ih => tac₂`
  uses tactic `tac₁` for the `zero` case, and `tac₂` for the `succ` case.
-/
syntax (name := induction) "induction " term,+ (" using " ident)?
  ("generalizing " (colGt term:max)+)? (inductionAlts)? : tactic

/-- A `generalize` argument, of the form `term = x` or `h : term = x`. -/
syntax generalizeArg := atomic(ident " : ")? term:51 " = " ident

/--
* `generalize ([h :] e = x),+` replaces all occurrences `e`s in the main goal
  with a fresh hypothesis `x`s. If `h` is given, `h : e = x` is introduced as well.
* `generalize e = x at h₁ ... hₙ` also generalizes occurrences of `e`
  inside `h₁`, ..., `hₙ`.
* `generalize e = x at *` will generalize occurrences of `e` everywhere.
-/
syntax (name := generalize) "generalize " generalizeArg,+ (location)? : tactic

/--
A `cases` argument, of the form `e` or `h : e` (where `h` asserts that
`e = cᵢ a b` for each constructor `cᵢ` of the inductive).
-/
syntax casesTarget := atomic(ident " : ")? term
/--
Assuming `x` is a variable in the local context with an inductive type,
`cases x` splits the main goal, producing one goal for each constructor of the
inductive type, in which the target is replaced by a general instance of that constructor.
If the type of an element in the local context depends on `x`,
that element is reverted and reintroduced afterward,
so that the case split affects that hypothesis as well.
`cases` detects unreachable cases and closes them automatically.

For example, given `n : Nat` and a goal with a hypothesis `h : P n` and target `Q n`,
`cases n` produces one goal with hypothesis `h : P 0` and target `Q 0`,
and one goal with hypothesis `h : P (Nat.succ a)` and target `Q (Nat.succ a)`.
Here the name `a` is chosen automatically and is not accessible.
You can use `with` to provide the variables names for each constructor.
- `cases e`, where `e` is an expression instead of a variable, generalizes `e` in the goal,
  and then cases on the resulting variable.
- Given `as : List α`, `cases as with | nil => tac₁ | cons a as' => tac₂`,
  uses tactic `tac₁` for the `nil` case, and `tac₂` for the `cons` case,
  and `a` and `as'` are used as names for the new variables introduced.
- `cases h : e`, where `e` is a variable or an expression,
  performs cases on `e` as above, but also adds a hypothesis `h : e = ...` to each hypothesis,
  where `...` is the constructor instance for that particular case.
-/
syntax (name := cases) "cases " casesTarget,+ (" using " ident)? (inductionAlts)? : tactic

/-- `rename_i x_1 ... x_n` renames the last `n` inaccessible names using the given names. -/
syntax (name := renameI) "rename_i " (colGt binderIdent)+ : tactic

/--
`repeat tac` applies `tac` to main goal. If the application succeeds,
the tactic is applied recursively to the generated subgoals until it eventually fails.
-/
syntax "repeat " tacticSeq : tactic
macro_rules
  | `(tactic| repeat $seq) => `(tactic| first | ($seq); repeat $seq | skip)

/--
`trivial` tries different simple tactics (e.g., `rfl`, `contradiction`, ...)
to close the current goal.
You can use the command `macro_rules` to extend the set of tactics used. Example:
```
macro_rules | `(tactic| trivial) => `(tactic| simp)
```
-/
syntax "trivial" : tactic

/--
The `split` tactic is useful for breaking nested if-then-else and `match` expressions into separate cases.
For a `match` expression with `n` cases, the `split` tactic generates at most `n` subgoals.

For example, given `n : Nat`, and a target `if n = 0 then Q else R`, `split` will generate
one goal with hypothesis `n = 0` and target `Q`, and a second goal with hypothesis
`¬n = 0` and target `R`.  Note that the introduced hypothesis is unnamed, and is commonly
renamed used the `case` or `next` tactics.

- `split` will split the goal (target).
- `split at h` will split the hypothesis `h`.
-/
syntax (name := split) "split " (colGt term)? (location)? : tactic

/-- `dbg_trace "foo"` prints `foo` when elaborated.
Useful for debugging tactic control flow:
```
example : False ∨ True := by
  first
  | apply Or.inl; trivial; dbg_trace "left"
  | apply Or.inr; trivial; dbg_trace "right"
```
-/
syntax (name := dbgTrace) "dbg_trace " str : tactic

/--
`stop` is a helper tactic for "discarding" the rest of a proof:
it is defined as `repeat sorry`.
It is useful when working on the middle of a complex proofs,
and less messy than commenting the remainder of the proof.
-/
macro "stop" tacticSeq : tactic => `(tactic| repeat sorry)

/--
The tactic `specialize h a₁ ... aₙ` works on local hypothesis `h`.
The premises of this hypothesis, either universal quantifications or
non-dependent implications, are instantiated by concrete terms coming
from arguments `a₁` ... `aₙ`.
The tactic adds a new hypothesis with the same name `h := h a₁ ... aₙ`
and tries to clear the previous one.
-/
syntax (name := specialize) "specialize " term : tactic

macro_rules | `(tactic| trivial) => `(tactic| assumption)
macro_rules | `(tactic| trivial) => `(tactic| rfl)
macro_rules | `(tactic| trivial) => `(tactic| contradiction)
macro_rules | `(tactic| trivial) => `(tactic| decide)
macro_rules | `(tactic| trivial) => `(tactic| apply True.intro)
macro_rules | `(tactic| trivial) => `(tactic| apply And.intro <;> trivial)

/--
`unhygienic tacs` runs `tacs` with name hygiene disabled.
This means that tactics that would normally create inaccessible names will instead
make regular variables. **Warning**: Tactics may change their variable naming
strategies at any time, so code that depends on autogenerated names is brittle.
Users should try not to use `unhygienic` if possible.
```
example : ∀ x : Nat, x = x := by unhygienic
  intro            -- x would normally be intro'd as inaccessible
  exact Eq.refl x  -- refer to x
```
-/
macro "unhygienic " t:tacticSeq : tactic => `(tactic| set_option tactic.hygienic false in $t)

/-- `fail msg` is a tactic that always fails, and produces an error using the given message. -/
syntax (name := fail) "fail " (str)? : tactic

/--
`checkpoint tac` acts the same as `tac`, but it caches the input and output of `tac`,
and if the file is re-elaborated and the input matches, the tactic is not re-run and
its effects are reapplied to the state. This is useful for improving responsiveness
when working on a long tactic proof, by wrapping expensive tactics with `checkpoint`.

See the `save` tactic, which may be more convenient to use.

(TODO: do this automatically and transparently so that users don't have to use
this combinator explicitly.)
-/
syntax (name := checkpoint) "checkpoint " tacticSeq : tactic

/--
`save` is defined to be the same as `skip`, but the elaborator has
special handling for occurrences of `save` in tactic scripts and will transform
`by tac1; save; tac2` to `by (checkpoint tac1); tac2`, meaning that the effect of `tac1`
will be cached and replayed. This is useful for improving responsiveness
when working on a long tactic proof, by using `save` after expensive tactics.

(TODO: do this automatically and transparently so that users don't have to use
this combinator explicitly.)
-/
macro (name := save) "save" : tactic => `(tactic| skip)

/--
The tactic `sleep ms` sleeps for `ms` milliseconds and does nothing.
It is used for debugging purposes only.
-/
syntax (name := sleep) "sleep" num : tactic

/--
`exists e₁, e₂, ...` is shorthand for `refine ⟨e₁, e₂, ...⟩; try trivial`.
It is useful for existential goals.
-/
macro "exists " es:term,+ : tactic =>
  `(tactic| (refine ⟨$es,*, ?_⟩; try trivial))

/--
Apply congruence (recursively) to goals of the form `⊢ f as = f bs` and `⊢ HEq (f as) (f bs)`.
The optional parameter is the depth of the recursive applications.
This is useful when `congr` is too aggressive in breaking down the goal.
For example, given `⊢ f (g (x + y)) = f (g (y + x))`,
`congr` produces the goals `⊢ x = y` and `⊢ y = x`,
while `congr 2` produces the intended `⊢ x + y = y + x`.
-/
syntax (name := congr) "congr " (num)? : tactic

end Tactic

namespace Attr
/--
Theorems tagged with the `simp` attribute are by the simplifier
(i.e., the `simp` tactic, and its variants) to simplify expressions occurring in your goals.
We call theorems tagged with the `simp` attribute "simp theorems" or "simp lemmas".
Lean maintains a database/index containing all active simp theorems.
Here is an example of a simp theorem.
```lean
@[simp] theorem ne_eq (a b : α) : (a ≠ b) = Not (a = b) := rfl
```
This simp theorem instructs the simplifier to replace instances of the term
`a ≠ b` (e.g. `x + 0 ≠ y`) with `Not (a = b)` (e.g., `Not (x + 0 = y)`).
The simplifier applies simp theorems in one direction only:
if `A = B` is a simp theorem, then `simp` replaces `A`s with `B`s,
but it doesn't replace `B`s with `A`s. Hence a simp theorem should have the
property that its right-hand side is "simpler" than its left-hand side.
In particular, `=` and `↔` should not be viewed as symmetric operators in this situation.
The following would be a terrible simp theorem (if it were even allowed):
```lean
@[simp] lemma mul_right_inv_bad (a : G) : 1 = a * a⁻¹ := ...
```
Replacing 1 with a * a⁻¹ is not a sensible default direction to travel.
Even worse would be a theorem that causes expressions to grow without bound,
causing simp to loop forever.

By default the simplifier applies `simp` theorems to an expression `e`
after its sub-expressions have been simplified.
We say it performs a bottom-up simplification.
You can instruct the simplifier to apply a theorem before its sub-expressions
have been simplified by using the modifier `↓`. Here is an example
```lean
@[simp↓] theorem not_and_eq (p q : Prop) : (¬ (p ∧ q)) = (¬p ∨ ¬q) :=
```

When multiple simp theorems are applicable, the simplifier uses the one with highest priority.
If there are several with the same priority, it is uses the "most recent one". Example:
```lean
@[simp high] theorem cond_true (a b : α) : cond true a b = a := rfl
@[simp low+1] theorem or_true (p : Prop) : (p ∨ True) = True :=
  propext <| Iff.intro (fun _ => trivial) (fun _ => Or.inr trivial)
@[simp 100] theorem ite_self {d : Decidable c} (a : α) : ite c a a = a := by
  cases d <;> rfl
```
-/
syntax (name := simp) "simp" (Tactic.simpPre <|> Tactic.simpPost)? (prio)? : attr
end Attr

end Parser
end Lean

/--
`‹t›` resolves to an (arbitrary) hypothesis of type `t`.
It is useful for referring to hypotheses without accessible names.
`t` may contain holes that are solved by unification with the expected type;
in particular, `‹_›` is a shortcut for `by assumption`.
-/
syntax "‹" withoutPosition(term) "›" : term
macro_rules | `(‹$type›) => `((by assumption : $type))

/--
`get_elem_tactic_trivial` is an extensible tactic automatically called
by the notation `arr[i]` to prove any side conditions that arise when
constructing the term (e.g. the index is in bounds of the array).
The default behavior is to just try `trivial` (which handles the case
where `i < arr.size` is in the context) and `simp_arith`
(for doing linear arithmetic in the index).
-/
syntax "get_elem_tactic_trivial" : tactic

macro_rules | `(tactic| get_elem_tactic_trivial) => `(tactic| trivial)
macro_rules | `(tactic| get_elem_tactic_trivial) => `(tactic| simp (config := { arith := true }); done)

/--
`get_elem_tactic` is the tactic automatically called by the notation `arr[i]`
to prove any side conditions that arise when constructing the term
(e.g. the index is in bounds of the array). It just delegates to
`get_elem_tactic_trivial` and gives a diagnostic error message otherwise;
users are encouraged to extend `get_elem_tactic_trivial` instead of this tactic.
-/
macro "get_elem_tactic" : tactic =>
  `(tactic| first
    | get_elem_tactic_trivial
    | fail "failed to prove index is valid, possible solutions:
  - Use `have`-expressions to prove the index is valid
  - Use `a[i]!` notation instead, runtime check is perfomed, and 'Panic' error message is produced if index is not valid
  - Use `a[i]?` notation instead, result is an `Option` type
  - Use `a[i]'h` notation instead, where `h` is a proof that index is valid"
   )

@[inherit_doc getElem]
syntax:max term noWs "[" withoutPosition(term) "]" : term
macro_rules | `($x[$i]) => `(getElem $x $i (by get_elem_tactic))

@[inherit_doc getElem]
syntax term noWs "[" withoutPosition(term) "]'" term:max : term
macro_rules | `($x[$i]'$h) => `(getElem $x $i $h)


import Mathlib.Tactic.Recover

/-- problematic tactic for testing recovery -/
elab "this" "is" "a" "problem" : tactic =>
  Lean.Elab.Tactic.setGoals []

/- The main test-/
example : 1 = 1 := by
  recover this is a problem
  rfl

/- Tests that recover does no harm -/
example : 3 < 4 := by
    recover decide

example : 1 = 1 := by
    recover skip ; rfl

example : 2 = 2 := by
    recover skip
    rfl