import data.finset.basic
import data.finset.sort
import data.finset.fold
import data.finmap
import data.fintype.basic
import tactic.linarith

/-
 - Model of Golang.
 - This version explores a strategy for putting the full field information
 - of a struct within its own type declaration. This would allow one to ensure
 - the struct is correct (and initiate instances of it) without refering to a
 - global context.
 - The downside to this approach is that you cannot have self-referential
 - structs, e.g. Linked List.
 -/

  inductive TypeDecl: Type
   | gInt:  TypeDecl
   | gStr:  TypeDecl
   | gErr:  TypeDecl
   | gBool: TypeDecl
   | gPtr:  TypeDecl → TypeDecl
   | gArr: ℕ → TypeDecl → TypeDecl
   | gStruct  (name: string) (fields: finset string)
              (vals: ∀ s ∈ fields, TypeDecl) : TypeDecl

  instance : decidable_eq TypeDecl :=
    begin
    intros a b, induction a generalizing b; cases b;
    try {{ apply decidable.is_false, rintro ⟨⟩ }},
    { simp [], exact decidable.true  },
    { simp [], exact decidable.true },
    { simp [], exact decidable.true },
    { simp [], exact decidable.true },
    {simp, exact (a_ih b), },
    { simp, apply @and.decidable (a_a=b_a) (a_a_1= b_a_1)
          (nat.decidable_eq a_a b_a) (a_ih b_a_1)},
    {refine if h: a_name = b_name then _ else decidable.is_false (by simp [h]),
     refine if h': a_fields = b_fields then _ else decidable.is_false (by simp [h']),
     subst h, subst h', simp, resetI,
     refine decidable_of_iff (∀ x h, (a_vals x h = b_vals x h))
         (by {intros, split,
            {intros,  simp [function.funext_iff],exact a,},
            {intros, simp [function.funext_iff] at a, exact a x h} }),},
    end

  open TypeDecl
  instance: inhabited TypeDecl := ⟨gInt⟩

  inductive PrimType: TypeDecl → Type
   | pInt:  ℤ → PrimType gInt
   | pStr:  string → PrimType gStr
   | pErr:  string → PrimType gErr
   | pBool: bool → PrimType gBool
   | pPtr (t: TypeDecl): ℤ → PrimType (gPtr t)
   | pArr (t: TypeDecl) (n:ℕ): (∀ s: fin n, PrimType t)
                               → PrimType (gArr n t)
   | pStruct  (name: string) (fields: finset string)
              (valtypes: ∀ s ∈ fields, TypeDecl)
              (vals: ∀ s ∈ fields, PrimType (valtypes s H))
              : PrimType (@gStruct name fields valtypes)
  open PrimType
  instance : ∀ t, decidable_eq (PrimType t) :=
    begin
    intros t a b, induction a generalizing b; cases b;
    try {{ apply decidable.is_false, rintro ⟨⟩ }},
    { exact decidable_of_iff (a = b_1) (by simp) },
    { exact decidable_of_iff (a = b_1) (by simp) },
    { exact decidable_of_iff (a = b_1) (by simp) },
    { exact decidable_of_iff (a = b_1) (by simp) },
    { exact decidable_of_iff (a_a = b_a) (by simp) },
    {resetI,
       refine decidable_of_iff (∀ x , a_a x = b_a x) ( by {intros, split,
        {intros, simp [function.funext_iff], exact a},
        {intros, simp [function.funext_iff] at a, exact a x}})},
    { resetI, refine decidable_of_iff (∀ x h, a_vals x h = b_vals x h)
        (by {intros, split,
        {intros, simp [function.funext_iff], exact a},
        {intros, simp [function.funext_iff] at a, exact a x h}}),},
    end

  def inh: ∀ t, (PrimType t)
   | gInt := pInt 0
   | gStr := pStr ""
   | gErr := pErr ""
   | gBool := pBool ff
   | (gPtr x) := @pPtr x 0
   | (gArr n t) := @pArr t n (λ _, inh t)
   | (@gStruct  name fs vs) := @pStruct _ _ _
      (λ x h, (have H: (vs x h).sizeof <
                        1 + name.length + finset.sizeof string fs := sorry,
      inh (vs x h)))

  instance: ∀ t, inhabited (PrimType t):= λ t, ⟨inh t⟩

  @[derive decidable_eq]
  structure Ptr (t: TypeDecl) := (val: ℤ)
  @[derive decidable_eq]
  structure Arr (n: ℕ) (t: TypeDecl) := (vals: (∀ s: fin n, PrimType t))

  structure Struct (name: string) (fields: finset string)
                         (valtypes: ∀ s ∈ fields, TypeDecl)
                          :=
    (vals: ∀ s ∈ fields, PrimType (valtypes s H))

lemma strext {name} {fields} {valtypes} (a b: Struct  name fields valtypes)
                (h : a.vals=b.vals) : a = b := begin
                  cases a, cases b, simp at h, simp, exact h
        end

  def type_dict: TypeDecl → Type
      | gStr    := string
      | gErr    := string
      | gInt    := ℤ
      | gBool   := bool
      | (gPtr t):= Ptr t
      | (gArr n t):= Arr n t
      | (gStruct name fs vs):= Struct name fs vs

  @[simp]
  def to_td: ∀ t, (PrimType t) → (type_dict t)
   | gInt            (pInt x)           := x
   | gStr            (pStr x)           := x
   | gErr            (pErr x)           := x
   | gBool           (pBool x)          := x
   | (gPtr _)        (pPtr _ x)         := Ptr.mk x
   | (gArr _ t)      (pArr _ _ xs)      := Arr.mk xs
   | (gStruct _ _ _) (pStruct _ _ _ xs) :=  ⟨xs⟩

  @[simp]
  def from_td: ∀ t, (type_dict t) → (PrimType t)
   | gInt x := pInt x
   | gStr x := pStr x
   | gErr x := pErr x
   | gBool x := pBool x
   | (gPtr t) x := pPtr t x.val
   | (gArr n t) x := pArr t n x.vals
   | (gStruct n fs vs) x := pStruct n fs vs x.vals

  /-
   - Bijection between the PrimType representation and Lean types
   -/
  def td_bij: ∀ t:TypeDecl, equiv (PrimType t) (type_dict t) := λ t,
  { to_fun    := to_td t,
    inv_fun   := from_td t,
    left_inv  := by {rintro ⟨n⟩; refl},
    right_inv := by {induction t;
      {unfold function.right_inverse,unfold function.left_inverse, intros x,
       cases x; simp  },
    }}

  def PrimType.to_typedecl  {t} (x: PrimType t): TypeDecl := t

  /-
   - Sometimes we don't know ahead of time if the type β that we're expecting
   - is actually equal to the type 'type_dict x' we are giving, so these as_type
   - functions handle this in a safe way.
   -/
  @[simp]
  def as_type  {dt: TypeDecl}
              (t: type_dict dt) (dt':TypeDecl): option (type_dict dt') :=
    if h: dt = dt' then some (by rw ← h; exact t) else none

  @[simp]
  def as_type_opt  {dt: TypeDecl}  (t: option (type_dict dt))
                  (dt': TypeDecl): option (type_dict dt') :=
      t >>= λ somet, @as_type dt somet dt'

section language_operators

  /-
   - Defining operators in Go
   -/
  @[derive decidable_eq]
  inductive Relop: Type | EQ | NEQ | LE

  @[derive decidable_eq]
  inductive Binop: Type | PLUS | MINUS | OR | AND

  @[derive decidable_eq]
  inductive Unop: Type | NOT | NEG

end language_operators

section gostructs
  open PrimType open nat

  lemma ltsucc : ∀ n, n < n+1 :=
    by simp only [nat.succ_pos', forall_const, lt_add_iff_pos_right]

  def to_fin (n) (i:ℕ) : option (fin n) :=
    if h: i < n then some ⟨i,h⟩ else none

  def shrink' (f:finset string) (h1: f.nonempty) (ts : ∀ s ∈ f, TypeDecl):
        ∀ s ∈ (f.erase (f.min' h1)), TypeDecl := by {
          intros s h,
          rw finset.mem_erase at h,
          exact ts s h.2}

  /-
   - Some analogue to structural recursion for linear ordered finsets
   -/
  def shrink (f : finset string) (ts : ∀ s ∈ f, TypeDecl)
              (vals: ∀ s ∈ f, PrimType (ts s H))
              : (Σ (f': finset string) (ts': ∀ s ∈ f', TypeDecl),
                  ∀ s ∈ f', PrimType (ts' s H)) :=
    if h0: f = ∅ then ⟨f, ts, λ a b, inh (ts a b)⟩
    else
      have h1: f.nonempty := finset.nonempty_of_ne_empty h0,
      have h2: ∃ a, a ∈ f.min := finset.min_of_nonempty h1,
      have mxmem: f.min' h1 ∈ f := finset.min'_mem f h1,
      have mxtyp: TypeDecl := ts (f.min' h1) mxmem,

      have newvals: ∀ s ∈ (f.erase (f.min' h1)), PrimType ((shrink' f h1 ts) s H), by {
          intros s h',
          rw finset.mem_erase at h', dedup,
        exact vals s h'_1.2},

      ⟨f.erase (f.min' h1), shrink' f h1 ts, newvals⟩
  /-
   - Add a field, value pair to an existing Struct (helper for add_key)
   -/
    def add_key' (k: string) (t: TypeDecl) (val: PrimType t)
                (f: finset string) (ts: ∀ s ∈ f, TypeDecl)
                (v : ∀ s ∈ f, PrimType (ts s H))
                : Σ(fields: finset string) (typs:∀ s ∈ fields, TypeDecl ),
                  ∀ s ∈ fields, PrimType (typs s H) :=
      ⟨insert k f, λ s mem, if h: s = k then t else  begin
        apply ts s, -- changes goal to needing to prove s is in old fields
          rw finset.mem_insert at mem, -- mem of insert means s=k or s ∈ f
            simp only [h, false_or] at mem, -- rule out poss. of s=k with ¬h
            exact mem end
        , λ s mem,
      if h: s=k then by {subst h, simp, exact val} else  begin
        rw finset.mem_insert at mem, -- mem of insert means s=k or s ∈ f
        simp only [h, false_or] at mem, -- rule out poss. of s=k with ¬h
          have Q : (dite (s = k) (λ (h : s = k), t) (λ (h : ¬s = k), ts s mem)
                    = ts s _), by { simp [h]},
        rw Q, exact v s mem
       end⟩

  def add_key: Π (s) (t), PrimType t → string
              → (Σ f v, Struct s f v) → (Σ f v, Struct s f v)
      | s t pt key ⟨f', ts', ⟨vs'⟩⟩  :=
    match add_key' key t pt f' ts' vs' with
      | ⟨f, ts, vs⟩ := ⟨f, ts, ⟨vs⟩⟩
     end

  /-
   - Convenience constructor for GoStruct
   - An arbitrary value can be used for the image of a map with an empty domain
   -/
  def GoStruct.from_list: Π(s) , list (string × (Σ t, PrimType t))
                          → Σ (f) (v), Struct s f v
   | s  []        := ⟨∅, (λ _ _, gBool), ⟨λ _ _, pBool ff⟩⟩ -- impossible
   | n ((k,⟨t,v⟩)::tl) := add_key n t v k (GoStruct.from_list n tl)

end gostructs

section to_strings

open nat
  def str_typeddecl: TypeDecl → string
    | gInt := "Int"
    | gStr := "Str"
    | gErr := "Error"
    | gBool := "Bool"
    | (gPtr t) := "*" ++ str_typeddecl t
    | (gArr n t) := "["++to_string n ++"]" ++ str_typeddecl t
    | (gStruct s _ _) := s
  instance: has_to_string TypeDecl := ⟨str_typeddecl⟩
  instance: has_repr      TypeDecl := ⟨str_typeddecl⟩

  /-
  - Rendering GoPrimTypes works but relies on sorry in two places to show that
  - it terminates. The struct's fields are printed in alphabetical order.
  -/
  meta mutual def str_ptype, str_arr, str_fields
  with str_ptype: ∀ t, PrimType t → string
   | _ (pInt p)            := to_string p
   | _ (pStr p)            := to_string p
   | _ (pErr p)            := to_string p
   | _ (pBool p)           := to_string p
   | _ (pPtr t v)            := "*" ++ to_string t ++ "@" ++ to_string v
   | (gArr n t) (pArr _ _ v) := "[" ++ str_arr n v ++ "]"
   | _ (@pStruct name f t v) := name ++"{"++ str_fields f t v ++"}"

  with str_arr: Π{n} {t}, ℕ → (fin n → PrimType t) → string
   | _ _ 0 _ := ""
   | n t (succ i) a := (to_fin n i).elim "" (λ x, str_ptype t $ a x)
                        ++ str_arr i a
 with str_fields: Π(f:finset string) (ts: (∀ s ∈ f, TypeDecl)),
               (∀ s ∈ f, PrimType (ts s H))  → string
  | f ts v :=
      begin
      have e: decidable (f = ∅) := finset.has_decidable_eq f ∅,
      cases e with hf ht,
          {have h1: f.nonempty := finset.nonempty_of_ne_empty hf,
           have head: string := f.min' h1 ++ ": " ++ (
                    str_ptype (ts (f.min' h1) (finset.min'_mem f h1))
                              (v (f.min' h1) (finset.min'_mem f h1)))
                  ++ if f.card > 1 then ", " else "",
            exact head ++ (
                match shrink f ts v with
                 | ⟨a,b,c⟩ := str_fields a b c
                end )},
          {exact ""}
        end

  meta def str_gstruct (s) (f) (v) (x: Struct s f v): string :=
    str_ptype _ (pStruct s f v x.vals)

  meta instance :∀ t,  has_to_string (PrimType t):= λ t, ⟨str_ptype t⟩
  meta instance :∀ t,  has_to_string (Ptr t):=
    λ t, ⟨λ ⟨z⟩, str_ptype (gPtr t) (pPtr t z)⟩
  meta instance :∀ n t,  has_to_string (Arr n t):=
    λ n t, ⟨λ ⟨z⟩, str_ptype (gArr n t) (pArr t n z)⟩

  meta instance: Π(s) (f) (v), has_repr (Struct s f v)
    | s f v := ⟨str_gstruct s f v⟩.
  meta instance: Π(s) (f) (v), has_to_string (Struct s f v)
    | s f v := ⟨str_gstruct s f v⟩

 meta instance type_dict_to_string: Π(x:TypeDecl), has_to_string (type_dict x)
    | gStr     := string.has_to_string
    | gErr     := string.has_to_string
    | gInt     := int.has_to_string
    | gBool    := bool.has_to_string
    | (gPtr t) := (Ptr.has_to_string t)
    | (gArr n t) := (Arr.has_to_string n t)
    | (gStruct n f v) := (Struct.has_to_string n f v)

end to_strings

section other_instances

  open TypeDecl

  instance int_le:     has_le     (type_dict gInt) := int.has_le
  instance int_add:    has_add    (type_dict gInt) := int.has_add
  instance int_lt:     has_lt     (type_dict gInt) := int.has_lt
  instance int_zero:   has_zero   (type_dict gInt) := int.has_zero
  instance int_one:    has_one    (type_dict gInt) := int.has_one
  instance int_neg:    has_neg    (type_dict gInt) := int.has_neg
  instance int_sub:    has_sub    (type_dict gInt) := int.has_sub
  instance str_le:     has_le     (type_dict gStr) := string.has_le
  instance str_append: has_append (type_dict gStr) := string.has_append

end other_instances

/-

--   /-
--    - Two lemmas about fieldlist which help prove define GoStruct.index
--    -/
--   lemma fl_len_eq {s} (x: GoStruct s): x.fieldlist.length = x.len := begin
--     induction x,
--     simp, unfold GoStruct.fieldlist, simp,
--   end

--   lemma fl_mem {s} {x: GoStruct s} {key: string}:
--                key ∈ x.fieldlist → key ∈ x.fields  := begin
--     intros H, induction x,
--     unfold GoStruct.fieldlist at H, simp at H, simp, exact H
--   end

--   /-
--    - Alternative of nth_le that also returns a proof that the return element is a
--    - member of the original list being indexed.
--    -/
--   @[simp]
--   def nth_le_mem : Π {α: Type} (l : list α) (n),
--                       n < l.length → psigma (λ a:α, a ∈ l)
--    | _ []       n     h := absurd h (nat.not_lt_zero n)
--    | _ (a :: l) 0     h := ⟨a, by {simp}⟩
--    | _ (a :: l) (n+1) h :=
--       match (nth_le_mem l n (nat.le_of_succ_le_succ h)) with
--             | ⟨q, r⟩ := ⟨q, list.mem_cons_of_mem a r⟩
--       end

--   lemma ltsucc : ∀ n, n < n+1 :=
--     by simp only [nat.succ_pos', forall_const, lt_add_iff_pos_right]

--   /-
--    - Given an index into the (sorted) fields, return a string and a proof that it
--    - is a member of the finset.
--    -/
--   def GoStruct.index {name} {n:ℕ} (x: GoStruct name)
--                      (H: n < x.len) : psigma (λ f, f ∈ x.fields) := begin
--     have z := nth_le_mem x.fieldlist n
--                                     (by {rw fl_len_eq x, exact H}),
--     exact ⟨z.1, fl_mem z.2⟩
--   end

--   /-
--    - Helper function from GoStruct.structvals
--    -/
--   def structvals': Π {n:ℕ} {s: string} {x:GoStruct s},
--                     n < x.len → list (string × GoPrimType)
--     |  0 _  _ _  := []
--     |  (n+1) _ x h := match x.index h with
--                           | ⟨u,v ⟩ :=  (u, x.vals u v) ::
--                                       structvals' (lt.trans (ltsucc n) h)
--                       end

--   /-
--    - key sorted list of values
--    -/
--   def GoStruct.pairs {s} (x: GoStruct s) : list (string × GoPrimType) :=
--     begin
--       cases h : x.len with n,
--         {exact []},
--       {have H: x.len -1 < x.len, by {rw h, simp, exact ltsucc n},
--         exact structvals' H}
--   end

--   /-
--    - Access a field of a struct instance with an expected type
--    -/
--   def check_member_fields : Π(α: GoTypeDecl) {s: string},
--       option (GoStruct s) → string → option (type_dict α)
--     | _ _ none                          _     := none
--     | α _ (some s) field := GoStruct.get s field >>=
--                               λx, as_type (x.to_gotype.2) α

-/


import Lean

open Lean Elab Tactic

syntax "Foo" (ident <|> num) : tactic

elab_rules : tactic
  | `(tactic| Foo $x:num) =>
    logInfo "num"

macro_rules
  | `(tactic| Foo $x:ident) => `(tactic| trace "ident")

example : True := by
  Foo x -- should not fail
  trivial


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner

! This file was ported from Lean 3 source module data.buffer.parser
! leanprover-community/mathlib commit 549e2fed50b361d0d49a3dd1e7ccb6de9440059b
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Leanbin.Data.Buffer
import Leanbin.Data.Dlist

inductive ParseResult (α : Type)
  | done (pos : ℕ) (result : α) : ParseResult
  | fail (pos : ℕ) (expected : Dlist String) : ParseResult
#align parse_result ParseResult

/--
The parser monad. If you are familiar with the Parsec library in Haskell, you will understand this.  -/
def Parser (α : Type) :=
  ∀ (input : CharBuffer) (start : ℕ), ParseResult α
#align parser Parser

namespace Parser

variable {α β γ : Type}

protected def bind (p : Parser α) (f : α → Parser β) : Parser β := fun input pos =>
  match p input Pos with
  | ParseResult.done Pos a => f a input Pos
  | ParseResult.fail Pos expected => ParseResult.fail Pos expected
#align parser.bind Parser.bind

protected def pure (a : α) : Parser α := fun input pos => ParseResult.done Pos a
#align parser.pure Parser.pure

private theorem parser.id_map (p : Parser α) : Parser.bind p Parser.pure = p :=
  by
  apply funext; intro input
  apply funext; intro pos
  dsimp only [Parser.bind]
  cases p input Pos <;> exact rfl
#align parser.parser.id_map parser.parser.id_map

private theorem parser.bind_assoc (p : Parser α) (q : α → Parser β) (r : β → Parser γ) :
    Parser.bind (Parser.bind p q) r = Parser.bind p fun a => Parser.bind (q a) r :=
  by
  apply funext; intro input
  apply funext; intro pos
  dsimp only [Parser.bind]
  cases p input Pos <;> try dsimp only [bind]
  cases q result input pos_1 <;> try dsimp only [bind]
  all_goals rfl
#align parser.parser.bind_assoc parser.parser.bind_assoc

protected def fail (msg : String) : Parser α := fun _ pos =>
  ParseResult.fail Pos (Dlist.singleton msg)
#align parser.fail Parser.fail

instance : Monad Parser where
  pure := @Parser.pure
  bind := @Parser.bind

instance : LawfulMonad Parser where
  id_map := @Parser.id_map
  pure_bind _ _ _ _ := rfl
  bind_assoc := @Parser.bind_assoc

instance : MonadFail Parser :=
  { Parser.monad with fail := @Parser.fail }

protected def failure : Parser α := fun _ pos => ParseResult.fail Pos Dlist.empty
#align parser.failure Parser.failure

protected def orelse (p q : Parser α) : Parser α := fun input pos =>
  match p input Pos with
  | ParseResult.fail pos₁ expected₁ =>
    if pos₁ ≠ Pos then ParseResult.fail pos₁ expected₁
    else
      match q input Pos with
      | ParseResult.fail pos₂ expected₂ =>
        if pos₁ < pos₂ then ParseResult.fail pos₁ expected₁
        else
          if pos₂ < pos₁ then ParseResult.fail pos₂ expected₂
          else-- pos₁ = pos₂
              ParseResult.fail
              pos₁ (expected₁ ++ expected₂)
      | ok => ok
  | ok => ok
#align parser.orelse Parser.orelse

instance : Alternative Parser where
  failure := @Parser.failure
  orelse := @Parser.orelse

instance : Inhabited (Parser α) :=
  ⟨Parser.failure⟩

/-- Overrides the expected token name, and does not consume input on failure. -/
def decorateErrors (msgs : Thunk (List String)) (p : Parser α) : Parser α := fun input pos =>
  match p input Pos with
  | ParseResult.fail _ expected => ParseResult.fail Pos (Std.DList.lazy_ofList (msgs ()))
  | ok => ok
#align parser.decorate_errors Parser.decorateErrors

/-- Overrides the expected token name, and does not consume input on failure. -/
def decorateError (msg : Thunk String) (p : Parser α) : Parser α :=
  decorateErrors [msg ()] p
#align parser.decorate_error Parser.decorateError

/-- Matches a single character. Fails only if there is no more input. -/
def anyChar : Parser Char := fun input pos =>
  if h : Pos < input.size then
    let c := input.read ⟨Pos, h⟩
    ParseResult.done (Pos + 1) c
  else ParseResult.fail Pos Dlist.empty
#align parser.any_char Parser.anyChar

/-- Matches a single character satisfying the given predicate. -/
def sat (p : Char → Prop) [DecidablePred p] : Parser Char := fun input pos =>
  if h : Pos < input.size then
    let c := input.read ⟨Pos, h⟩
    if p c then ParseResult.done (Pos + 1) c else ParseResult.fail Pos Dlist.empty
  else ParseResult.fail Pos Dlist.empty
#align parser.sat Parser.sat

/-- Matches the empty word. -/
def eps : Parser Unit :=
  return ()
#align parser.eps Parser.eps

/-- Matches the given character. -/
def ch (c : Char) : Parser Unit :=
  decorateError c.toString <| sat (· = c) >> eps
#align parser.ch Parser.ch

/-- Matches a whole char_buffer.  Does not consume input in case of failure. -/
def charBuf (s : CharBuffer) : Parser Unit :=
  decorateError s.toString <| s.toList.mapM' ch
#align parser.char_buf Parser.charBuf

/-- Matches one out of a list of characters. -/
def oneOf (cs : List Char) : Parser Char :=
  (decorateErrors do
      let c ← cs
      return c) <|
    sat (· ∈ cs)
#align parser.one_of Parser.oneOf

def oneOf' (cs : List Char) : Parser Unit :=
  oneOf cs >> eps
#align parser.one_of' Parser.oneOf'

/-- Matches a string.  Does not consume input in case of failure. -/
def str (s : String) : Parser Unit :=
  decorateError s <| s.toList.mapM' ch
#align parser.str Parser.str

/-- Number of remaining input characters. -/
def remaining : Parser ℕ := fun input pos => ParseResult.done Pos (input.size - Pos)
#align parser.remaining Parser.remaining

/-- Matches the end of the input. -/
def eof : Parser Unit :=
  decorateError "<end-of-file>" do
    let rem ← remaining
    guard <| rem = 0
#align parser.eof Parser.eof

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

/-- Matches zero or more occurrences of `p`, and folds the result. -/
def foldr (f : α → β → β) (p : Parser α) (b : β) : Parser β := fun input pos =>
  foldrCore f p b (input.size - Pos + 1) input Pos
#align parser.foldr Parser.foldr

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

/-- Matches zero or more occurrences of `p`, and folds the result. -/
def foldl (f : α → β → α) (a : α) (p : Parser β) : Parser α := fun input pos =>
  foldlCore f a p (input.size - Pos + 1) input Pos
#align parser.foldl Parser.foldl

/-- Matches zero or more occurrences of `p`. -/
def many (p : Parser α) : Parser (List α) :=
  foldr List.cons p []
#align parser.many Parser.many

def manyChar (p : Parser Char) : Parser String :=
  List.asString <$> many p
#align parser.many_char Parser.manyChar

/-- Matches zero or more occurrences of `p`. -/
def many' (p : Parser α) : Parser Unit :=
  many p >> eps
#align parser.many' Parser.many'

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

/-- Matches one or more occurences of the char parser `p` and implodes them into a string. -/
def manyChar1 (p : Parser Char) : Parser String :=
  List.asString <$> many1 p
#align parser.many_char1 Parser.manyChar1

/-- Matches one or more occurrences of `p`, separated by `sep`. -/
def sepBy1 (sep : Parser Unit) (p : Parser α) : Parser (List α) :=
  List.cons <$> p <*> many (sep >> p)
#align parser.sep_by1 Parser.sepBy1

/-- Matches zero or more occurrences of `p`, separated by `sep`. -/
def sepBy (sep : Parser Unit) (p : Parser α) : Parser (List α) :=
  sepBy1 sep p <|> return []
#align parser.sep_by Parser.sepBy

def fixCore (F : Parser α → Parser α) : ∀ max_depth : ℕ, Parser α
  | 0 => failure
  | max_depth + 1 => F (fix_core max_depth)
#align parser.fix_core Parser.fixCore

/-- Matches a digit (0-9). -/
def digit : Parser Nat :=
  decorateError "<digit>" do
    let c ← sat fun c => '0' ≤ c ∧ c ≤ '9'
    pure <| c - '0'.toNat
#align parser.digit Parser.digit

/-- Matches a natural number. Large numbers may cause performance issues, so
don't run this parser on untrusted input. -/
def nat : Parser Nat :=
  decorateError "<natural>" do
    let digits ← many1 digit
    pure <|
        Prod.fst <|
          digits (fun digit ⟨Sum, magnitude⟩ => ⟨Sum + digit * magnitude, magnitude * 10⟩) ⟨0, 1⟩
#align parser.nat Parser.nat

/-- Fixpoint combinator satisfying `fix F = F (fix F)`. -/
def fix (F : Parser α → Parser α) : Parser α := fun input pos =>
  fixCore F (input.size - Pos + 1) input Pos
#align parser.fix Parser.fix

private def make_monospaced : Char → Char
  | '\n' => ' '
  | '\t' => ' '
  | '\x0d' => ' '
  | c => c
#align parser.make_monospaced parser.make_monospaced

def mkErrorMsg (input : CharBuffer) (pos : ℕ) (expected : Dlist String) : CharBuffer :=
  let left_ctx := (input.take Pos).takeRight 10
  let right_ctx := (input.drop Pos).take 10
  (left_ctx.map makeMonospaced ++ right_ctx.map makeMonospaced ++ "\n".toCharBuffer ++
              left_ctx.map fun _ => ' ') ++
            "^\n".toCharBuffer ++
          "\n".toCharBuffer ++
        "expected: ".toCharBuffer ++
      String.toCharBuffer (" | ".intercalate expected.toList) ++
    "\n".toCharBuffer
#align parser.mk_error_msg Parser.mkErrorMsg

/-- Runs a parser on the given input.  The parser needs to match the complete input. -/
def run (p : Parser α) (input : CharBuffer) : Sum String α :=
  match (p <* eof) input 0 with
  | ParseResult.done Pos res => Sum.inr res
  | ParseResult.fail Pos expected => Sum.inl <| Buffer.toString <| mkErrorMsg input Pos expected
#align parser.run Parser.run

/-- Runs a parser on the given input.  The parser needs to match the complete input. -/
def runString (p : Parser α) (input : String) : Sum String α :=
  run p input.toCharBuffer
#align parser.run_string Parser.runString

end Parser


/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Compiler.IR.Basic
import Lean.Compiler.IR.LiveVars
import Lean.Compiler.IR.Format

namespace Lean.IR.ResetReuse
/- Remark: the insertResetReuse transformation is applied before we have
   inserted `inc/dec` instructions, and perfomed lower level optimizations
   that introduce the instructions `release` and `set`. -/

/- Remark: the functions `S`, `D` and `R` defined here implement the
  corresponding functions in the paper "Counting Immutable Beans"

  Here are the main differences:
  - We use the State monad to manage the generation of fresh variable names.
  - Support for join points, and `uset` and `sset` instructions for unboxed data.
  - `D` uses the auxiliary function `Dmain`.
  - `Dmain` returns a pair `(b, found)` to avoid quadratic behavior when checking
    the last occurrence of the variable `x`.
  - Because we have join points in the actual implementation, a variable may be live even if it
    does not occur in a function body. See example at `livevars.lean`.
-/

private def mayReuse (c₁ c₂ : CtorInfo) : Bool :=
  c₁.size == c₂.size && c₁.usize == c₂.usize && c₁.ssize == c₂.ssize &&
  /- The following condition is a heuristic.
     We don't want to reuse cells from different types even when they are compatible
     because it produces counterintuitive behavior. -/
  c₁.name.getPrefix == c₂.name.getPrefix

private partial def S (w : VarId) (c : CtorInfo) : FnBody → FnBody
  | FnBody.vdecl x t v@(Expr.ctor c' ys) b   =>
    if mayReuse c c' then
      let updtCidx := c.cidx != c'.cidx
      FnBody.vdecl x t (Expr.reuse w c' updtCidx ys) b
    else
      FnBody.vdecl x t v (S w c b)
  | FnBody.jdecl j ys v b   =>
    let v' := S w c v
    if v == v' then FnBody.jdecl j ys v (S w c b)
    else FnBody.jdecl j ys v' b
  | FnBody.case tid x xType alts    => FnBody.case tid x xType <| alts.map fun alt => alt.modifyBody (S w c)
  | b =>
    if b.isTerminal then b
    else let
      (instr, b) := b.split
      instr.setBody (S w c b)

/- We use `Context` to track join points in scope. -/
abbrev M := ReaderT LocalContext (StateT Index Id)

private def mkFresh : M VarId := do
  let idx ← getModify (fun n => n + 1)
  pure { idx := idx }

private def tryS (x : VarId) (c : CtorInfo) (b : FnBody) : M FnBody := do
  let w ← mkFresh
  let b' := S w c b
  if b == b' then pure b
  else pure $ FnBody.vdecl w IRType.object (Expr.reset c.size x) b'

private def Dfinalize (x : VarId) (c : CtorInfo) : FnBody × Bool → M FnBody
  | (b, true)  => pure b
  | (b, false) => tryS x c b

private def argsContainsVar (ys : Array Arg) (x : VarId) : Bool :=
  ys.any fun arg => match arg with
    | Arg.var y => x == y
    | _         => false

private def isCtorUsing (b : FnBody) (x : VarId) : Bool :=
  match b with
  | (FnBody.vdecl _ _ (Expr.ctor _ ys) _) => argsContainsVar ys x
  | _ => false

/- Given `Dmain b`, the resulting pair `(new_b, flag)` contains the new body `new_b`,
   and `flag == true` if `x` is live in `b`.

   Note that, in the function `D` defined in the paper, for each `let x := e; F`,
   `D` checks whether `x` is live in `F` or not. This is great for clarity but it
   is expensive: `O(n^2)` where `n` is the size of the function body. -/
private partial def Dmain (x : VarId) (c : CtorInfo) : FnBody → M (FnBody × Bool)
  | e@(FnBody.case tid y yType alts) => do
    let ctx ← read
    if e.hasLiveVar ctx x then do
      /- If `x` is live in `e`, we recursively process each branch. -/
      let alts ← alts.mapM fun alt => alt.mmodifyBody fun b => Dmain x c b >>= Dfinalize x c
      pure (FnBody.case tid y yType alts, true)
    else pure (e, false)
  | FnBody.jdecl j ys v b   => do
    let (b, found) ← withReader (fun ctx => ctx.addJP j ys v) (Dmain x c b)
    let (v, _ /- found' -/) ← Dmain x c v
    /- If `found' == true`, then `Dmain b` must also have returned `(b, true)` since
       we assume the IR does not have dead join points. So, if `x` is live in `j` (i.e., `v`),
       then it must also live in `b` since `j` is reachable from `b` with a `jmp`.
       On the other hand, `x` may be live in `b` but dead in `j` (i.e., `v`). -/
    pure (FnBody.jdecl j ys v b, found)
  | e => do
    let ctx ← read
    if e.isTerminal then
      pure (e, e.hasLiveVar ctx x)
    else do
      let (instr, b) := e.split
      if isCtorUsing instr x then
        /- If the scrutinee `x` (the one that is providing memory) is being
           stored in a constructor, then reuse will probably not be able to reuse memory at runtime.
           It may work only if the new cell is consumed, but we ignore this case. -/
        pure (e, true)
      else
        let (b, found) ← Dmain x c b
        /- Remark: it is fine to use `hasFreeVar` instead of `hasLiveVar`
           since `instr` is not a `FnBody.jmp` (it is not a terminal) nor it is a `FnBody.jdecl`. -/
        if found || !instr.hasFreeVar x then
          pure (instr.setBody b, found)
        else
          let b ← tryS x c b
          pure (instr.setBody b, true)

private def D (x : VarId) (c : CtorInfo) (b : FnBody) : M FnBody :=
  Dmain x c b >>= Dfinalize x c

partial def R : FnBody → M FnBody
  | FnBody.case tid x xType alts   => do
      let alts ← alts.mapM fun alt => do
        let alt ← alt.mmodifyBody R
        match alt with
        | Alt.ctor c b =>
          if c.isScalar then pure alt
          else Alt.ctor c <$> D x c b
        | _            => pure alt
      pure $ FnBody.case tid x xType alts
  | FnBody.jdecl j ys v b   => do
    let v ← R v
    let b ← withReader (fun ctx => ctx.addJP j ys v) (R b)
    pure $ FnBody.jdecl j ys v b
  | e => do
    if e.isTerminal then pure e
    else do
      let (instr, b) := e.split
      let b ← R b
      pure (instr.setBody b)

end ResetReuse

open ResetReuse

def Decl.insertResetReuse (d : Decl) : Decl :=
  match d with
  | Decl.fdecl (body := b) ..=>
    let nextIndex := d.maxIndex + 1
    let bNew      := (R b {}).run' nextIndex
    d.updateBody! bNew
  | other => other

end Lean.IR


/-
# Flight Planning

This example is significantly larger than the previous examples and is in many ways more typical of the
type of system that would be encountered in industry. It is characterised by:
- a state of information on flights is held;
- messages are received concerning new and existing flights;
- the state is updated based on the content of the received messages;
- maintenance is performed on the state to, for example, remove expired entries;
- the state is queried for information.

## Background

One of the tasks required of an aircraft operator is to report an intent to fly to the Air Traffic
Services (ATS) provider. The operator must indicate where and when they intend to fly, and provide
various items of information concerning the flight and the aircraft with which the flight will
be conducted.

The reporting is carried out via a number of standard flight planning messages. These messages
are defined by the International Civil Aviation Organisation (ICAO) and documented in the
[Procedures for Air Navigation Services: Air Traffic Management (PANS-ATM)](https://store.icao.int/en/procedures-for-air-navigation-services-air-traffic-management-doc-4444).
It is document number 4444 published by ICAO, so is often referred to as _Doc 4444_.

Appendix 3 of PANS-ATM describes a number of messages employed for communicating flight information.
A subset of those specifically relate to flight planning:

| Message Type | Purpose |
| - | - |
| FPL | File a plan for an intended flight |
| DLA | Report a delay to a previously filed flight |
| CHG | Modify a previously filed flight plan |
| CNL | Cancel a planned flight |
| DEP | Report a flight has departed |
| ARR | Report a flight has arrived |

An example FPL message is:
```
(FPL-ABC123-IS
-B738/M-SADE2E3GHIRWZ/LB1
-YSSY0400
-M079F380 DCT WOL H65 RAZZI Q29 LIZZI DCT
-YMML0100
-PBN/A1B1C1D1O2S2T1 NAV/RNP2 DOF/230220 REG/VHXYZ SEL/AFPQ CODE/7C6DDF OPR/FLYOU ORGN/YSSYABCO PER/C)
```
Flight _ABC123_ is flying from _YSSY_ (Sydney) to _YMML_ (Melbourne) departing _0400_ on _20/2/2023_ with an
expected flight time of one hour. The aircraft is a Boeing 737-800 (_B738_). The text _WOL H65 RAZZI Q29 LIZZI DCT_
is a description of the route the flight will follow. The last line contains various pieces of additional information
such as the aircraft registration (_VHXYZ_).

A collection of numerically labelled fields are defined, each containing a subset of the information that relates to a flight.
Different messages are then defined by selecting the appropriate set of fields for
the purpose of the message. In the above FPL, those fields are:

| Field Number | Content |
| - | - |
| 7 | ABC123 |
| 8 | IS |
| 9 | B738/M |
| 10 | SADE2E3GHIRWZ/LB1 |
| 13 | YSSY0400 |
| 15 | M079F380 DCT WOL H65 RAZZI Q29 LIZZI DCT |
| 16 | YMML0100 |
| 18 | PBN/A1B1C1D1O2S2T1 NAV/RNP2 DOF/230220 REG/VHXYZ SEL/AFPQ CODE/7C6DDF OPR/FLYOU ORGN/YSSYABCO PER/C |

## The Specification

The specification is concerned with the processing of flight plan and related messages, and consists of:

- a model of the data elements, fields, flights and messages;
- definition of invariants on the flights and messages, which primarily capture consistency constraints between the different fields;
- the definition of a state that models a collection of flight information that might be held by a system;
- given a state and a received message, the specification of how a revised state is created from the supplied state and the message;
- some maintenance activities on the state;
- querying the state.

The model and program specification are contained in five modules:

| Module | Purpose |
| - | - |
| [Core](FPL/Core.md)       | The core data elements from which higher level entities are built |
| [Field](FPL/Field.md)     | The fields from which the messages are assembled |
| [Flight](FPL/Flight.md)   | Data entity capturing all information on a flight |
| [Message](FPL/Message.md) | The various messages employed for flight planning purposes |
| [State](FPL/State.md)     | The processing of messages with respect to a state |

These modules depend on the general purpose definitions in [Util](lib/Util.md), [Geo](lib/Geo.md) and [Temporal](lib/Temporal.md).
-/


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura, Sebastian Ullrich
-/
import Lean.Util.CollectFVars
import Lean.AuxRecursor
import Lean.Parser.Term
import Lean.Meta.RecursorInfo
import Lean.Meta.CollectMVars
import Lean.Meta.Tactic.ElimInfo
import Lean.Meta.Tactic.Induction
import Lean.Meta.Tactic.Cases
import Lean.Meta.GeneralizeVars
import Lean.Elab.App
import Lean.Elab.Tactic.ElabTerm
import Lean.Elab.Tactic.Generalize

namespace Lean.Elab.Tactic
open Meta

/-
  Given an `inductionAlt` of the form
  ```
  syntax inductionAltLHS := "| " (group("@"? ident) <|> hole) (ident <|> hole)*
  syntax inductionAlt  := ppDedent(ppLine) inductionAltLHS+ " => " (hole <|> syntheticHole <|> tacticSeq)
  ```
-/
private def getFirstAltLhs (alt : Syntax) : Syntax :=
  alt[0][0]
/-- Return `inductionAlt` name. It assumes `alt` does not have multiple `inductionAltLHS` -/
private def getAltName (alt : Syntax) : Name :=
  let lhs := getFirstAltLhs alt
  if !lhs[1].isOfKind ``Parser.Term.hole then lhs[1][1].getId.eraseMacroScopes else `_
/-- Returns the `inductionAlt` `ident <|> hole` -/
private def getAltNameStx (alt : Syntax) : Syntax :=
  let lhs := getFirstAltLhs alt
  if lhs[1].isOfKind ``Parser.Term.hole then lhs[1] else lhs[1][1]
/-- Return `true` if the first LHS of the given alternative contains `@`. -/
private def altHasExplicitModifier (alt : Syntax) : Bool :=
  let lhs := getFirstAltLhs alt
  !lhs[1].isOfKind ``Parser.Term.hole && !lhs[1][0].isNone
/-- Return the variables in the first LHS of the given alternative. -/
private def getAltVars (alt : Syntax) : Array Syntax :=
  let lhs := getFirstAltLhs alt
  lhs[2].getArgs
private def getAltRHS (alt : Syntax) : Syntax :=
  alt[2]
private def getAltDArrow (alt : Syntax) : Syntax :=
  alt[1]

-- Return true if `stx` is a term occurring in the RHS of the induction/cases tactic
def isHoleRHS (rhs : Syntax) : Bool :=
  rhs.isOfKind ``Parser.Term.syntheticHole || rhs.isOfKind ``Parser.Term.hole

def evalAlt (mvarId : MVarId) (alt : Syntax) (addInfo : TermElabM Unit) (remainingGoals : Array MVarId) : TacticM (Array MVarId) :=
  let rhs := getAltRHS alt
  withCaseRef (getAltDArrow alt) rhs do
    if isHoleRHS rhs then
      addInfo
      let gs' ← mvarId.withContext <| withRef rhs do
        let mvarDecl ← mvarId.getDecl
        let val ← elabTermEnsuringType rhs mvarDecl.type
        mvarId.assign val
        let gs' ← getMVarsNoDelayed val
        tagUntaggedGoals mvarDecl.userName `induction gs'.toList
        pure gs'
      return remainingGoals ++ gs'
    else
      setGoals [mvarId]
      closeUsingOrAdmit (withTacticInfoContext alt (addInfo *> evalTactic rhs))
      return remainingGoals

/-!
  Helper method for creating an user-defined eliminator/recursor application.
-/
namespace ElimApp

structure Alt where
  /-- The short name of the alternative, used in `| foo =>` cases -/
  name      : Name
  /-- A declaration corresponding to the inductive constructor.
  (For custom recursors, the alternatives correspond to parameter names in the
  recursor, so we may not have a declaration to point to.)
  This is used for go-to-definition on the alternative name. -/
  declName? : Option Name
  /-- The subgoal metavariable for the alternative. -/
  mvarId    : MVarId
  deriving Inhabited

structure Context where
  elimInfo : ElimInfo
  targets  : Array Expr -- targets provided by the user

structure State where
  argPos    : Nat := 0 -- current argument position
  targetPos : Nat := 0 -- current target at targetsStx
  f         : Expr
  fType     : Expr
  alts      : Array Alt := #[]
  insts     : Array MVarId := #[]

abbrev M := ReaderT Context $ StateRefT State TermElabM

private def addNewArg (arg : Expr) : M Unit :=
  modify fun s => { s with argPos := s.argPos+1, f := mkApp s.f arg, fType := s.fType.bindingBody!.instantiate1 arg }

/-- Return the binder name at `fType`. This method assumes `fType` is a function type. -/
private def getBindingName : M Name := return (← get).fType.bindingName!
/-- Return the next argument expected type. This method assumes `fType` is a function type. -/
private def getArgExpectedType : M Expr := return (← get).fType.bindingDomain!

private def getFType : M Expr := do
  let fType ← whnfForall (← get).fType
  modify fun s => { s with fType := fType }
  pure fType

structure Result where
  elimApp : Expr
  alts    : Array Alt := #[]
  others  : Array MVarId := #[]

/--
  Construct the an eliminator/recursor application. `targets` contains the explicit and implicit targets for
  the eliminator. For example, the indices of builtin recursors are considered implicit targets.
  Remark: the method `addImplicitTargets` may be used to compute the sequence of implicit and explicit targets
  from the explicit ones.
-/
partial def mkElimApp (elimInfo : ElimInfo) (targets : Array Expr) (tag : Name) : TermElabM Result := do
  let rec loop : M Unit := do
    match (← getFType) with
    | .forallE binderName _ _ c =>
      let ctx ← read
      let argPos := (← get).argPos
      if ctx.elimInfo.motivePos == argPos then
        let motive ← mkFreshExprMVar (← getArgExpectedType) MetavarKind.syntheticOpaque
        addNewArg motive
      else if ctx.elimInfo.targetsPos.contains argPos then
        let s ← get
        let ctx ← read
        unless s.targetPos < ctx.targets.size do
          throwError "insufficient number of targets for '{elimInfo.name}'"
        let target := ctx.targets[s.targetPos]!
        let expectedType ← getArgExpectedType
        let target ← withAssignableSyntheticOpaque <| Term.ensureHasType expectedType target
        modify fun s => { s with targetPos := s.targetPos + 1 }
        addNewArg target
      else match c with
        | .implicit =>
          let arg ← mkFreshExprMVar (← getArgExpectedType)
          addNewArg arg
        | .strictImplicit =>
          let arg ← mkFreshExprMVar (← getArgExpectedType)
          addNewArg arg
        | .instImplicit =>
          let arg ← mkFreshExprMVar (← getArgExpectedType) (kind := MetavarKind.synthetic) (userName := appendTag tag binderName)
          modify fun s => { s with insts := s.insts.push arg.mvarId! }
          addNewArg arg
        | _ =>
          let arg ← mkFreshExprSyntheticOpaqueMVar (← getArgExpectedType) (tag := appendTag tag binderName)
          let x   ← getBindingName
          modify fun s =>
            let declName? := elimInfo.altsInfo[s.alts.size]!.declName?
            { s with alts := s.alts.push ⟨x, declName?, arg.mvarId!⟩ }
          addNewArg arg
      loop
    | _ =>
      pure ()
  let f ← Term.mkConst elimInfo.name
  let fType ← inferType f
  let (_, s) ← (loop).run { elimInfo := elimInfo, targets := targets } |>.run { f := f, fType := fType }
  let mut others := #[]
  for mvarId in s.insts do
    try
      unless (← Term.synthesizeInstMVarCore mvarId) do
        mvarId.setKind .syntheticOpaque
        others := others.push mvarId
    catch _ =>
      mvarId.setKind .syntheticOpaque
      others := others.push mvarId
  let alts ← s.alts.filterM fun alt => return !(← alt.mvarId.isAssigned)
  return { elimApp := (← instantiateMVars s.f), alts, others := others }

/-- Given a goal `... targets ... |- C[targets]` associated with `mvarId`, assign
  `motiveArg := fun targets => C[targets]` -/
def setMotiveArg (mvarId : MVarId) (motiveArg : MVarId) (targets : Array FVarId) : MetaM Unit := do
  let type ← inferType (mkMVar mvarId)
  let motive ← mkLambdaFVars (targets.map mkFVar) type
  let motiverInferredType ← inferType motive
  let motiveType ← inferType (mkMVar motiveArg)
  unless (← isDefEqGuarded motiverInferredType motiveType) do
    throwError "type mismatch when assigning motive{indentExpr motive}\n{← mkHasTypeButIsExpectedMsg motiverInferredType motiveType}"
  motiveArg.assign motive

private def getAltNumFields (elimInfo : ElimInfo) (altName : Name) : TermElabM Nat := do
  for altInfo in elimInfo.altsInfo do
    if altInfo.name == altName then
      return altInfo.numFields
  throwError "unknown alternative name '{altName}'"

private def checkAltNames (alts : Array Alt) (altsSyntax : Array Syntax) : TacticM Unit :=
  for i in [:altsSyntax.size] do
    let altStx := altsSyntax[i]!
    if getAltName altStx == `_ && i != altsSyntax.size - 1 then
      withRef altStx <| throwError "invalid occurrence of wildcard alternative, it must be the last alternative"
    let altName := getAltName altStx
    if altName != `_ then
      unless alts.any (·.name == altName) do
        throwErrorAt altStx "invalid alternative name '{altName}'"

/-- Given the goal `altMVarId` for a given alternative that introduces `numFields` new variables,
    return the number of explicit variables. Recall that when the `@` is not used, only the explicit variables can
    be named by the user. -/
private def getNumExplicitFields (altMVarId : MVarId) (numFields : Nat) : MetaM Nat := altMVarId.withContext do
  let target ← altMVarId.getType
  withoutModifyingState do
    let (_, bis, _) ← forallMetaBoundedTelescope target numFields
    return bis.foldl (init := 0) fun r bi => if bi.isExplicit then r + 1 else r

private def saveAltVarsInfo (altMVarId : MVarId) (altStx : Syntax) (fvarIds : Array FVarId) : TermElabM Unit :=
  withSaveInfoContext <| altMVarId.withContext do
    let useNamesForExplicitOnly := !altHasExplicitModifier altStx
    let mut i := 0
    let altVars := getAltVars altStx
    for fvarId in fvarIds do
      if !useNamesForExplicitOnly || (← fvarId.getDecl).binderInfo.isExplicit then
        if i < altVars.size then
          Term.addLocalVarInfo altVars[i]! (mkFVar fvarId)
          i := i + 1

/--
  If `altsSyntax` is not empty we reorder `alts` using the order the alternatives have been provided
  in `altsSyntax`. Motivations:

  1- It improves the effectiveness of the `checkpoint` and `save` tactics. Consider the following example:
  ```lean
  example (h₁ : p ∨ q) (h₂ : p → x = 0) (h₃ : q → y = 0) : x * y = 0 := by
    cases h₁ with
    | inr h =>
      sleep 5000 -- sleeps for 5 seconds
      save
      have : y = 0 := h₃ h
      -- We can confortably work here
    | inl h => stop ...
  ```
  If we do reorder, the `inl` alternative will be executed first. Moreover, as we type in the `inr` alternative,
  type errors will "swallow" the `inl` alternative and affect the tactic state at `save` making it ineffective.

  2- The errors are produced in the same order the appear in the code above. This is not super important when using IDEs.
-/
def reorderAlts (alts : Array Alt) (altsSyntax : Array Syntax) : Array Alt := Id.run do
  if altsSyntax.isEmpty then
    return alts
  else
    let mut alts := alts
    let mut result := #[]
    for altStx in altsSyntax do
      let altName := getAltName altStx
      let some i := alts.findIdx? (·.1 == altName) | return result ++ alts
      result := result.push alts[i]!
      alts := alts.eraseIdx i
    return result ++ alts

def evalAlts (elimInfo : ElimInfo) (alts : Array Alt) (optPreTac : Syntax) (altsSyntax : Array Syntax)
    (initialInfo : Info)
    (numEqs : Nat := 0) (numGeneralized : Nat := 0) (toClear : Array FVarId := #[]) : TacticM Unit := do
  checkAltNames alts altsSyntax
  let hasAlts := altsSyntax.size > 0
  if hasAlts then
    -- default to initial state outside of alts
    -- HACK: because this node has the same span as the original tactic,
    -- we need to take all the info trees we have produced so far and re-nest them
    -- inside this node as well
    let treesSaved ← getResetInfoTrees
    withInfoContext ((modifyInfoState fun s => { s with trees := treesSaved }) *> go) (pure initialInfo)
  else go
where
  go := do
    let alts := reorderAlts alts altsSyntax
    let hasAlts := altsSyntax.size > 0
    let mut usedWildcard := false
    let mut subgoals := #[] -- when alternatives are not provided, we accumulate subgoals here
    let mut altsSyntax := altsSyntax
    for { name := altName, declName?, mvarId := altMVarId } in alts do
      let numFields ← getAltNumFields elimInfo altName
      let mut isWildcard := false
      let altStx? ←
        match altsSyntax.findIdx? (fun alt => getAltName alt == altName) with
        | some idx =>
          let altStx := altsSyntax[idx]!
          altsSyntax := altsSyntax.eraseIdx idx
          pure (some altStx)
        | none => match altsSyntax.findIdx? (fun alt => getAltName alt == `_) with
          | some idx =>
            isWildcard := true
            pure (some altsSyntax[idx]!)
          | none =>
            pure none
      match altStx? with
      | none =>
        let mut (_, altMVarId) ← altMVarId.introN numFields
        match (← Cases.unifyEqs? numEqs altMVarId {}) with
        | none   => pure () -- alternative is not reachable
        | some (altMVarId', _) =>
          (_, altMVarId) ← altMVarId'.introNP numGeneralized
          for fvarId in toClear do
            altMVarId ← altMVarId.tryClear fvarId
          let altMVarIds ← applyPreTac altMVarId
          if !hasAlts then
            -- User did not provide alternatives using `|`
            subgoals := subgoals ++ altMVarIds.toArray
          else if altMVarIds.isEmpty then
            pure ()
          else
            logError m!"alternative '{altName}' has not been provided"
            altMVarIds.forM fun mvarId => admitGoal mvarId
      | some altStx =>
        (subgoals, usedWildcard) ← withRef altStx do
          let altVars := getAltVars altStx
          let numFieldsToName ← if altHasExplicitModifier altStx then pure numFields else getNumExplicitFields altMVarId numFields
          if altVars.size > numFieldsToName then
            logError m!"too many variable names provided at alternative '{altName}', #{altVars.size} provided, but #{numFieldsToName} expected"
          let mut (fvarIds, altMVarId) ← altMVarId.introN numFields (altVars.toList.map getNameOfIdent') (useNamesForExplicitOnly := !altHasExplicitModifier altStx)
          -- Delay adding the infos for the pattern LHS because we want them to nest
          -- inside tacticInfo for the current alternative (in `evalAlt`)
          let addInfo := do
            if (← getInfoState).enabled then
              if let some declName := declName? then
                addConstInfo (getAltNameStx altStx) declName
              saveAltVarsInfo altMVarId altStx fvarIds
          let unusedAlt := do
            addInfo
            if isWildcard then
              pure (#[], usedWildcard)
            else
              throwError "alternative '{altName}' is not needed"
          match (← Cases.unifyEqs? numEqs altMVarId {}) with
          | none => unusedAlt
          | some (altMVarId', _) =>
            (_, altMVarId) ← altMVarId'.introNP numGeneralized
            for fvarId in toClear do
              altMVarId ← altMVarId.tryClear fvarId
            let altMVarIds ← applyPreTac altMVarId
            if altMVarIds.isEmpty then
              unusedAlt
            else
              let mut subgoals := subgoals
              for altMVarId' in altMVarIds do
                subgoals ← evalAlt altMVarId' altStx addInfo subgoals
              pure (subgoals, usedWildcard || isWildcard)
    if usedWildcard then
      altsSyntax := altsSyntax.filter fun alt => getAltName alt != `_
    unless altsSyntax.isEmpty do
      logErrorAt altsSyntax[0]! "unused alternative"
    setGoals subgoals.toList
  applyPreTac (mvarId : MVarId) : TacticM (List MVarId) :=
    if optPreTac.isNone then
      return [mvarId]
    else
      evalTacticAt optPreTac[0] mvarId

end ElimApp

/-
  Recall that
  ```
  generalizingVars := optional (" generalizing " >> many1 ident)
  «induction»  := leading_parser nonReservedSymbol "induction " >> majorPremise >> usingRec >> generalizingVars >> optional inductionAlts
  ```
  `stx` is syntax for `induction`. -/
private def getUserGeneralizingFVarIds (stx : Syntax) : TacticM (Array FVarId) :=
  withRef stx do
    let generalizingStx := stx[3]
    if generalizingStx.isNone then
      pure #[]
    else
      trace[Elab.induction] "{generalizingStx}"
      let vars := generalizingStx[1].getArgs
      getFVarIds vars

-- process `generalizingVars` subterm of induction Syntax `stx`.
private def generalizeVars (mvarId : MVarId) (stx : Syntax) (targets : Array Expr) : TacticM (Nat × MVarId) :=
  mvarId.withContext do
    let userFVarIds ← getUserGeneralizingFVarIds stx
    let forbidden ← mkGeneralizationForbiddenSet targets
    let mut s ← getFVarSetToGeneralize targets forbidden
    for userFVarId in userFVarIds do
      if forbidden.contains userFVarId then
        throwError "variable cannot be generalized because target depends on it{indentExpr (mkFVar userFVarId)}"
      if s.contains userFVarId then
        throwError "unnecessary 'generalizing' argument, variable '{mkFVar userFVarId}' is generalized automatically"
      s := s.insert userFVarId
    let fvarIds ← sortFVarIds s.toArray
    let (fvarIds, mvarId') ← mvarId.revert fvarIds
    return (fvarIds.size, mvarId')

/--
Given `inductionAlts` of the fom
```
syntax inductionAlts := "with " (tactic)? withPosition( (colGe inductionAlt)+)
```
Return an array containing its alternatives.
-/
private def getAltsOfInductionAlts (inductionAlts : Syntax) : Array Syntax :=
  inductionAlts[2].getArgs

private def getAltsOfOptInductionAlts (optInductionAlts : Syntax) : Array Syntax :=
  if optInductionAlts.isNone then #[] else getAltsOfInductionAlts optInductionAlts[0]

private def getOptPreTacOfOptInductionAlts (optInductionAlts : Syntax) : Syntax :=
  if optInductionAlts.isNone then mkNullNode else optInductionAlts[0][1]

private def isMultiAlt (alt : Syntax) : Bool :=
  alt[0].getNumArgs > 1

/-- Return `some #[alt_1, ..., alt_n]` if `alt` has multiple LHSs. -/
private def expandMultiAlt? (alt : Syntax) : Option (Array Syntax) := Id.run do
  if isMultiAlt alt then
    some <| alt[0].getArgs.map fun lhs => alt.setArg 0 (mkNullNode #[lhs])
  else
    none

/--
Given `inductionAlts` of the form
```
syntax inductionAlts := "with " (tactic)? withPosition( (colGe inductionAlt)+)
```
Return `some inductionAlts'` if one of the alternatives have multiple LHSs, in the new `inductionAlts'`
all alternatives have a single LHS.

Remark: the `RHS` of alternatives with multi LHSs is copied.
-/
private def expandInductionAlts? (inductionAlts : Syntax) : Option Syntax := Id.run do
  let alts := getAltsOfInductionAlts inductionAlts
  if alts.any isMultiAlt then
    let mut altsNew := #[]
    for alt in alts do
      if let some alt' := expandMultiAlt? alt then
        altsNew := altsNew ++ alt'
      else
        altsNew := altsNew.push alt
    some <| inductionAlts.setArg 2 (mkNullNode altsNew)
  else
    none

/--
Expand
```
syntax "induction " term,+ (" using " ident)?  ("generalizing " (colGt term:max)+)? (inductionAlts)? : tactic
```
if `inductionAlts` has an alternative with multiple LHSs.
-/
private def expandInduction? (induction : Syntax) : Option Syntax := do
  let optInductionAlts := induction[4]
  guard <| !optInductionAlts.isNone
  let inductionAlts' ← expandInductionAlts? optInductionAlts[0]
  return induction.setArg 4 (mkNullNode #[inductionAlts'])

/--
Expand
```
syntax "cases " casesTarget,+ (" using " ident)? (inductionAlts)? : tactic
```
if `inductionAlts` has an alternative with multiple LHSs.
-/
private def expandCases? (induction : Syntax) : Option Syntax := do
  let optInductionAlts := induction[3]
  guard <| !optInductionAlts.isNone
  let inductionAlts' ← expandInductionAlts? optInductionAlts[0]
  return induction.setArg 3 (mkNullNode #[inductionAlts'])

/--
  We may have at most one `| _ => ...` (wildcard alternative), and it must not set variable names.
  The idea is to make sure users do not write unstructured tactics. -/
private def checkAltsOfOptInductionAlts (optInductionAlts : Syntax) : TacticM Unit :=
  unless optInductionAlts.isNone do
    let mut found := false
    for alt in getAltsOfInductionAlts optInductionAlts[0] do
      let n := getAltName alt
      if n == `_ then
        unless (getAltVars alt).isEmpty do
          throwErrorAt alt "wildcard alternative must not specify variable names"
        if found then
          throwErrorAt alt "more than one wildcard alternative '| _ => ...' used"
        found := true

def getInductiveValFromMajor (major : Expr) : TacticM InductiveVal :=
  liftMetaMAtMain fun mvarId => do
    let majorType ← inferType major
    let majorType ← whnf majorType
    matchConstInduct majorType.getAppFn
      (fun _ => Meta.throwTacticEx `induction mvarId m!"major premise type is not an inductive type {indentExpr majorType}")
      (fun val _ => pure val)

-- `optElimId` is of the form `("using" ident)?`
private def getElimNameInfo (optElimId : Syntax) (targets : Array Expr) (induction : Bool): TacticM ElimInfo := do
  if optElimId.isNone then
    if let some elimInfo ← getCustomEliminator? targets then
      return elimInfo
    unless targets.size == 1 do
      throwError "eliminator must be provided when multiple targets are used (use 'using <eliminator-name>'), and no default eliminator has been registered using attribute `[eliminator]`"
    let indVal ← getInductiveValFromMajor targets[0]!
    if induction && indVal.all.length != 1 then
      throwError "'induction' tactic does not support mutually inductive types, the eliminator '{mkRecName indVal.name}' has multiple motives"
    if induction && indVal.isNested then
      throwError "'induction' tactic does not support nested inductive types, the eliminator '{mkRecName indVal.name}' has multiple motives"
    let elimName := if induction then mkRecName indVal.name else mkCasesOnName indVal.name
    getElimInfo elimName indVal.name
  else
    let elimId := optElimId[1]
    let elimName ← withRef elimId do resolveGlobalConstNoOverloadWithInfo elimId
    -- not a precise check, but covers the common cases of T.recOn / T.casesOn
    -- as well as user defined T.myInductionOn to locate the constructors of T
    let baseName? := if ← isInductive elimName.getPrefix then some elimName.getPrefix else none
    withRef elimId <| getElimInfo elimName baseName?

private def shouldGeneralizeTarget (e : Expr) : MetaM Bool := do
  if let .fvar fvarId .. := e then
    return (←  fvarId.getDecl).hasValue -- must generalize let-decls
  else
    return true

private def generalizeTargets (exprs : Array Expr) : TacticM (Array Expr) := do
  if (← withMainContext <| exprs.anyM (shouldGeneralizeTarget ·)) then
    liftMetaTacticAux fun mvarId => do
      let (fvarIds, mvarId) ← mvarId.generalize (exprs.map fun expr => { expr })
      return (fvarIds.map mkFVar, [mvarId])
  else
    return exprs

@[builtin_tactic Lean.Parser.Tactic.induction] def evalInduction : Tactic := fun stx =>
  match expandInduction? stx with
  | some stxNew => withMacroExpansion stx stxNew <| evalTactic stxNew
  | _ => focus do
    let optInductionAlts := stx[4]
    let alts := getAltsOfOptInductionAlts optInductionAlts
    let targets ← withMainContext <| stx[1].getSepArgs.mapM (elabTerm · none)
    let targets ← generalizeTargets targets
    let elimInfo ← withMainContext <| getElimNameInfo stx[2] targets (induction := true)
    let mvarId ← getMainGoal
    -- save initial info before main goal is reassigned
    let initInfo ← mkTacticInfo (← getMCtx) (← getUnsolvedGoals) (← getRef)
    let tag ← mvarId.getTag
    mvarId.withContext do
      let targets ← addImplicitTargets elimInfo targets
      checkTargets targets
      let targetFVarIds := targets.map (·.fvarId!)
      let (n, mvarId) ← generalizeVars mvarId stx targets
      mvarId.withContext do
        let result ← withRef stx[1] do -- use target position as reference
          ElimApp.mkElimApp elimInfo targets tag
        trace[Elab.induction] "elimApp: {result.elimApp}"
        let elimArgs := result.elimApp.getAppArgs
        ElimApp.setMotiveArg mvarId elimArgs[elimInfo.motivePos]!.mvarId! targetFVarIds
        let optPreTac := getOptPreTacOfOptInductionAlts optInductionAlts
        mvarId.assign result.elimApp
        ElimApp.evalAlts elimInfo result.alts optPreTac alts initInfo (numGeneralized := n) (toClear := targetFVarIds)
        appendGoals result.others.toList
where
  checkTargets (targets : Array Expr) : MetaM Unit := do
    let mut foundFVars : FVarIdSet := {}
    for target in targets do
      unless target.isFVar do
        throwError "index in target's type is not a variable (consider using the `cases` tactic instead){indentExpr target}"
      if foundFVars.contains target.fvarId! then
        throwError "target (or one of its indices) occurs more than once{indentExpr target}"

def elabCasesTargets (targets : Array Syntax) : TacticM (Array Expr) :=
  withMainContext do
    let args ← targets.mapM fun target => do
      let hName? := if target[0].isNone then none else some target[0][0].getId
      let expr ← elabTerm target[1] none
      return { expr, hName? : GeneralizeArg }
    if (← withMainContext <| args.anyM fun arg => shouldGeneralizeTarget arg.expr <||> pure arg.hName?.isSome) then
      liftMetaTacticAux fun mvarId => do
        let argsToGeneralize ← args.filterM fun arg => shouldGeneralizeTarget arg.expr <||> pure arg.hName?.isSome
        let (fvarIdsNew, mvarId) ← mvarId.generalize argsToGeneralize
        let mut result := #[]
        let mut j := 0
        for arg in args do
          if (← shouldGeneralizeTarget arg.expr) || arg.hName?.isSome then
            result := result.push (mkFVar fvarIdsNew[j]!)
            j := j+1
          else
            result := result.push arg.expr
        return (result, [mvarId])
    else
      return args.map (·.expr)

@[builtin_tactic Lean.Parser.Tactic.cases] def evalCases : Tactic := fun stx =>
  match expandCases? stx with
  | some stxNew => withMacroExpansion stx stxNew <| evalTactic stxNew
  | _ => focus do
    -- leading_parser nonReservedSymbol "cases " >> sepBy1 (group majorPremise) ", " >> usingRec >> optInductionAlts
    let targets ← elabCasesTargets stx[1].getSepArgs
    let optInductionAlts := stx[3]
    let optPreTac := getOptPreTacOfOptInductionAlts optInductionAlts
    let alts :=  getAltsOfOptInductionAlts optInductionAlts
    let targetRef := stx[1]
    let elimInfo ← withMainContext <| getElimNameInfo stx[2] targets (induction := false)
    let mvarId ← getMainGoal
    -- save initial info before main goal is reassigned
    let initInfo ← mkTacticInfo (← getMCtx) (← getUnsolvedGoals) (← getRef)
    let tag ← mvarId.getTag
    mvarId.withContext do
      let targets ← addImplicitTargets elimInfo targets
      let result ← withRef targetRef <| ElimApp.mkElimApp elimInfo targets tag
      let elimArgs := result.elimApp.getAppArgs
      let targets ← elimInfo.targetsPos.mapM fun i => instantiateMVars elimArgs[i]!
      let motiveType ← inferType elimArgs[elimInfo.motivePos]!
      let mvarId ← generalizeTargetsEq mvarId motiveType targets
      let (targetsNew, mvarId) ← mvarId.introN targets.size
      mvarId.withContext do
        ElimApp.setMotiveArg mvarId elimArgs[elimInfo.motivePos]!.mvarId! targetsNew
        mvarId.assign result.elimApp
        ElimApp.evalAlts elimInfo result.alts optPreTac alts initInfo (numEqs := targets.size) (toClear := targetsNew)

builtin_initialize
  registerTraceClass `Elab.cases
  registerTraceClass `Elab.induction

end Lean.Elab.Tactic


import meta_k.meta_sort
import meta_k.meta_var
import meta_k.meta_symbol
import meta_k.meta_pattern
import object_k.object_symbol
import object_k.object_pattern
import meta_k.sort_schemas
import meta_k.symbol_schemas

/-

This file contains a definition of the 'working example' matching logic
theory described in chapter 8 of the "Semantics of K" document for illustration
purposes.
Notation used that differs from that in the document is
1) the use of tilde (~) as a prefix for object theory elements (like # for meta)m
2) the ↑ up arrow is used to cast one type into another in a way that
    is explicit. Matching Logic is based on many-sorted logic, and there are
    implicit transofrmations happening all over the place, which is daunting for
    the uninitiated, so I've made them explicit lifts instead of implicit coercions.
3) The modified logical connective notation corresponds to its matching logic pattern
   counterpart. IE #∧ is the #and pattern, ~s~> is implication parameterized by sort s, etc.

For the purposes of chapter 8, the definition of T here can just be thought of as the
items in scope.
The constructions and lifting used in chapters 7 and 8 are also surprisingly different
from thos used in Kore; Symbols become 'head' objects, pattern constructions are all
made into independent production rules, and they object pattern/meta pattern constructors
are parametric across all patterns, and the lifting process between object theory
elements and meta theory elements is altered.

-/

-- object sort definition of Nat
def Nat : object_sort := ~sort ⟨"Nat"⟩ ~nilSortList

-- object sort definition of List{Nat}
def List_Nat : object_sort := ~sort ⟨"List"⟩ ↑[~sort ⟨"Nat"⟩ ~nilSortList]

-- specification of lift for sorts as defined in 8.3
mutual def lift_object_sort, lift_object_sort_list
with lift_object_sort : object_sort → meta_sort
| (object_sort.mk ident object_sort_list.nil) := #sort (repr ident) #nilSortList
| (object_sort.mk ident L) := #sort (repr ident) (lift_object_sort_list L)
with lift_object_sort_list : object_sort_list → meta_sort_list
| (object_sort_list.nil) := #nilSortList
| (object_sort_list.cons hd tl) := #consSortList (lift_object_sort hd) (lift_object_sort_list tl)

instance : has_lift object_sort meta_sort := ⟨ lift_object_sort ⟩
instance : has_lift object_sort_list meta_sort_list := ⟨ lift_object_sort_list ⟩

def meta_Nat : meta_sort := ↑Nat
def meta_List_Nat : meta_sort := ↑List_Nat

-- evaluation of lifting process from 8.3 on Nat and List_Nat; VM evaluation
-- will show that they come out to
-- #sort "Nat" ε
-- #sort "List" [#sort "Nat" ε]
-- respectively
#eval meta_Nat
#eval meta_List_Nat

-- The literal definition of the sort helper functions for #'Nat and #'List
-- given in 8.3 would be these two functions.
def nat_meta_rep : #Sort := #sort "Nat" #nilSortList
notation `#'Nat` := nat_meta_rep

def list_meta_rep : #Sort → #Sort
| s := #sort "List" ↑[s]
notation `#'List` := list_meta_rep

-- The axioms which define them intensionally in matching logic would be as follows,
-- so we add these patterns to our theory T.
def nat_constructor_axiom : #Pattern :=
    let s1 := #'Nat,
        s2 := #sort "Nat" #nilSortList
    in (↑s1 #= (s1, s2); ↑s2)

def list_constructor_axiom {carrier s : #Sort} : #Pattern :=
   let s1 := #'List s,
       s2 := #sort "List" ↑[s]
    in #∀carrier, "s" : %Sort . (↑s1) #= (s1, s2); (↑s2)

-- axiom schema about definedness of list parameters; for any sort s,
-- if s is defined in the current theory, that implies that the sort List s
-- is therefore defined.
def list_axiom_schema {carrier s : #Sort} {L : #SortList}: #Pattern :=
    #∀carrier, "s" : %Sort .
        (#apply (#symbol "sortDeclared" [%Sort] [%Sort, %SortList] %Sort) . [↑s, ↑L])
        ~carrier~>
        (#apply (#symbol "sortDeclared" [%Sort] [%Sort, %SortList] %Sort) . [↑(#'List s), ↑L])

-- Generic function to lift object symbol declarations into meta theory
-- based on specification in chapter 8. Uses already defined lifts for sort.
def object_symbol_lift_to_meta : object_symbol → meta_symbol
| (~symbol ident params args ret) :=
    #symbol (name_fn ident) ↑params ↑args ↑ret

instance : has_lift object_symbol meta_symbol := ⟨ object_symbol_lift_to_meta ⟩

def object_nat_zero : ~Symbol := ~symbol "O" [] [] Nat
def meta_nat_zero : #Symbol := #symbol "zero" [] [] #'Nat
notation `~O` := object_nat_zero

-- definition of object theory's 'zero' symbol in meta theory
-- is as follows; #eval shows that the version produced by the
-- lifting function is identical.
def zeros_eq : bool := ↑object_nat_zero = meta_nat_zero
#eval zeros_eq

def object_nat_succ : ~Symbol := ~symbol "succ" [] [Nat] Nat
def meta_nat_succ : #Symbol := #symbol "succ" [] [#'Nat] #'Nat

def succs_eq : bool := ↑object_nat_succ = meta_nat_succ
#eval succs_eq

def object_nat_plus : ~Symbol := ~symbol "+" [] [Nat, Nat] Nat
def meta_nat_plus : #Symbol := #symbol "plus" [] [#'Nat, #'Nat] #'Nat
notation `~+` := object_nat_plus

def pluses_eq : bool := ↑object_nat_plus = meta_nat_plus
#eval pluses_eq

def object_list_nat_nil : ~Symbol := ~symbol "ε" [Nat] [] (List_Nat)
def meta_list_nat_nil : #Symbol := #symbol "nil" [#'Nat] [] (#'List(#'Nat))

def nils_eq : bool := ↑object_list_nat_nil = meta_list_nat_nil
#eval nils_eq

def object_list_nat_cons : ~Symbol := ~symbol "::" [Nat] [Nat, List_Nat] (List_Nat)
def meta_list_nat_cons : #Symbol := #symbol "cons" [#'Nat] [#'Nat, #'List(#'Nat)] (#'List(#'Nat))

-- parametric list symbols
def meta_list_nil : #Sort → #Symbol
| s := #symbol "nil" [%Sort] [] (#'List s)
notation `#'nil` := meta_list_nil

def meta_list_cons : #Sort → #Symbol
| s := #symbol "cons" [%Sort] [s, #'List s] (#'List s)
notation `#'cons` := meta_list_cons

def meta_list_append : #Sort → #Symbol
| s := #symbol "append" [%Sort] [#'List s, #'List s] (#'List s)
notation `#'append` := meta_list_append

def cons_eq : bool := ↑object_list_nat_cons = meta_list_nat_cons
#eval cons_eq

def object_list_nat_append : ~Symbol := ~symbol "@" [Nat] [List_Nat, List_Nat] (List_Nat)
def meta_list_nat_append : #Symbol := #symbol "append" [#'Nat] [#'List(#'Nat), #'List(#'Nat)] (#'List(#'Nat))
notation `#'append` := meta_list_nat_append

def append_eq : bool := ↑object_list_nat_append = meta_list_nat_append
#eval append_eq

def symbol_declared_pred {s : #Sort} := #symbol "symbolDeclared" [%Sort] [%Symbol, %SymbolList] %Pattern
def sort_declared_pred   {s : #Sort} := #symbol "sortDeclared" [%Sort] [%Sort, %SortList] %Pattern
def sorts_declared_pred  {s : #Sort} := #symbol "sortsDeclared" [%Sort] [%SortList, %SortList] %Pattern
def axiom_declared_pred  {s : #Sort} := #symbol "axiomDeclared" [%Sort] [%Pattern, %PatternList] %Pattern

-- for any #s : Sort in T, the meta representation of the nat zero symbol
-- is declared, but not for any other sorts.
-- object_nat_zero gets lifted to meta_symbol, then to meta_pattern to
-- satisfy the specification.
def non_parametric_axiom1 {«#s» : #Sort} {L : #SymbolList }: #Pattern :=
    #apply (@symbol_declared_pred «#s») . [↑object_nat_zero, ↑L]

-- for any #s : Sort in T, the meta representation of succ is declared,
-- but not for any others.
def non_parametric_axiom2 {«#s» : #Sort} {L : #SymbolList} : #Pattern :=
    #apply (@symbol_declared_pred «#s»)  . [↑object_nat_succ, ↑L]

def non_parametric_axiom3 {«#s» : #Sort} {L : #SymbolList} : #Pattern :=
    #apply (@symbol_declared_pred «#s»)  . [↑object_nat_plus, ↑L]

def parametric_axiom1 {«#s» s  : #Sort} {LS : #SortList} {LSy : #SymbolList} : #Pattern :=
    (#apply (@sort_declared_pred «#s») . [↑s, ↑LS])
    ~s~>
    (#apply (@symbol_declared_pred «#s») . [↑object_list_nat_nil, ↑LSy])

def parametric_axiom2 {«#s» s : #Sort} {LS : #SortList} {LSy : #SymbolList} : #Pattern :=
    (#apply (@sort_declared_pred «#s») . [↑s, ↑LS])
    ~s~>
    (#apply (@symbol_declared_pred «#s») . [↑object_list_nat_cons, ↑LSy])

def parametric_axiom3 {«#s» s : #Sort} {LS : #SortList} {LSy : #SymbolList} : #Pattern :=
    (#apply (@sort_declared_pred «#s») . [↑s, ↑LS])
    ~s~>
    (#apply (@symbol_declared_pred «#s») . [↑object_list_nat_append, ↑LSy])

def object_variable_lift_meta : ~Variable → #Variable
| (~variable ident s) := #variable (name_fn ident) (↑s)

instance : has_lift object_variable meta_variable := ⟨ object_variable_lift_meta ⟩

open object_pattern
open meta_pattern

mutual def object_pattern_lift_meta, object_pattern_list_lift_meta
with object_pattern_lift_meta : ~Pattern → #Pattern
| (~variableAsPattern v) := #variableAsPattern ↑v
| (object_application σ L) := #apply ↑σ  . (object_pattern_list_lift_meta L)
| (object_and s φ1 φ2) := meta_and ↑s (object_pattern_lift_meta φ1) (object_pattern_lift_meta φ2)
| (object_not s φ) := meta_not ↑s (object_pattern_lift_meta φ)
| (object_exsts s v φ) := meta_exsts ↑s ↑v (object_pattern_lift_meta φ)
with object_pattern_list_lift_meta : ~PatternList → #PatternList
| [] := []
| (hd :: tl) := object_pattern_lift_meta hd :: (object_pattern_list_lift_meta tl)

instance object_pattern_to_meta_pattern_lift : has_lift object_pattern meta_pattern := ⟨ object_pattern_lift_meta ⟩

def object_nat_var : ~Variable := ⟨ "x", Nat ⟩
def meta_nat_var : #Variable := ⟨ "x", #'Nat ⟩
#eval ((((↑object_nat_var) : #Pattern) = (↑meta_nat_var))  : bool)

-- for any x : Nat, x + O is equal to x
-- extremely verbose version to clarify what's going on.
def object_aux_axiom1_verbose {c s' : ~Sort} : ~Pattern :=
    ~∀c, "x" : Nat . ((~apply (~symbol "+" [] [Nat, Nat] Nat) . [(~variableAsPattern ⟨"x", Nat⟩), ↑(~symbol "O" [] [] Nat)]) ~= (Nat, s'); (~variableAsPattern ⟨"x", Nat⟩))

-- more comfortable version
def object_aux_axiom1 {c s' : ~Sort} : ~Pattern :=
    let x : ~Variable := ⟨ "x", Nat ⟩
    in ~∀c, x . ((~apply ~+ . [↑x, ↑~O]) ~= (Nat, s'); (↑x))

def meta_aux_axiom1 {c s' : #Sort} : #Pattern :=
    let x : #Variable := #variable "x" #'Nat
    in #∀c, x . ((#apply meta_nat_plus . [↑x, ↑meta_nat_zero]) #= (#'Nat, s'); (↑x))

def a_lift : #Pattern := ↑(@object_aux_axiom1 object_sort.inhabited.default object_sort.inhabited.default)
#eval a_lift

-- example of naming helper functions given on p. 49-50, allowing
-- #'zero to be used in place of the longer 'raw' representation
def «#'zero» : #Symbol := #symbol "zero" [] [] #'Nat
def zero_axiom {«#s» : #Sort} : #Pattern :=
    ↑«#'zero» #= (#'Nat, «#s»); #apply (#symbol "zero" [] [] #'Nat) . []

def «#'nil» : #Sort → #Symbol
| s := #symbol "nil" [%Sort] [] s

def nil_axiom {«#s» : #Sort} : #Sort → #Pattern
| s' := #∀«#s», "s'" : s' . ↑(«#'nil» s') #= (s', «#s»); #apply (#symbol "nil" [%Sort] [] s') . []

def Ψ1 {s' : #Sort} : #Pattern :=
    (#apply (#symbol "#'plus" [] [#'Nat, #'Nat] #'Nat) . [#variableAsPattern ⟨ "x", #'Nat⟩, ↑«#'zero»])
    #= (#'Nat, s');
    (#variableAsPattern ⟨ "x", #'Nat ⟩)

-- append(s) (x :: L0) (L) == x :: (L0 ++ L)
def Ψ2 {s s' : #Sort} : #Pattern :=
    (#apply (#'append s) . [(#apply (#'cons s) . [#variableAsPattern ⟨"L0", (#'List s)⟩]), (#variableAsPattern ⟨"L", (#'List s)⟩) ])
    #= (#'List s, s');
    (#apply (#'cons s) . [(#apply (#'append s) . [#variableAsPattern ⟨"L0", (#'List s)⟩, #variableAsPattern ⟨"L", (#'List s)⟩]) ])

def axiom_Ψ1 {«#s» s s' : #Sort} {Ss : #SortList} {φs : #PatternList} : #Pattern :=
    #∀«#s», "s'" : %Sort . (#apply (@sort_declared_pred «#s») . [↑s'])
    ~«#s»~>
    (#apply (@axiom_declared_pred «#s») . [@Ψ1 s'])

def axiom_Ψ2 {«#s» s s' : #Sort} {Ss : #SortList} {φs : #PatternList} : #Pattern :=
    #∀«#s», "s'" : %Sort . ((#apply (@sort_declared_pred «#s») . [↑s])
                            #∧(s'); (#apply (@sort_declared_pred «#s») . [↑s']))
                            ~«#s»~>
                            (#apply (@axiom_declared_pred «#s») . [@Ψ2 s s'])


import data.list.basic   -- basic operations on `list`
import data.option.basic -- basic operations on `option`
import data.set.basic
import data.vector
import data.vector2
import logic.function    -- function update and inverses
import aux

namespace parlang
variables {n : ℕ} {σ : Type} {ι : Type} {τ : ι → Type} [decidable_eq ι]

/-
We use the following conventions for type variables:

 `σ` -- thread internal states
 `ι` -- shared memory index
 `τ` -- shared memory type map

-/

/-- Kernel of a parallel program.

The general idea is to not have explicit expressions, but use Lean functions to compute values. What
we are explicit shared loads and stores.

Σ is constructor where the second argument may depend on the type of the first (in this case i). Can be constructed using ⟨...⟩
-/
inductive kernel {ι : Type} (σ : Type) (τ : ι → Type) : Type
| load       : (σ → (Σi:ι, (τ i → σ))) → kernel
| store      : (σ → (Σi:ι, τ i)) → kernel
| compute {} : (σ → σ) → kernel
| seq        : kernel → kernel → kernel
| ite        : (σ → bool) → kernel → kernel → kernel
| loop       : (σ → bool) → kernel → kernel
| sync {}    : kernel

infixr ` ;; `:90 := kernel.seq
open kernel

/-- Memory view -/
def memory {ι : Type} (τ : ι → Type) := Π (i : ι), τ i

namespace memory

def get (m : memory τ) (i : ι) : τ i := m i

def update (m : memory τ) (i : ι) (v : τ i) : memory τ := function.update m i v

end memory

/-- Thread state inclusing a shared memory *view*, the list of loads and stores tells what should
differ between differnet threads. -/
structure thread_state {ι : Type} (σ : Type) (τ : ι → Type) : Type :=
(tlocal : σ)
(shared : memory τ)
(loads  : set ι := ∅)
(stores : set ι := ∅)

namespace thread_state

def load (f : σ → (Σi:ι, (τ i → σ))) (t : thread_state σ τ) : thread_state σ τ :=
let ⟨i, tr⟩ := f t.tlocal in
{ tlocal := tr (t.shared.get i),
  loads := insert i t.loads,
  .. t }

def store (f : σ → (Σi:ι, τ i)) (t : thread_state σ τ) : thread_state σ τ :=
let ⟨i, v⟩ := f t.tlocal in
{ shared := t.shared.update i v,
  stores := insert i t.stores,
  .. t}

def compute (f : σ → σ) (t : thread_state σ τ) : thread_state σ τ :=
{ tlocal := f t.tlocal,
  .. t}

def sync (g : memory τ) (t : thread_state σ τ) : thread_state σ τ :=
{ shared := g,
  loads := ∅,
  stores := ∅,
  .. t}

def accesses (t : thread_state σ τ) : set ι := t.stores ∪ t.loads

end thread_state

def no_thread_active (ac : vector bool n) : bool := ¬ac.to_list.any id
def any_thread_active (ac : vector bool n) : bool := ac.to_list.any id
def all_threads_active (ac : vector bool n) : bool := ac.to_list.all id
/-- thread can only be active either in ac₁ or ac₂ -/
def ac_distinct (ac₁ ac₂ : vector bool n) : Prop := ∀ (i : fin n), ac₁.nth i = ff ∨ ac₂.nth i = ff

def ac_ge (ac' : vector bool n) (ac : vector bool n) : Prop := ∀ (t : fin n), ¬ (ac.nth t) → ¬ (ac'.nth t)
instance : has_le (vector bool n) := ⟨ac_ge⟩

/-- shared program state -/
structure state {ι : Type} (n : ℕ) (σ : Type) (τ : ι → Type) : Type :=
(threads : vector (thread_state σ τ) n)

namespace state

def map_threads (f : thread_state σ τ → thread_state σ τ) (s : state n σ τ) : state n σ τ :=
{ threads := s.threads.map f, ..s }

-- we generally don't want to unfold this if possible
-- this would for example happen when you do cases in (exec_state (compute f) ...)
-- TODO: rename this to mat? It would shorten a lot of names
@[irreducible]
def map_active_threads (ac : vector bool n) (f : thread_state σ τ → thread_state σ τ) (s : state n σ τ) : state n σ τ :=
{ threads := (s.threads.map₂ (λ t (a : bool), if a then f t else t) ac), ..s }

def active_threads (ac : vector bool n) (s : state n σ τ) : list (thread_state σ τ) :=
((s.threads.map₂ prod.mk ac).to_list.filter (λ c : (thread_state σ τ × bool), c.2)).map (λ ⟨t, a⟩, t)

-- case 1: no thread changed ι and shadows must be equal at ι
-- case 2: thread t changed ι and all other threads must not access ι
def syncable (s : state n σ τ) (m : memory τ) : Prop :=
∀i:ι,
  (∀ tid, i ∉ (s.threads.nth tid).stores ∧ m i = (s.threads.nth tid).shared i) ∨
  (∃ tid, i ∈ (s.threads.nth tid).stores ∧ m i = (s.threads.nth tid).shared i ∧
    (∀ tid', tid ≠ tid' → i ∉ (s.threads.nth tid').accesses))

def precedes (s u : state n σ τ) : Prop :=
∀ (t : thread_state σ τ × thread_state σ τ), t ∈ (s.threads.map₂ prod.mk u.threads) → t.1.stores ⊆ t.2.stores ∧ t.1.loads ⊆ t.2.loads

end state

/-- If condition *f* evaluates to *tt*, the thread is deactivated -/
@[irreducible]
def deactivate_threads (f : σ → bool) (ac : vector bool n) (s : state n σ τ) : vector bool n :=
ac.map₂ (λ a (ts : thread_state σ τ), (bnot ∘ f) ts.tlocal && a) s.threads

def subkernel (q : kernel σ τ) : kernel σ τ → Prop
| (seq k₁ k₂) := k₁ = q ∨ k₂ = q ∨ subkernel k₁ ∨ subkernel k₂
| (ite c th el) := th = q ∨ el = q ∨ subkernel th ∨ subkernel el
| (loop c body) := body = q ∨ subkernel body
| k := k = q

/-- Execute a kernel on a shared state, i.e. a list of threads -/
inductive exec_state {n : ℕ} : kernel σ τ → vector bool n → state n σ τ → state n σ τ → Prop
| load (f) (s : state n σ τ) (ac : vector bool n) :
  exec_state (load f) ac s (s.map_active_threads ac $ thread_state.load f)
| store (f) (s : state n σ τ) (ac : vector bool n) :
  exec_state (store f) ac s (s.map_active_threads ac $ thread_state.store f)
| compute (f : σ → σ) (s : state n σ τ) (ac : vector bool n) :
  exec_state (compute f) ac s (s.map_active_threads ac $ thread_state.compute f)
| sync_all (s : state n σ τ) (ac : vector bool n) (m : memory τ) (hs : s.syncable m)
  (ha : all_threads_active ac) :
  exec_state sync ac s (s.map_threads $ thread_state.sync m)
| sync_none (s : state n σ τ) (ac : vector bool n) (h : no_thread_active ac) :
  exec_state sync ac s s
| seq (s t u : state n σ τ) (ac : vector bool n) (k₁ k₂ : kernel σ τ) :
  exec_state k₁ ac s t → exec_state k₂ ac t u → exec_state (seq k₁ k₂) ac s u
  -- in the then-branch we deactivate the threads where the condition is false and similar for else
| ite (s t u : state n σ τ) (ac : vector bool n) (f : σ → bool) (k₁ k₂ : kernel σ τ) :
  exec_state k₁ (deactivate_threads (bnot ∘ f) ac s) s t →
  exec_state k₂ (deactivate_threads f ac s) t u →
  exec_state (ite f k₁ k₂) ac s u
| loop_stop (s : state n σ τ) (ac : vector bool n) (f : σ → bool) (k : kernel σ τ) :
  no_thread_active (deactivate_threads (bnot ∘ f) ac s) →
  exec_state (loop f k) ac s s
| loop_step (s t u : state n σ τ) (ac : vector bool n) (f : σ → bool) (k : kernel σ τ) :
  any_thread_active (deactivate_threads (bnot ∘ f) ac s) →
  exec_state k (deactivate_threads (bnot ∘ f) ac s) s t →
  exec_state (loop f k) (deactivate_threads (bnot ∘ f) ac s) t u →
  exec_state (loop f k) ac s u

def kernel_transform_func (k) (f) (n) (ac) : Prop := ∀ (s u : state n σ τ), exec_state k ac s u ↔ (u = s.map_active_threads ac f)

def contains_sync : kernel σ τ → Prop
| (sync) := true
| (seq k₁ k₂) := contains_sync k₁ ∨ contains_sync k₂
| (load _) := false
| (store _) := false
| (compute _) := false
| (ite c k₁ k₂) := contains_sync k₁ ∨ contains_sync k₂
| (loop c k) := contains_sync k

inductive program {ι : Type} (σ : Type) (τ : ι → Type)
| intro (f : memory τ → ℕ) (k : kernel σ τ) : program

def state_initializer := ℕ → σ

@[reducible]
def init_state (init : ℕ → σ) (f : memory τ → ℕ) (m : memory τ) : state (f m) σ τ :=
{ threads := (vector.range (f m)).map (λ n, { tlocal := init n, shared := m, loads := ∅, stores := ∅ })}

inductive exec_prog : (ℕ → σ) → program σ τ → memory τ → memory τ → Prop
| intro (k : kernel σ τ) (f : memory τ → ℕ) (a b : memory τ) (init : ℕ → σ) (s' : state (f a) σ τ) (hsync : s'.syncable b)
  (he : exec_state k (vector.repeat tt (f a)) (init_state init f a) s') :
  exec_prog init (program.intro f k) a b

def list_to_kernel_seq (ks : list (kernel σ τ)) : kernel σ τ := ks.foldl (λ k₁ k₂, k₁ ;; k₂) (kernel.compute id)

end parlang


/-
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.declaration init.meta.exceptional init.data.option.basic
import init.meta.rb_map

/-- An __environment__ contains all of the declarations and notation that have been defined so far.   -/
meta constant environment : Type

namespace environment
/--
Consider a type `ψ` which is an inductive datatype using a single constructor `mk (a : α) (b : β) : ψ`.
Lean will automatically make two projection functions `a : ψ → α`, `b : ψ → β`.
Lean tags these declarations as __projections__.
This helps the simplifier / rewriter not have to expand projectors.
Eg `a (mk x y)` will automatically reduce to `x`.
If you `extend` a structure, all of the projections on the parent will also be created for the child.
Projections are also treated differently in the VM for efficiency.

Note that projections have nothing to do with the dot `mylist.map` syntax.

You can find out if a declaration is a projection using `environment.is_projection` which returns `projection_info`.

Data for a projection declaration:
- `cname`    is the name of the constructor associated with the projection.
- `nparams`  is the number of constructor parameters. Eg `and.intro` has two type parameters.
- `idx`      is the parameter being projected by this projection.
- `is_class` is tt iff this is a typeclass projection.

### Examples:

- `and.right` is a projection with ``{cname := `and.intro, nparams := 2, idx := 1, is_class := ff}``
- `ordered_ring.neg` is a projection with ``{cname := `ordered_ring.mk, nparams := 1, idx := 5, is_class := tt}``.

-/
structure projection_info :=
(cname : name)
(nparams : nat)
(idx : nat)
(is_class : bool)

/-- A marking on the binders of structures and inductives indicating
   how this constructor should mark its parameters.

       inductive foo
       | one {} : foo -> foo   -- relaxed_implicit
       | two ( ) : foo -> foo  -- explicit
       | two [] : foo -> foo   -- implicit
       | three : foo -> foo    -- relaxed implicit (default)
-/
inductive implicit_infer_kind | implicit | relaxed_implicit | none
instance implicit_infer_kind.inhabited : inhabited implicit_infer_kind := ⟨implicit_infer_kind.implicit⟩

/-- One introduction rule in an inductive declaration -/
meta structure intro_rule :=
(constr : name)
(type : expr)
(infer : implicit_infer_kind := implicit_infer_kind.implicit)

/-- Create a standard environment using the given trust level -/
meta constant mk_std          : nat → environment
/-- Return the trust level of the given environment -/
meta constant trust_lvl       : environment → nat
/-- Add a new declaration to the environment -/
meta constant add             : environment → declaration → exceptional environment
/-- make declaration `n` protected -/
meta constant mk_protected   : environment → name → environment

/-- add declaration `d` and make it protected -/
meta def add_protected (env : environment) (d : declaration) : exceptional environment := do
env ← env.add d,
pure $ env.mk_protected d.to_name

/-- check if `n` is the name of a protected declaration -/
meta constant is_protected    : environment → name → bool
/-- Retrieve a declaration from the environment -/
meta constant get             : environment → name → exceptional declaration
meta def      contains (env : environment) (d : name) : bool :=
match env.get d with
| exceptional.success _      := tt
| exceptional.exception _ := ff
end

meta constant add_defn_eqns (env : environment) (opt : options)
  (lp_params : list name) (params : list expr) (sig : expr)
  (eqns : list (list (expr ff) × expr)) (is_meta : bool) : exceptional environment

/-- Register the given name as a namespace, making it available to the `open` command -/
meta constant add_namespace   : environment → name → environment
/-- Mark a namespace as open -/
meta constant mark_namespace_as_open : environment -> name -> environment
/-- Modify the environment as if `open %%name` had been parsed -/
meta constant execute_open : environment -> name -> environment
/-- Retrieve all registered namespaces -/
meta constant get_namespaces : environment -> list name
/-- Return tt iff the given name is a namespace -/
meta constant is_namespace    : environment → name → bool
/-- Add a new inductive datatype to the environment
   name, universe parameters, number of parameters, type, constructors (name and type), is_meta -/
meta constant add_inductive (env : environment)
  (n : name) (levels : list name) (num_params : nat) (type : expr)
  (intros : list (name × expr)) (is_meta : bool) : exceptional environment
/-- Add a new general inductive declaration to the environment.
  This has the same effect as a `inductive` in the file, including generating
  all the auxiliary definitions, as well as triggering mutual/nested inductive
  compilation, by contrast to `environment.add_inductive` which only adds the
  core axioms supported by the kernel.

  The `inds` argument should be a list of inductives in the mutual family.
  The first argument is a pair of the name of the type being constructed
  and the type of this inductive family (not including the params).
  The second argument is a list of intro rules, specified by a name, an
  `implicit_infer_kind` giving the implicitness of the params for this constructor,
  and an expression with the type of the constructor (not including the params).
-/
meta constant add_ginductive (env : environment) (opt : options)
  (levels : list name) (params : list expr)
  (inds : list ((name × expr) × list intro_rule))
  (is_meta : bool) : exceptional environment
/-- Return tt iff the given name is an inductive datatype -/
meta constant is_inductive    : environment → name → bool
/-- Return tt iff the given name is a constructor -/
meta constant is_constructor  : environment → name → bool
/-- Return tt iff the given name is a recursor -/
meta constant is_recursor     : environment → name → bool
/-- Return tt iff the given name is a recursive inductive datatype -/
meta constant is_recursive    : environment → name → bool
/-- Return the name of the inductive datatype of the given constructor. -/
meta constant inductive_type_of : environment → name → option name
/-- Return the constructors of the inductive datatype with the given name -/
meta constant constructors_of : environment → name → list name
/-- Return the recursor of the given inductive datatype -/
meta constant recursor_of     : environment → name → option name
/-- Return the number of parameters of the inductive datatype -/
meta constant inductive_num_params : environment → name → nat
/-- Return the number of indices of the inductive datatype -/
meta constant inductive_num_indices : environment → name → nat
/-- Return tt iff the inductive datatype recursor supports dependent elimination -/
meta constant inductive_dep_elim : environment → name → bool
/-- Functionally equivalent to `is_inductive`.

Technically, this works by checking if the name is in the ginductive environment
extension which is outside the kernel, whereas `is_inductive` works by looking at the kernel extension.
But there are no `is_inductive`s which are not `is_ginductive`.
 -/
meta constant is_ginductive : environment → name → bool
/-- See the docstring for `projection_info`. -/
meta constant is_projection : environment → name → option projection_info
/-- Fold over declarations in the environment. -/
meta constant fold {α :Type} : environment → α → (declaration → α → α) → α
/-- `relation_info env n` returns some value if n is marked as a relation in the given environment.
   the tuple contains: total number of arguments of the relation, lhs position and rhs position. -/
meta constant relation_info : environment → name → option (nat × nat × nat)
/-- `refl_for env R` returns the name of the reflexivity theorem for the relation R -/
meta constant refl_for : environment → name → option name
/-- `symm_for env R` returns the name of the symmetry theorem for the relation R -/
meta constant symm_for : environment → name → option name
/-- `trans_for env R` returns the name of the transitivity theorem for the relation R -/
meta constant trans_for : environment → name → option name
/-- `decl_olean env d` returns the name of the .olean file where d was defined.
   The result is none if d was not defined in an imported file. -/
meta constant decl_olean : environment → name → option string
/-- `decl_pos env d` returns the source location of d if available. -/
meta constant decl_pos : environment → name → option pos
/-- `decl_pos env d` returns the name of a declaration that d inherits
noncomputability from, or `none` if it is computable.

Note that this also returns `none` on `axiom`s and `constant`s. These can be detected by using
`environment.get_decl` and `declaration.is_axiom` and `declaration.is_constant`. -/
meta constant decl_noncomputable_reason : environment → name → option name
/-- Return the fields of the structure with the given name, or `none` if it is not a structure -/
meta constant structure_fields : environment → name → option (list name)
/-- `get_class_attribute_symbols env attr_name` return symbols
   occurring in instances of type classes tagged with the attribute `attr_name`.
   Example: [algebra] -/
meta constant get_class_attribute_symbols : environment → name → name_set
/-- The fingerprint of the environment is a hash formed from all of the declarations in the environment. -/
meta constant fingerprint : environment → nat

/-- Gets the equation lemmas for the declaration `n`. -/
meta constant get_eqn_lemmas_for (env : environment) (n : name) : list name
/-- Gets the equation lemmas for the declaration `n`, including lemmas for match statements, etc. -/
meta constant get_ext_eqn_lemmas_for (env : environment) (n : name) : list name
/--
Adds the equation lemma `n`.
It is added for the declaration `t.pi_codomain.get_app_fn.const_name` where `t` is the type of the equation lemma.
-/
meta constant add_eqn_lemma (env : environment) (n : name) : environment

open expr

meta constant unfold_untrusted_macros : environment → expr → expr
meta constant unfold_all_macros : environment → expr → expr

meta def is_constructor_app (env : environment) (e : expr) : bool :=
is_constant (get_app_fn e) && is_constructor env (const_name (get_app_fn e))

meta def is_refl_app (env : environment) (e : expr) : option (name × expr × expr) :=
match (refl_for env (const_name (get_app_fn e))) with
| (some n) :=
    if get_app_num_args e ≥ 2
    then some (n, app_arg (app_fn e), app_arg e)
    else none
| none   := none
end

/-- Return true if 'n' has been declared in the current file -/
meta def in_current_file (env : environment) (n : name) : bool :=
(env.decl_olean n).is_none && env.contains n && (n ∉ [``quot, ``quot.mk, ``quot.lift, ``quot.ind])

meta def is_definition (env : environment) (n : name) : bool :=
match env.get n with
| exceptional.success (declaration.defn _ _ _ _ _ _) := tt
| _                                                  := ff
end

end environment

meta instance : has_repr environment :=
⟨λ e, "[environment]"⟩

meta instance : inhabited environment :=
⟨environment.mk_std 0⟩