import data.list
import data.rbmap
import tactic.linarith

import .ast
import .sized

lemma rbmap_insert_lookup_eq {α:Type} {β:Type} {lt:α → α → Prop} [Hdec:decidable_rel lt]
  (m:rbmap α β lt)
  (k:α) (x:β)
  : forall a, cmp_using lt a k = ordering.eq → rbmap.find (rbmap.insert m k x) a = some x
:= sorry

lemma rbmap_insert_lookup_neq {α:Type} {β:Type} {lt:α → α → Prop} [Hdec:decidable_rel lt]
  (m:rbmap α β lt)
  (k:α) (x:β)
  : forall a, cmp_using lt a k ≠ ordering.eq → rbmap.find (rbmap.insert m k x) a = rbmap.find m a
:= sorry

namespace llvm.

meta def llvm_type_tac :=
  `[unfold has_well_founded.r measure inv_image sizeof has_sizeof.sizeof
      llvm_type.sizeof
      at *,
    try { linarith }
   ].

@[simp]
def mentions : llvm_type → list ident
| (llvm_type.prim_type _) := []
| (llvm_type.alias i) := [i]
| (llvm_type.array _n tp) := mentions tp
| (llvm_type.fun_ty ret args _va) := mentions ret ++ (list.join (sized.map_over args (λ x H, mentions x)))
| (llvm_type.ptr_to _) := [] -- NB pointer types are explicitly excluded
| (llvm_type.struct fs) := list.join (sized.map_over fs (λ x H, mentions x))
| (llvm_type.packed_struct fs) := list.join (sized.map_over fs (λ x H, mentions x))
| (llvm_type.vector _n tp) := mentions tp
| (llvm_type.opaque) := []

using_well_founded ⟨λ _ _, `[exact ⟨measure sizeof, measure_wf _⟩] , llvm_type_tac⟩
.

@[reducible,simp]
def alias_rel (am:strmap llvm_type) (x y:ident) : Prop :=
  ∃tp, am.find y.ident = some tp /\ x ∈ mentions tp.

instance ident_eq_dec : decidable_rel (@eq ident) :=
begin
  unfold decidable_rel, intros a b, cases a, cases b, simp, apply_instance
end

@[reducible]
def alias_map := { am:strmap llvm_type // (forall a, acc (alias_rel am) a) }.

namespace alias_map.

def all_mem_dec {α:Type} (p:α → Prop) (l:list α) :
  (∀x, x ∈ l → decidable (p x)) →
  decidable (∀x, x ∈ l → p x) :=
begin
  induction l,
  case list.nil {
    intros, unfold has_mem.mem list.mem,
    right; intros, trivial,
  },
  case list.cons {
    intros, unfold has_mem.mem list.mem, intros,
    cases (a l_hd (or.inl rfl)),
    { left, intro, apply h, apply a_1, simp, },
    { have Hsub : (Π (x : α), x ∈ l_tl → decidable (p x)),
      { intros; apply a, apply or.inr, assumption },
      cases (l_ih Hsub),
      { left, intro, apply h_1, intros, apply a_1, apply or.inr, assumption },
      { right, intros, cases a_1,
        { subst x; assumption },
        { apply h_1; assumption }
      }
    }
  }
end

def ex_mem_dec {α:Type} (p:α → Prop) (l:list α) :
  (∀x, x ∈ l → decidable (p x)) →
  decidable (∃x, x ∈ l ∧ p x) :=
begin
  induction l,
  case list.nil {
    intros, unfold has_mem.mem list.mem,
    left, intro H, cases H, cases H_h, trivial
  },
  case list.cons {
    intros, unfold has_mem.mem list.mem, intros,
    cases (a l_hd (or.inl rfl)),
    { have Hsub : (Π (x : α), x ∈ l_tl → decidable (p x)),
      { intros; apply a, apply or.inr, assumption },
      cases (l_ih Hsub),
      { left, intro H, cases H, cases H_h, cases H_h_left,
        { apply h; cc },
        { apply h_1, existsi H_w, cc }
      },
      { right, cases h_1, existsi h_1_w, cases h_1_h, split,
        apply or.inr, assumption, assumption,
      }
    },
    { right, existsi l_hd, split; try {assumption}, left, refl,
    }
  }
end.

def reachable_dec
  (am:strmap llvm_type)
  : forall x y (Hacc : acc (alias_rel am) y), decidable (tc (alias_rel am) x y) :=
begin
  intros x y Hacc, apply Hacc.rec_on, clear Hacc y, intros y _ IH,
  destruct (am.find y.ident),
  { intros Hy, left, intro Htc, revert Hy, clear IH,
    induction Htc,
    { intros, cases Htc_a_1, cc, },
    { intros, cc }
  },
  intros tp Htp,
  have H : decidable (∃i, i ∈ mentions tp ∧ (i = x ∨ tc (alias_rel am) x i)),
  { apply ex_mem_dec, intros i Hi,
    cases (llvm.ident_eq_dec i x),
    { have Hi : alias_rel am i y, { existsi tp, split; assumption },
      cases (IH i Hi),
      { left, intro H, cases H; cc },
      { right, right, assumption }
    },
    { right, left, assumption },
  },

  cases H,
  { left, intro, clear h IH, apply H, clear H,
    induction a; intros,
    unfold alias_rel at a_a_1, cases a_a_1 with tp' Ha, cases Ha with Ha1 Ha2,
    have Heq : tp = tp', { cc }, subst tp',
    existsi a_a, split, apply Ha2, simp,
    cases (a_ih_a_1 Htp),
    cases h, cases h_right, subst a_b,
    existsi w, split, assumption, right, assumption,
    existsi w, split, assumption, right, apply tc.trans _ a_b _; assumption,
  },
  { right, cases H with i H, cases H with H1 H2, cases H2 with H2 H2,
    subst i, apply tc.base, existsi tp, split; assumption,
    apply tc.trans _ i _, assumption, apply tc.base, existsi tp, split; assumption
  }
end.

lemma string_cmp_using_eq
  (x y : string) :
  cmp_using string.has_lt'.lt x y = ordering.eq → x = y :=
begin
  unfold cmp_using ite,
  cases (string.decidable_lt y x); simp,
  cases (string.decidable_lt x y); simp,
  apply le_antisymm; assumption,
  cases (string.decidable_lt x y); simp,
end.

lemma insert_alias_map_wf_aux
  (am:strmap llvm_type)
  (x z:ident) (tp:llvm_type)
  (Hacc: acc (alias_rel am) z)
  : forall
  (Hxy : z ≠ x)
  (Hntc: ¬(tc (alias_rel am) x z)),
  acc (alias_rel (rbmap.insert am x.ident tp)) z :=
begin
  apply Hacc.rec_on, clear Hacc z, intros z h IH Hx Htc,
  apply acc.intro, intros q Hq,
  cases Hq with tp Htp, cases Htp with Htp1 Htp2,
  rewrite (rbmap_insert_lookup_neq am) at Htp1,
  { apply IH,
    { existsi tp, cc },
    { intro Hqx, apply Htc, apply tc.base,
      subst q, existsi tp, cc
    },
    { intro Hxq, apply Htc,
      apply tc.trans _ q _, assumption,
      apply tc.base, existsi tp, cc,
    }
  },
  { intro, apply Hx, cases z, cases x,
    unfold ident.ident at a,
    have Hzx : z = x, { apply string_cmp_using_eq, assumption },
    cc
  }
end

lemma insert_alias_map_wf
  (am:strmap llvm_type)
  (x:ident) (tp:llvm_type)
  (Hacc: forall a, acc (alias_rel am) a)
  (Hnacc : ¬∃y, y ∈ mentions tp ∧ (y = x ∨ tc (alias_rel am) x y))
  : forall a, acc (alias_rel (rbmap.insert am x.ident tp)) a :=
begin
  intro a, apply (Hacc a).rec_on, clear a, intros a h IH, clear h,
  apply acc.intro, intros q Hq,
  cases Hq with tp' Htp, cases Htp with Htp1 Htp2,
  apply (@decidable.by_cases (cmp_using string.has_lt'.lt a.ident x.ident = ordering.eq)); intro Heq,
  { rewrite (rbmap_insert_lookup_eq am x.ident tp) at Htp1; try {assumption},
    injection Htp1, subst tp', clear Htp1,
    apply (insert_alias_map_wf_aux am x q tp (Hacc q)),
    { intro; subst q, apply Hnacc, existsi x, cc, },
    { intro, apply Hnacc, existsi q, cc, }
  },
  { rewrite (rbmap_insert_lookup_neq am x.ident tp) at Htp1; try {assumption},
    apply (IH q), existsi tp', split; assumption
  }
end.

def empty : alias_map := subtype.mk (strmap_empty _)
  begin
    intro a, apply acc.intro, intros b H,
    destruct H, simp, unfold strmap_empty,
    unfold rbmap.find rbmap.find_entry rbmap.from_list,
    unfold mk_rbmap mk_rbtree,
    simp, unfold rbmap.find_entry._match_1 rbmap.to_value,
    intros, cc,
  end
.

def insert_check_dec (am:alias_map) (x:ident) (tp:llvm_type) :
  decidable (∃y, y ∈ mentions tp ∧ (y = x ∨ tc (alias_rel am.val) x y)) :=
begin
  apply ex_mem_dec, intros q Hq,
  cases (llvm.ident_eq_dec q x),
  { cases (reachable_dec am.val x q (am.property q)),
    { left, intro H; cases H; cc },
    { right, right, assumption }
  },
  { right, left, assumption }
end.

def insert (am:alias_map) (k:ident) (tp:llvm_type) : option alias_map :=
  match insert_check_dec am k tp with
  | decidable.is_true _ := none
  | decidable.is_false H :=
      some ⟨rbmap.insert am.val k.ident tp, insert_alias_map_wf am.val k tp am.property H⟩
  end

def build : list type_decl → alias_map → sum type_decl alias_map
| []        am := sum.inr am
| (td::tds) am :=
    match insert am td.name td.value with
    | none        := sum.inl td
    | some am'    := build tds am'
    end.

end alias_map.

end llvm.


import Lean
import Mathlib.Tactic.RCases
import Mathlib.Init.ExtendedBinder

import Verbose.Common

inductive intro_rel where
| lt | gt | le | ge | mem
deriving Repr

open Lean

inductive introduced where
| typed (syn : Syntax) (n : Name) (e : Syntax) : introduced
| bare (syn : Syntax) (n : Name) : introduced
| related (syn : Syntax) (n : Name) (rel : intro_rel) (e : Syntax) : introduced
deriving Repr

open Lean Meta
open Lean Elab Tactic

/- Like Lean.Meta.intro except it introduces only data and fails on Prop.
It takes the current goal id as `mvarId` and a name for the newly introduced object
and returns a `FVarId` referring the newly introduced object and a `MVarId` for the new
goal.
 -/
def introObj (mvarId : MVarId) (name : Name) : MetaM (FVarId × MVarId) := do
  let tgt ← whnf (← getMVarType mvarId)
  if tgt.isForall ∨ tgt.isLet then
    let (fvar, newmvarId) ← intro mvarId name
    withMVarContext newmvarId do
      let t := (← getLocalDecl fvar).type
      if (← inferType t).isProp then
        throwError "There is no object to introduce here."
      else
        pure (fvar, newmvarId)
  else
    throwError "There is no object to introduce here."

def Fix1 : introduced → TacticM Unit
| introduced.typed syn n t   =>  do
  withRef syn do
    checkName n
    -- Introduce n, getting the corresponding FVarId and the new goal MVarId with its context
    let (n_fvar, new_goal) ← introObj (← getMainGoal) n
    -- Change the default MVarContext to the newly created one for the benefit of `elabTerm`
    withMVarContext new_goal do
      replaceMainGoal [← changeLocalDecl new_goal n_fvar (← elabTerm t none)]
| introduced.bare syn n      => do
  withRef syn do
    checkName n
    -- Introduce n, forget the corresponding FVarId and get the new goal MVarId with its context
    let (_, new_goal) ← introObj (← getMainGoal) n
    replaceMainGoal [new_goal]
| introduced.related syn n rel e => do
  withRef syn do
    checkName n
    let (n_fvar, new_goal) ← introObj (← getMainGoal) n
    withMVarContext new_goal do
      let n_decl ← getLocalDeclFromUserName n
      let n_type := n_decl.type
      -- Let's build the RHS e as an expr. In the membership case we don't have extra information
      -- in other case we elaborate knowing we should get the same type as n
      let (E : Expr) ← match rel with
              | intro_rel.mem => elabTerm e none
              | _ => elabTerm e n_type
      -- Now create a name for the relation assumption that will be created
      let (hyp_name : String) := if e matches `(0) then
                        match rel with
                        | intro_rel.lt  => n.toString ++ "_neg"
                        | intro_rel.gt  => n.toString ++ "_pos"
                        | intro_rel.le  => n.toString ++ "_neg"
                        | intro_rel.ge  => n.toString ++ "_pos"
                        | intro_rel.mem => "h_" ++ n.toString -- shouldn't happen

                      else
                        match rel with
                        | intro_rel.lt  => n.toString ++ "_lt"
                        | intro_rel.gt  => n.toString ++ "_gt"
                        | intro_rel.le  => n.toString ++ "_le"
                        | intro_rel.ge  => n.toString ++ "_ge"
                        | intro_rel.mem => n.toString ++ "_mem"

      let n_expr : Expr := mkFVar n_fvar
      let (rel_expr : Expr) ← match rel with
                    | intro_rel.lt => mkAppM ``LT.lt #[n_expr, E]
                    | intro_rel.gt => mkAppM ``GT.gt #[n_expr, E]
                    | intro_rel.le => mkAppM ``LE.le #[n_expr, E]
                    | intro_rel.ge => mkAppM ``GE.ge #[n_expr, E]
                    | intro_rel.mem => mkAppM ``Membership.mem #[n_expr, E]

      let (hyp_fvar, newer_goal) ← intro new_goal hyp_name
      withMVarContext newer_goal do
        let new_mvarid ← changeLocalDecl newer_goal hyp_fvar rel_expr
        replaceMainGoal [new_mvarid]

section
open Lean Elab

declare_syntax_cat fixDecl
syntax ident : fixDecl
syntax ident ":" term : fixDecl
syntax ident "<" term : fixDecl
syntax ident ">" term : fixDecl
syntax ident ("<=" <|> "≤") term : fixDecl
syntax ident (">=" <|> "≥") term : fixDecl
syntax ident "∈" term : fixDecl
syntax "(" fixDecl ")" : fixDecl

syntax "Fix₁ " colGt fixDecl : tactic
syntax "Fix " (colGt fixDecl)+ : tactic

elab_rules : tactic
  | `(tactic| Fix₁ $x:ident) => Fix1 (introduced.bare x x.getId)

elab_rules : tactic
  | `(tactic| Fix₁ $x:ident : $type) =>
    Fix1 (introduced.typed (mkNullNode #[x, type]) x.getId type)

elab_rules : tactic
  | `(tactic| Fix₁ $x:ident < $bound) =>
    Fix1 (introduced.related (mkNullNode #[x, bound]) x.getId intro_rel.lt bound)

elab_rules : tactic
  | `(tactic| Fix₁ $x:ident > $bound) =>
    Fix1 (introduced.related (mkNullNode #[x, bound]) x.getId intro_rel.gt bound)

elab_rules : tactic
  | `(tactic| Fix₁ $x:ident ≤ $bound) =>
    Fix1 (introduced.related (mkNullNode #[x, bound]) x.getId intro_rel.le bound)

elab_rules : tactic
  | `(tactic| Fix₁ $x:ident ≥ $bound) =>
    Fix1 (introduced.related (mkNullNode #[x, bound]) x.getId intro_rel.ge bound)

elab_rules : tactic
  | `(tactic| Fix₁ $x:ident ∈ $set) =>
    Fix1 (introduced.related (mkNullNode #[x, set]) x.getId intro_rel.mem set)

elab_rules : tactic
  | `(tactic| Fix₁ ( $decl:fixDecl )) => do evalTactic (← `(tactic| Fix₁ $decl:fixDecl))

macro_rules
  | `(tactic| Fix $decl:fixDecl) => `(tactic| Fix₁ $decl)

macro_rules
  | `(tactic| Fix $decl:fixDecl $decls:fixDecl*) => `(tactic| Fix₁ $decl; Fix $decls:fixDecl*)

macro_rules
| `(ℕ) => `(Nat)

-- requires the extended binder import
#check ∀ n ≥ 2, true

#check ∃ n ≥ 2, true

example : ∀ b : ℕ, ∀ a : Nat, a ≥ 2 → a = a ∧ b = b := by
  Fix b (a ≥ 2)
  trivial

end


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import init.meta.smt.smt_tactic init.meta.interactive_base
import init.meta.smt.rsimp

namespace smt_tactic
meta def save_info (p : pos) : smt_tactic unit :=
do (ss, ts) ← smt_tactic.read,
   tactic.save_info_thunk p (λ _, smt_state.to_format ss ts)

meta def skip : smt_tactic unit :=
return ()

meta def solve_goals : smt_tactic unit :=
iterate close

meta def step {α : Type} (tac : smt_tactic α) : smt_tactic unit :=
tac >> solve_goals

meta def istep {α : Type} (line0 col0 line col ast : nat) (tac : smt_tactic α) : smt_tactic unit :=
⟨λ ss ts, (@scope_trace _ line col (λ _,
  tactic.with_ast ast ((tac >> solve_goals).run ss) ts)).clamp_pos line0 line col⟩

meta def execute (tac : smt_tactic unit) : tactic unit :=
using_smt tac

meta def execute_with (cfg : smt_config) (tac : smt_tactic unit) : tactic unit :=
using_smt tac cfg

meta instance : interactive.executor smt_tactic :=
{ config_type := smt_config,
  inhabited := ⟨{}⟩,
  execute_with := λ cfg tac, using_smt tac cfg, }

namespace interactive
open lean.parser
open _root_.interactive
open interactive.types
local postfix `?`:9001 := optional
local postfix *:9001 := many

meta def itactic : Type :=
smt_tactic unit

meta def intros : parse ident* → smt_tactic unit
| [] := smt_tactic.intros
| hs := smt_tactic.intro_lst hs

/--
  Try to close main goal by using equalities implied by the congruence
  closure module.
-/
meta def close : smt_tactic unit :=
smt_tactic.close

/--
  Produce new facts using heuristic lemma instantiation based on E-matching.
  This tactic tries to match patterns from lemmas in the main goal with terms
  in the main goal. The set of lemmas is populated with theorems
  tagged with the attribute specified at smt_config.em_attr, and lemmas
  added using tactics such as `smt_tactic.add_lemmas`.
  The current set of lemmas can be retrieved using the tactic `smt_tactic.get_lemmas`.
-/
meta def ematch : smt_tactic unit :=
smt_tactic.ematch

meta def apply (q : parse texpr) : smt_tactic unit :=
tactic.interactive.apply q

meta def fapply (q : parse texpr) : smt_tactic unit :=
tactic.interactive.fapply q

meta def apply_instance : smt_tactic unit :=
tactic.apply_instance

meta def change (q : parse texpr) : smt_tactic unit :=
tactic.interactive.change q none (loc.ns [none])

meta def exact (q : parse texpr) : smt_tactic unit :=
tactic.interactive.exact q

meta def «from» := exact

meta def «assume» := tactic.interactive.assume

meta def «have» (h : parse ident?) (q₁ : parse (tk ":" *> texpr)?) (q₂ : parse $ (tk ":=" *> texpr)?) : smt_tactic unit :=
let h := h.get_or_else `this in
match q₁, q₂ with
| some e, some p := do
  t ← tactic.to_expr e,
  v ← tactic.to_expr ``(%%p : %%t),
  smt_tactic.assertv h t v
| none, some p := do
  p ← tactic.to_expr p,
  smt_tactic.note h none p
| some e, none := tactic.to_expr e >>= smt_tactic.assert h
| none, none := do
  u ← tactic.mk_meta_univ,
  e ← tactic.mk_meta_var (expr.sort u),
  smt_tactic.assert h e
end >> return ()

meta def «let» (h : parse ident?) (q₁ : parse (tk ":" *> texpr)?) (q₂ : parse $ (tk ":=" *> texpr)?) : smt_tactic unit :=
let h := h.get_or_else `this in
match q₁, q₂ with
| some e, some p := do
  t ← tactic.to_expr e,
  v ← tactic.to_expr ``(%%p : %%t),
  smt_tactic.definev h t v
| none, some p := do
  p ← tactic.to_expr p,
  smt_tactic.pose h none p
| some e, none := tactic.to_expr e >>= smt_tactic.define h
| none, none := do
  u ← tactic.mk_meta_univ,
  e ← tactic.mk_meta_var (expr.sort u),
  smt_tactic.define h e
end >> return ()

meta def add_fact (q : parse texpr) : smt_tactic unit :=
do h ← tactic.get_unused_name `h none,
   p ← tactic.to_expr_strict q,
   smt_tactic.note h none p

meta def trace_state : smt_tactic unit :=
smt_tactic.trace_state

meta def trace {α : Type} [has_to_tactic_format α] (a : α) : smt_tactic unit :=
tactic.trace a

meta def destruct (q : parse texpr) : smt_tactic unit :=
do p ← tactic.to_expr_strict q,
   smt_tactic.destruct p

meta def by_cases (q : parse texpr) : smt_tactic unit :=
do p ← tactic.to_expr_strict q,
   smt_tactic.by_cases p

meta def by_contradiction : smt_tactic unit :=
smt_tactic.by_contradiction

meta def by_contra : smt_tactic unit :=
smt_tactic.by_contradiction

open tactic (resolve_name transparency to_expr)

private meta def report_invalid_em_lemma {α : Type} (n : name) : smt_tactic α :=
fail format!"invalid ematch lemma '{n}'"

private meta def add_lemma_name (md : transparency) (lhs_lemma : bool) (n : name) (ref : pexpr) : smt_tactic unit :=
do
  p ← resolve_name n,
  match p with
  | expr.const n _           := (add_ematch_lemma_from_decl_core md lhs_lemma n >> tactic.save_const_type_info n ref) <|> report_invalid_em_lemma n
  | _                        := (do e ← to_expr p, add_ematch_lemma_core md lhs_lemma e >> try (tactic.save_type_info e ref)) <|> report_invalid_em_lemma n
  end

private meta def add_lemma_pexpr (md : transparency) (lhs_lemma : bool) (p : pexpr) : smt_tactic unit :=
match p with
| (expr.const c [])          := add_lemma_name md lhs_lemma c p
| (expr.local_const c _ _ _) := add_lemma_name md lhs_lemma c p
| _                          := do new_e ← to_expr p, add_ematch_lemma_core md lhs_lemma new_e
end

private meta def add_lemma_pexprs (md : transparency) (lhs_lemma : bool) : list pexpr → smt_tactic unit
| []      := return ()
| (p::ps) := add_lemma_pexpr md lhs_lemma p >> add_lemma_pexprs ps

meta def add_lemma (l : parse pexpr_list_or_texpr) : smt_tactic unit :=
add_lemma_pexprs reducible ff l

meta def add_lhs_lemma (l : parse pexpr_list_or_texpr) : smt_tactic unit :=
add_lemma_pexprs reducible tt l

private meta def add_eqn_lemmas_for_core (md : transparency) : list name → smt_tactic unit
| []      := return ()
| (c::cs) := do
  p ← resolve_name c,
  match p with
  | expr.const n _           := add_ematch_eqn_lemmas_for_core md n >> add_eqn_lemmas_for_core cs
  | _                        := fail format!"'{c}' is not a constant"
  end

meta def add_eqn_lemmas_for (ids : parse ident*) : smt_tactic unit :=
add_eqn_lemmas_for_core reducible ids

meta def add_eqn_lemmas (ids : parse ident*) : smt_tactic unit :=
add_eqn_lemmas_for ids

private meta def add_hinst_lemma_from_name (md : transparency) (lhs_lemma : bool) (n : name) (hs : hinst_lemmas) (ref : pexpr) : smt_tactic hinst_lemmas :=
do
  p ← resolve_name n,
  match p with
  | expr.const n _           :=
    (do h ← hinst_lemma.mk_from_decl_core md n lhs_lemma, tactic.save_const_type_info n ref, return $ hs.add h)
    <|>
    (do hs₁ ← mk_ematch_eqn_lemmas_for_core md n, tactic.save_const_type_info n ref, return $ hs.merge hs₁)
    <|>
    report_invalid_em_lemma n
  | _ :=
    (do e ← to_expr p, h ← hinst_lemma.mk_core md e lhs_lemma, try (tactic.save_type_info e ref), return $ hs.add h)
    <|>
    report_invalid_em_lemma n
  end

private meta def add_hinst_lemma_from_pexpr (md : transparency) (lhs_lemma : bool) (p : pexpr) (hs : hinst_lemmas) : smt_tactic hinst_lemmas :=
match p with
| (expr.const c [])          := add_hinst_lemma_from_name md lhs_lemma c hs p
| (expr.local_const c _ _ _) := add_hinst_lemma_from_name md lhs_lemma c hs p
| _                          := do new_e ← to_expr p, h ← hinst_lemma.mk_core md new_e lhs_lemma, return $ hs.add h
end

private meta def add_hinst_lemmas_from_pexprs (md : transparency) (lhs_lemma : bool) : list pexpr → hinst_lemmas → smt_tactic hinst_lemmas
| []      hs := return hs
| (p::ps) hs := do hs₁ ← add_hinst_lemma_from_pexpr md lhs_lemma p hs, add_hinst_lemmas_from_pexprs ps hs₁

meta def ematch_using (l : parse pexpr_list_or_texpr) : smt_tactic unit :=
do hs ← add_hinst_lemmas_from_pexprs reducible ff l hinst_lemmas.mk,
   smt_tactic.ematch_using hs

/-- Try the given tactic, and do nothing if it fails. -/
meta def try (t : itactic) : smt_tactic unit :=
smt_tactic.try t

/-- Keep applying the given tactic until it fails. -/
meta def iterate (t : itactic) : smt_tactic unit :=
smt_tactic.iterate t

/-- Apply the given tactic to all remaining goals. -/
meta def all_goals (t : itactic) : smt_tactic unit :=
smt_tactic.all_goals t

meta def induction (p : parse tactic.interactive.cases_arg_p) (rec_name : parse using_ident) (ids : parse with_ident_list)
  (revert : parse $ (tk "generalizing" *> ident*)?) : smt_tactic unit :=
slift (tactic.interactive.induction p rec_name ids revert)

open tactic

/-- Simplify the target type of the main goal. -/
meta def simp (use_iota_eqn : parse $ (tk "!")?) (no_dflt : parse only_flag) (hs : parse simp_arg_list)
              (attr_names : parse with_ident_list) (cfg : simp_config_ext := {}) : smt_tactic unit :=
tactic.interactive.simp use_iota_eqn none no_dflt hs attr_names (loc.ns [none]) cfg

meta def dsimp (no_dflt : parse only_flag) (es : parse simp_arg_list) (attr_names : parse with_ident_list) : smt_tactic unit :=
tactic.interactive.dsimp no_dflt es attr_names (loc.ns [none])

meta def rsimp : smt_tactic unit :=
do ccs ← to_cc_state, _root_.rsimp.rsimplify_goal ccs

meta def add_simp_lemmas : smt_tactic unit :=
get_hinst_lemmas_for_attr `rsimp_attr >>= add_lemmas

/-- Keep applying heuristic instantiation until the current goal is solved, or it fails. -/
meta def eblast : smt_tactic unit :=
smt_tactic.eblast

/-- Keep applying heuristic instantiation using the given lemmas until the current goal is solved, or it fails. -/
meta def eblast_using (l : parse pexpr_list_or_texpr) : smt_tactic unit :=
do hs ← add_hinst_lemmas_from_pexprs reducible ff l hinst_lemmas.mk,
   smt_tactic.iterate (smt_tactic.ematch_using hs >> smt_tactic.try smt_tactic.close)

meta def guard_expr_eq (t : expr) (p : parse $ tk ":=" *> texpr) : smt_tactic unit :=
do e ← to_expr p, guard (expr.alpha_eqv t e)

meta def guard_target (p : parse texpr) : smt_tactic unit :=
do t ← target, guard_expr_eq t p

end interactive
end smt_tactic


/-
Copyright (c) 2016 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
prelude
import init.meta.name init.meta.options init.meta.format init.meta.rb_map
import init.meta.level init.meta.expr init.meta.environment init.meta.attribute
import init.meta.tactic init.meta.contradiction_tactic init.meta.constructor_tactic
import init.meta.injection_tactic init.meta.relation_tactics init.meta.fun_info
import init.meta.congr_lemma init.meta.match_tactic init.meta.ac_tactics
import init.meta.backward init.meta.rewrite_tactic
import init.meta.derive init.meta.mk_dec_eq_instance
import init.meta.simp_tactic init.meta.set_get_option_tactics
import init.meta.interactive init.meta.converter init.meta.vm
import init.meta.comp_value_tactics init.meta.smt
import init.meta.async_tactic init.meta.ref
import init.meta.hole_command init.meta.congr_tactic
import init.meta.local_context init.meta.type_context
import init.meta.instance_cache
import init.meta.module_info
import init.meta.expr_address
import init.meta.tagged_format


import control.traversable.derive
import control.traversable.instances

universes u

/- traversable -/
open tactic.interactive

run_cmd do
lawful_traversable_derive_handler' `test ``(is_lawful_traversable) ``list
-- the above creates local instances of `traversable` and `is_lawful_traversable`
-- for `list`
-- do not put in instances because they are not universe polymorphic

@[derive [traversable, is_lawful_traversable]]
structure my_struct (α : Type) :=
  (y : ℤ)

@[derive [traversable, is_lawful_traversable]]
inductive either (α : Type u)
| left : α → ℤ → either
| right : α → either

@[derive [traversable, is_lawful_traversable]]
structure my_struct2 (α : Type u) : Type u :=
  (x : α)
  (y : ℤ)
  (η : list α)
  (k : list (list α))

@[derive [traversable, is_lawful_traversable]]
inductive rec_data3 (α : Type u) : Type u
| nil : rec_data3
| cons : ℕ → α → rec_data3 → rec_data3 → rec_data3

@[derive traversable]
meta structure meta_struct (α : Type u) : Type u :=
  (x : α)
  (y : ℤ)
  (z : list α)
  (k : list (list α))
  (w : expr)

@[derive [traversable,is_lawful_traversable]]
inductive my_tree (α : Type)
| leaf : my_tree
| node : my_tree → my_tree → α → my_tree

section
open my_tree (hiding traverse)

def x : my_tree (list nat) :=
node
  leaf
  (node
    (node leaf leaf [1,2,3])
    leaf
    [3,2])
  [1]

/-- demonstrate the nested use of `traverse`. It traverses each node of the tree and
in each node, traverses each list. For each `ℕ` visited, apply an action `ℕ -> state (list ℕ) unit`
which adds its argument to the state. -/
def ex : state (list ℕ) (my_tree $ list unit) :=
do xs ← traverse (traverse $ λ a, modify $ list.cons a) x,
   pure xs

example : (ex.run []).1 = node leaf (node (node leaf leaf [(), (), ()]) leaf [(), ()]) [()] := rfl
example : (ex.run []).2 = [1, 2, 3, 3, 2, 1] := rfl
example : is_lawful_traversable my_tree := my_tree.is_lawful_traversable

end


import tactic
import category_theory.limits.shapes.pullbacks

namespace category_theory
open category_theory.limits

variables {C D : Type*} [category C] [category D] (e : C ≌ D)
  {X Y B : D} (f : X ⟶ B) (g : Y ⟶ B) [has_pullback (e.inverse.map f) (e.inverse.map g)]

lemma equivalence.hom_eq_map {X Y : C} (f : e.functor.obj X ⟶ e.functor.obj Y)
  (g : X ⟶ Y) : e.inverse.map f = e.symm.counit.app _ ≫ g ≫ e.unit.app _ →
  f = e.functor.map g :=
begin
  intros h,
  change _ = (e.unit_iso.app _).inv ≫ g ≫ (e.unit_iso.app _).hom at h,
  rw iso.eq_inv_comp at h,
  replace h := h.symm,
  rw ← iso.eq_comp_inv at h,
  rw h,
  simp,
  nth_rewrite 0 ← category.id_comp f,
  simp_rw ← category.assoc,
  congr' 1,
  simp,
end

noncomputable theory

/-
I would like to do something for more general shapes, but universes make this difficult
(as usual...)
-/

@[simps]
def equivalence.pullback_cone : cone (cospan f g) :=
{ X := e.functor.obj $ pullback (e.inverse.map f) (e.inverse.map g),
  π :=
  { app := λ i,
    match i with
    | none := e.functor.map pullback.fst ≫ e.counit.app X ≫ f
    | walking_cospan.left := e.functor.map pullback.fst ≫ e.counit.app X
    | walking_cospan.right := e.functor.map pullback.snd ≫ e.counit.app Y
    end,
    naturality' := begin
      rintro (i|i|i) (j|j|j) (h|h),
      { tidy },
      { tidy },
      { tidy },
      { unfold_aux,
        dsimp, simp, delta id_rhs,
        have : e.counit.app X ≫ f = e.functor.map (e.inverse.map f) ≫ e.counit.app B, by tidy,
        rw this, clear this,
        have : e.counit.app Y ≫ g = e.functor.map (e.inverse.map g) ≫ e.counit.app B, by tidy,
        rw this, clear this,
        simp_rw [← category.assoc, ← e.functor.map_comp, limits.pullback.condition] },
      { tidy }
    end } } .

-- This is a mess :-(
-- Please fix before moving this file to mathlib!
def equivalence.is_limit_pullback_cone : limits.is_limit (e.pullback_cone f g) :=
{ lift := λ S, e.symm.unit.app S.X ≫
    e.functor.map (pullback.lift (e.inverse.map (S.π.app walking_cospan.left))
      (e.inverse.map (S.π.app walking_cospan.right)) begin
        simp_rw ← e.inverse.map_comp,
        congr' 1,
        have := cospan_map_inl f g,
        change _ ≫ (cospan f g).map walking_cospan.hom.inl =
          _ ≫ (cospan f g).map walking_cospan.hom.inr,
        simp_rw S.w,
      end),
  fac' := begin
    rintros S (j|j|j),
    { dsimp [equivalence.pullback_cone._match_1], simp,
      have : e.counit.app X ≫ f = e.functor.map (e.inverse.map f) ≫ e.counit.app B, by tidy,
      rw this, clear this,
      simp_rw [← category.assoc _ _ (e.counit.app B), ← e.functor.map_comp],
      simp,
      dsimp,
      simp,
      change _ ≫ (cospan f g).map walking_cospan.hom.inl = _,
      rw S.w },
    { dsimp [equivalence.pullback_cone._match_1], simp,
      simp_rw [← category.assoc _ _ (e.counit.app X), ← e.functor.map_comp],
      simp,
      dsimp,
      simp },
    { dsimp [equivalence.pullback_cone._match_1], simp,
      simp_rw [← category.assoc _ _ (e.counit.app Y), ← e.functor.map_comp],
      simp,
      dsimp,
      simp }
  end,
  uniq' := begin
    intros S m h,
    dsimp at *,
    change m = (e.counit_iso.app S.X).inv ≫ _,
    rw iso.eq_inv_comp,
    apply equivalence.hom_eq_map,
    change _ = (e.unit_iso.app _).inv ≫ _ ≫ (e.unit_iso.app _).hom,
    rw iso.eq_inv_comp,
    symmetry,
    rw ← iso.eq_comp_inv,
    simp,
    apply pullback.hom_ext,
    { simp,
      specialize h walking_cospan.left,
      dsimp [equivalence.pullback_cone._match_1] at h,
      rw ← h,
      simp,
      simp_rw ← category.assoc,
      congr' 2,
      simp },
    { simp,
      specialize h walking_cospan.right,
      dsimp [equivalence.pullback_cone._match_1] at h,
      rw ← h,
      simp,
      simp_rw ← category.assoc,
      congr' 2,
      simp }
  end } .

include e

lemma equivalence.has_pullback {X Y B : D} (f : X ⟶ B) (g : Y ⟶ B)
  [has_pullback (e.inverse.map f) (e.inverse.map g)] : has_pullback f g :=
limits.has_limit.mk ⟨e.pullback_cone _ _, e.is_limit_pullback_cone _ _⟩

lemma equivalence.has_pullbacks [has_pullbacks C] : has_pullbacks D :=
begin
  apply has_pullbacks_of_has_limit_cospan _,
  intros X Y B f g,
  apply e.has_pullback,
end

end category_theory


/-
Copyright (c) 2022 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner
-/
import Lean.Elab.ElabRules
open Lean Elab Parser Term Meta Macro

/-!
Defines variants of `have` and `let` syntax which do not produce `let_fun` or `let` bindings,
but instead inline the value instead.

This is useful to declare local instances and proofs in theorem statements
and subgoals, where the extra binding is inconvenient.
-/

namespace Std.Tactic

/-- `haveI` behaves like `have`, but inlines the value instead of producing a `let_fun` term. -/
@[term_parser] def «haveI» := leading_parser withPosition ("haveI " >> haveDecl) >> optSemicolon termParser
/-- `letI` behaves like `let`, but inlines the value instead of producing a `let_fun` term. -/
@[term_parser] def «letI» := leading_parser withPosition ("letI " >> haveDecl) >> optSemicolon termParser

macro_rules
  | `(haveI $_ : $_ := $_; $_) => throwUnsupported -- handled by elab
  | `(haveI $[: $ty]? := $val; $body) => `(haveI $(mkIdent `this) $[: $ty]? := $val; $body)
  | `(haveI $x := $val; $body) => `(haveI $x : _ := $val; $body)
  | `(haveI $decl:haveDecl; $body) => `(haveI x := have $decl:haveDecl; x; $body)

macro_rules
  | `(letI $_ : $_ := $_; $_) => throwUnsupported -- handled by elab
  | `(letI $[: $ty]? := $val; $body) => `(letI $(mkIdent `this) $[: $ty]? := $val; $body)
  | `(letI $x := $val; $body) => `(letI $x : _ := $val; $body)
  | `(letI $decl:haveDecl; $body) => `(letI x := have $decl:haveDecl; x; $body)

elab_rules <= expectedType
  | `(haveI $x : $ty := $val; $body) => do
    let ty ← elabType ty
    let val ← elabTermEnsuringType val ty
    withLocalDeclD x.getId ty fun x => do
      return (← (← elabTerm body expectedType).abstractM #[x]).instantiate #[val]

elab_rules <= expectedType
  | `(letI $x : $ty := $val; $body) => do
    let ty ← elabType ty
    let val ← elabTermEnsuringType val ty
    withLetDecl x.getId ty val fun x => do
      return (← (← elabTerm body expectedType).abstractM #[x]).instantiate #[val]

/-- `haveI` behaves like `have`, but inlines the value instead of producing a `let_fun` term. -/
macro "haveI " d:haveDecl : tactic => `(tactic| refine_lift haveI $d:haveDecl; ?_)
/-- `letI` behaves like `let`, but inlines the value instead of producing a `let_fun` term. -/
macro "letI " d:haveDecl : tactic => `(tactic| refine_lift letI $d:haveDecl; ?_)


import .cofibration_category
import .cylinder
import .lifting

universes v u

open category_theory
open category_theory.category
local notation f ` ∘ `:80 g:80 := g ≫ f

namespace homotopy_theory.cofibrations
open precofibration_category cofibration_category

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

-- Homotopies in a cofibration category.

variables {a b : C} {j : a ⟶ b} {hj : is_cof j}

structure homotopy_on (c : relative_cylinder hj) {x : C} (f₀ f₁ : b ⟶ x) :=
(H : c.ob ⟶ x)
(Hi₀ : H ∘ c.i₀ = f₀)
(Hi₁ : H ∘ c.i₁ = f₁)

@[ext] lemma homotopy_on.ext (c : relative_cylinder hj) {x : C} (f₀ f₁ : b ⟶ x)
  (H H' : homotopy_on c f₀ f₁) (e : H.H = H'.H) : H = H' :=
by cases H; cases H'; simpa

def homotopy_on.refl {c : relative_cylinder hj} {x : C} (f : b ⟶ x) :
  homotopy_on c f f :=
⟨f ∘ c.p, by rw [←assoc, c.pi₀]; simp, by rw [←assoc, c.pi₁]; simp⟩

def homotopy_on.symm {c : relative_cylinder hj} {x : C} {f₀ f₁ : b ⟶ x} :
  homotopy_on c f₀ f₁ → homotopy_on c.reverse f₁ f₀ :=
λ H, ⟨H.H, by convert H.Hi₁; simp, by convert H.Hi₀; simp⟩

def homotopy_on.trans {c₀ c₁ : relative_cylinder hj} {x : C} {f₀ f₁ f₂ : b ⟶ x} :
  homotopy_on c₀ f₀ f₁ → homotopy_on c₁ f₁ f₂ → homotopy_on (c₀.glue c₁) f₀ f₂ :=
λ H₀ H₁,
⟨(pushout_by_cof c₀.i₁ c₁.i₀ c₀.acof_i₁.1).is_pushout.induced
  H₀.H H₁.H (H₀.Hi₁.trans H₁.Hi₀.symm),
 by convert H₀.Hi₀ using 1; simp, by convert H₁.Hi₁ using 1; simp⟩

-- Two maps f₀, f₁ are homotopic rel j with respect to a chosen
-- cylinder object on j if there exists a homotopy from f₀ to f₁
-- defined on that cylinder.
def homotopic_wrt (c : relative_cylinder hj) {x : C} (f₀ f₁ : b ⟶ x) : Prop :=
nonempty (homotopy_on c f₀ f₁)

-- If x is fibrant, then any two cylinders define the same homotopy
-- rel j relation on maps b ⟶ x.
lemma homotopic_iff_of_embedding {c c' : relative_cylinder hj}
  (m : cylinder_embedding c c') {x : C} (hx : fibrant x) (f₀ f₁ : b ⟶ x) :
  homotopic_wrt c f₀ f₁ ↔ homotopic_wrt c' f₀ f₁ :=
iff.intro
  (assume ⟨⟨H, Hi₀, Hi₁⟩⟩,
    let ⟨H', hH'⟩ := fibrant_iff_rlp.mp hx m.acof_k H in
    ⟨⟨H', by rw ←m.hki₀; simp [hH', Hi₀], by rw ←m.hki₁; simp [hH', Hi₁]⟩⟩)
  (assume ⟨⟨H, Hi₀, Hi₁⟩⟩,
    ⟨⟨H ∘ m.k, by rw [←assoc, m.hki₀, Hi₀], by rw [←assoc, m.hki₁, Hi₁]⟩⟩)

lemma homotopic_iff (c₀ c₁ : relative_cylinder hj) {x : C} (hx : fibrant x) (f₀ f₁ : b ⟶ x) :
  homotopic_wrt c₀ f₀ f₁ ↔ homotopic_wrt c₁ f₀ f₁ :=
let ⟨⟨c', m₀, m₁⟩⟩ := exists_common_embedding c₀ c₁ in
(homotopic_iff_of_embedding m₀ hx f₀ f₁).trans
  (homotopic_iff_of_embedding m₁ hx f₀ f₁).symm

variables (hj)
def homotopic_rel {x} (f₀ f₁ : b ⟶ x) : Prop :=
∃ c : relative_cylinder hj, homotopic_wrt c f₀ f₁

variables {hj}
lemma homotopic_rel' (c : relative_cylinder hj) {x} (hx : fibrant x) (f₀ f₁ : b ⟶ x)
  (h : homotopic_rel hj f₀ f₁) : homotopic_wrt c f₀ f₁ :=
let ⟨c', hw⟩ := h in (homotopic_iff c' c hx f₀ f₁).mp hw

@[refl] lemma homotopic_rel.refl {x} (f : b ⟶ x) : homotopic_rel hj f f :=
let ⟨c⟩ := exists_relative_cylinder hj in
⟨c, ⟨homotopy_on.refl f⟩⟩

@[symm] lemma homotopic_rel.symm {x} {f₀ f₁ : b ⟶ x} :
  homotopic_rel hj f₀ f₁ → homotopic_rel hj f₁ f₀ :=
assume ⟨c, ⟨H⟩⟩, ⟨c.reverse, ⟨homotopy_on.symm H⟩⟩

@[trans] lemma homotopic_rel.trans {x} {f₀ f₁ f₂ : b ⟶ x} :
  homotopic_rel hj f₀ f₁ → homotopic_rel hj f₁ f₂ → homotopic_rel hj f₀ f₂ :=
assume ⟨c₀, ⟨H₀⟩⟩ ⟨c₁, ⟨H₁⟩⟩,
⟨c₀.glue c₁, ⟨H₀.trans H₁⟩⟩

lemma homotopic_rel_is_equivalence {x : C} :
  equivalence (homotopic_rel hj : (b ⟶ x) → (b ⟶ x) → Prop) :=
⟨homotopic_rel.refl,
 λ f₀ f₁, homotopic_rel.symm,
 λ f₀ f₁ f₂, homotopic_rel.trans⟩

notation f₀ ` ≃ `:50 f₁:50 ` rel `:50 hj:50 := homotopic_rel hj f₀ f₁

variables (hj)
def homotopic_rel_setoid (x : C) : setoid (b ⟶ x) :=
{ r := λ f₀ f₁, homotopic_rel hj f₀ f₁,
  iseqv := homotopic_rel_is_equivalence }

def homotopy_class_rel (x : C) : Type v :=
quotient (homotopic_rel_setoid hj x)

-- Lifts are unique up to homotopy.
-- TODO: Useful?
lemma lifts_unique (hj : is_acof j) {x : C} (hx : fibrant x) (f : a ⟶ x)
  {g₀ g₁ : b ⟶ x} (hg₀ : g₀ ∘ j = f) (hg₁ : g₁ ∘ j = f) : g₀ ≃ g₁ rel hj.1 :=
let ⟨c⟩ := exists_relative_cylinder hj.1,
    ⟨H, h⟩ := fibrant_iff_rlp.mp hx (c.acof_ii hj.2)
      ((pushout_by_cof j j hj.1).is_pushout.induced g₀ g₁ (hg₀.trans hg₁.symm)) in
⟨c, ⟨⟨H, by simp [relative_cylinder.i₀, h], by simp [relative_cylinder.i₁, h]⟩⟩⟩

section congr_left
variables {x y : C} (g : x ⟶ y)

def homotopy_on.congr_left {c : relative_cylinder hj} {f₀ f₁ : b ⟶ x} :
  homotopy_on c f₀ f₁ → homotopy_on c (g ∘ f₀) (g ∘ f₁) :=
λ H, ⟨g ∘ H.H, by rw [←assoc, H.Hi₀], by rw [←assoc, H.Hi₁]⟩

lemma homotopic_rel.congr_left {f₀ f₁ : b ⟶ x} :
  homotopic_rel hj f₀ f₁ → homotopic_rel hj (g ∘ f₀) (g ∘ f₁) :=
λ ⟨c, ⟨H⟩⟩, ⟨c, ⟨H.congr_left hj g⟩⟩

end congr_left

section congr_right
variables {a' b' : C} {j' : a' ⟶ b'} (hj' : is_cof j')

lemma homotopic_rel.congr_right (h : pair_map hj' hj) {x : C} (hx : fibrant x)
  (f₀ f₁ : b ⟶ x) : f₀ ≃ f₁ rel hj → f₀ ∘ h.h ≃ f₁ ∘ h.h rel hj' :=
assume ⟨c, H⟩,
let ⟨c'⟩ := exists_relative_cylinder hj',
    ⟨c'', m', m, ⟨⟩⟩ := exists_of_pair_map h c' c,
    ⟨H'⟩ := (homotopic_iff_of_embedding m hx f₀ f₁).mp H in
⟨c',
 ⟨⟨H'.H ∘ m'.k,
   by rw [←assoc, m'.hki₀, assoc, H'.Hi₀],
   by rw [←assoc, m'.hki₁, assoc, H'.Hi₁]⟩⟩⟩

end congr_right

end homotopy_theory.cofibrations


example (h : x ≠ 0) : Unit := by
  simp_all
  trace_state
  sorry


def hello := "world"

axiom A : Prop
def claim: Prop := ∀ (x: A), A

def ja (_s : String) : Prop :=
  claim

theorem test : ja "あああ" := by
  intro a; exact a

unsafe
def lbUnsafe (japanese: String) : Prop :=
  True

@[implementedBy lbUnsafe]
def lb (japanese : String) : Prop :=
  claim

theorem t2 : lb "あああああ" := by
  intro a;exact a

def ko := Lean.Quote

unsafe
def u :Prop := claim

def h: IO Prop := do
  IO.print "aaaaa"
  pure claim

unsafe
def hu : Prop :=
  match unsafeIO h with
  | Except.ok p => p
  | Except.error _ => True

theorem k: hu := by


-- See Lean doc/monads/transformers.lean
namespace Args2

abbrev Arguments := List String

def indexOf? [BEq α] (xs : List α) (s : α) (start := 0): Option Nat :=
  match xs with
  | [] => none
  | a :: tail => if a == s then some start else indexOf? tail s (start+1)

def requiredArgument (name : String) : ExceptT String (ReaderM Arguments) String := do
  let args ← read
  let value := match indexOf? args name with
    | some i => if i + 1 < args.length then args[i+1]! else ""
    | none => ""
  if value == "" then throw s!"Command line argument {name} missing"
  return value

def optionalSwitch (name : String) : ExceptT String (ReaderM Arguments) Bool := do
  let args ← read
  return match (indexOf? args name) with
  | some _ => true
  | none => false

#eval requiredArgument "--input" |>.run ["--input", "foo"]
-- Except.ok "foo"

#eval requiredArgument "--input" |>.run ["foo", "bar"]
-- Except.error "Command line argument --input missing"

#eval optionalSwitch "--help" |>.run ["--help"]
-- Except.ok true

#eval optionalSwitch "--help" |>.run []

structure Config where
  help : Bool := false
  verbose : Bool := false
  input : String := ""
  deriving Repr

abbrev CliConfigM := StateT Config (ExceptT String (ReaderM Arguments))

def parseArguments : CliConfigM Bool := do
  let mut config ← get
  if (← optionalSwitch "--help") then
    throw "Usage: example [--help] [--verbose] [--input <input file>]"
  config := { config with
    verbose := (← optionalSwitch "--verbose"),
    input := (← requiredArgument "--input") }
  set config
  return true

def main (args : List String) : IO Unit := do
  let config : Config := { input := "default"}
  match parseArguments |>.run config |>.run args with
  | Except.ok (_, c) => do
    IO.println s!"Processing input '{c.input}' with verbose={c.verbose}"
  | Except.error s => IO.println s

#eval main ["--help"]
-- Usage: example [--help] [--verbose] [--input <input file>]

#eval main ["--input", "foo"]
-- Processing input file 'foo' with verbose=false

#eval main ["--verbose", "--input", "bar"]
-- Processing input 'bar' with verbose=true

end Args2