/-
Copyright (c) 2019 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro, Simon Hudon, Scott Morrison, Keeley Hoek, Robert Y. Lewis, Floris van Doorn
-/
import data.string.defs
import tactic.derive_inhabited
/-!
# Additional operations on expr and related types

This file defines basic operations on the types expr, name, declaration, level, environment.

This file is mostly for non-tactics. Tactics should generally be placed in `tactic.core`.

## Tags

expr, name, declaration, level, environment, meta, metaprogramming, tactic
-/

open tactic

attribute [derive has_reflect, derive decidable_eq] binder_info congr_arg_kind

namespace binder_info

/-! ### Declarations about `binder_info` -/

instance : inhabited binder_info := ⟨ binder_info.default ⟩

/-- The brackets corresponding to a given binder_info. -/
def brackets : binder_info → string × string
| binder_info.implicit        := ("{", "}")
| binder_info.strict_implicit := ("{{", "}}")
| binder_info.inst_implicit   := ("[", "]")
| _                           := ("(", ")")

end binder_info

namespace name

/-! ### Declarations about `name` -/

/-- Find the largest prefix `n` of a `name` such that `f n ≠ none`, then replace this prefix
with the value of `f n`. -/
def map_prefix (f : name → option name) : name → name
| anonymous := anonymous
| (mk_string s n') := (f (mk_string s n')).get_or_else (mk_string s $ map_prefix n')
| (mk_numeral d n') := (f (mk_numeral d n')).get_or_else (mk_numeral d $ map_prefix n')

/-- If `nm` is a simple name (having only one string component) starting with `_`, then
`deinternalize_field nm` removes the underscore. Otherwise, it does nothing. -/
meta def deinternalize_field : name → name
| (mk_string s name.anonymous) :=
  let i := s.mk_iterator in
  if i.curr = '_' then i.next.next_to_string else s
| n := n

/-- `get_nth_prefix nm n` removes the last `n` components from `nm` -/
meta def get_nth_prefix : name → ℕ → name
| nm 0 := nm
| nm (n + 1) := get_nth_prefix nm.get_prefix n

/-- Auxiliary definition for `pop_nth_prefix` -/
private meta def pop_nth_prefix_aux : name → ℕ → name × ℕ
| anonymous n := (anonymous, 1)
| nm n := let (pfx, height) := pop_nth_prefix_aux nm.get_prefix n in
          if height ≤ n then (anonymous, height + 1)
          else (nm.update_prefix pfx, height + 1)

/-- Pops the top `n` prefixes from the given name. -/
meta def pop_nth_prefix (nm : name) (n : ℕ) : name :=
prod.fst $ pop_nth_prefix_aux nm n

/-- Pop the prefix of a name -/
meta def pop_prefix (n : name) : name :=
pop_nth_prefix n 1

/-- Auxiliary definition for `from_components` -/
private def from_components_aux : name → list string → name
| n [] := n
| n (s :: rest) := from_components_aux (name.mk_string s n) rest

/-- Build a name from components. For example `from_components ["foo","bar"]` becomes
  ``` `foo.bar``` -/
def from_components : list string → name :=
from_components_aux name.anonymous

/-- `name`s can contain numeral pieces, which are not legal names
  when typed/passed directly to the parser. We turn an arbitrary
  name into a legal identifier name by turning the numbers to strings. -/
meta def sanitize_name : name → name
| name.anonymous := name.anonymous
| (name.mk_string s p) := name.mk_string s $ sanitize_name p
| (name.mk_numeral s p) := name.mk_string sformat!"n{s}" $ sanitize_name p

/-- Append a string to the last component of a name. -/
def append_suffix : name → string → name
| (mk_string s n) s' := mk_string (s ++ s') n
| n _ := n

/-- Update the last component of a name. -/
def update_last (f : string → string) : name → name
| (mk_string s n) := mk_string (f s) n
| n := n

/-- `append_to_last nm s is_prefix` adds `s` to the last component of `nm`,
  either as prefix or as suffix (specified by `is_prefix`), separated by `_`.
  Used by `simps_add_projections`. -/
def append_to_last (nm : name) (s : string) (is_prefix : bool) : name :=
nm.update_last $ λ s', if is_prefix then s ++ "_" ++ s' else s' ++ "_" ++ s

/-- The first component of a name, turning a number to a string -/
meta def head : name → string
| (mk_string s anonymous) := s
| (mk_string s p)         := head p
| (mk_numeral n p)        := head p
| anonymous               := "[anonymous]"

/-- Tests whether the first component of a name is `"_private"` -/
meta def is_private (n : name) : bool :=
n.head = "_private"

/-- Get the last component of a name, and convert it to a string. -/
meta def last : name → string
| (mk_string s _)  := s
| (mk_numeral n _) := repr n
| anonymous        := "[anonymous]"

/-- Returns the number of characters used to print all the string components of a name,
  including periods between name segments. Ignores numerical parts of a name. -/
meta def length : name → ℕ
| (mk_string s anonymous) := s.length
| (mk_string s p)         := s.length + 1 + p.length
| (mk_numeral n p)        := p.length
| anonymous               := "[anonymous]".length

/-- Checks whether `nm` has a prefix (including itself) such that P is true -/
def has_prefix (P : name → bool) : name → bool
| anonymous := ff
| (mk_string s nm)  := P (mk_string s nm) ∨ has_prefix nm
| (mk_numeral s nm) := P (mk_numeral s nm) ∨ has_prefix nm

/-- Appends `'` to the end of a name. -/
meta def add_prime : name → name
| (name.mk_string s p) := name.mk_string (s ++ "'") p
| n := (name.mk_string "x'" n)

/-- `last_string n` returns the rightmost component of `n`, ignoring numeral components.
For example, ``last_string `a.b.c.33`` will return `` `c ``. -/
def last_string : name → string
| anonymous        := "[anonymous]"
| (mk_string s _)  := s
| (mk_numeral _ n) := last_string n

/--
Constructs a (non-simple) name from a string.

Example: ``name.from_string "foo.bar" = `foo.bar``
-/
meta def from_string (s : string) : name :=
from_components $ s.split (= '.')

/--
In surface Lean, we can write anonymous Π binders (i.e. binders where the
argument is not named) using the function arrow notation:

```lean
inductive test : Type
| intro : unit → test
```

After elaboration, however, every binder must have a name, so Lean generates
one. In the example, the binder in the type of `intro` is anonymous, so Lean
gives it the name `ᾰ`:

```lean
test.intro : ∀ (ᾰ : unit), test
```

When there are multiple anonymous binders, they are named `ᾰ_1`, `ᾰ_2` etc.

Thus, when we want to know whether the user named a binder, we can check whether
the name follows this scheme. Note, however, that this is not reliable. When the
user writes (for whatever reason)

```lean
inductive test : Type
| intro : ∀ (ᾰ : unit), test
```

we cannot tell that the binder was, in fact, named.

The function `name.is_likely_generated_binder_name` checks if
a name is of the form `ᾰ`, `ᾰ_1`, etc.
-/
library_note "likely generated binder names"

/--
Check whether a simple name was likely generated by Lean to name an anonymous
binder. Such names are either `ᾰ` or `ᾰ_n` for some natural `n`. See
note [likely generated binder names].
-/
meta def is_likely_generated_binder_simple_name : string → bool
| "ᾰ" := tt
| n :=
  match n.get_rest "ᾰ_" with
  | none := ff
  | some suffix := suffix.is_nat
  end

/--
Check whether a name was likely generated by Lean to name an anonymous binder.
Such names are either `ᾰ` or `ᾰ_n` for some natural `n`. See
note [likely generated binder names].
-/
meta def is_likely_generated_binder_name (n : name) : bool :=
match n with
| mk_string s anonymous := is_likely_generated_binder_simple_name s
| _ := ff
end

end name

namespace level

/-! ### Declarations about `level` -/

/-- Tests whether a universe level is non-zero for all assignments of its variables -/
meta def nonzero : level → bool
| (succ _) := tt
| (max l₁ l₂) := l₁.nonzero || l₂.nonzero
| (imax _ l₂) := l₂.nonzero
| _ := ff

/--
`l.fold_mvar f` folds a function `f : name → α → α`
over each `n : name` appearing in a `level.mvar n` in `l`.
-/
meta def fold_mvar {α} : level → (name → α → α) → α → α
| zero f := id
| (succ a) f := fold_mvar a f
| (param a) f := id
| (mvar a) f := f a
| (max a b) f := fold_mvar a f ∘ fold_mvar b f
| (imax a b) f := fold_mvar a f ∘ fold_mvar b f

/--
`l.params` is the set of parameters occuring in `l`.
For example if `l = max 1 (max (u+1) (max v w))` then `l.params = {u, v, w}`.
-/
protected meta def params (u : level) : name_set :=
u.fold mk_name_set $ λ v l,
  match v with
  | (param nm) := l.insert nm
  | _ := l
  end

end level

/-! ### Declarations about `binder` -/

/-- The type of binders containing a name, the binding info and the binding type -/
@[derive decidable_eq, derive inhabited]
meta structure binder :=
  (name : name)
  (info : binder_info)
  (type : expr)

namespace binder
/-- Turn a binder into a string. Uses expr.to_string for the type. -/
protected meta def to_string (b : binder) : string :=
let (l, r) := b.info.brackets in
l ++ b.name.to_string ++ " : " ++ b.type.to_string ++ r

meta instance : has_to_string binder := ⟨ binder.to_string ⟩
meta instance : has_to_format binder := ⟨ λ b, b.to_string ⟩
meta instance : has_to_tactic_format binder :=
⟨ λ b, let (l, r) := b.info.brackets in
  (λ e, l ++ b.name.to_string ++ " : " ++ e ++ r) <$> pp b.type ⟩

end binder

/-!
### Converting between expressions and numerals

There are a number of ways to convert between expressions and numerals, depending on the input and
output types and whether you want to infer the necessary type classes.

See also the tactics `expr.of_nat`, `expr.of_int`, `expr.of_rat`.
-/

/--
`nat.mk_numeral n` embeds `n` as a numeral expression inside a type with 0, 1, and +.
`type`: an expression representing the target type. This must live in Type 0.
`has_zero`, `has_one`, `has_add`: expressions of the type `has_zero %%type`, etc.
 -/
meta def nat.mk_numeral (type has_zero has_one has_add : expr) : ℕ → expr :=
let z : expr := `(@has_zero.zero.{0} %%type %%has_zero),
    o : expr := `(@has_one.one.{0} %%type %%has_one) in
nat.binary_rec z
  (λ b n e, if n = 0 then o else
    if b then `(@bit1.{0} %%type %%has_one %%has_add %%e)
    else `(@bit0.{0} %%type %%has_add %%e))

/--
`int.mk_numeral z` embeds `z` as a numeral expression inside a type with 0, 1, +, and -.
`type`: an expression representing the target type. This must live in Type 0.
`has_zero`, `has_one`, `has_add`, `has_neg`: expressions of the type `has_zero %%type`, etc.
 -/
meta def int.mk_numeral (type has_zero has_one has_add has_neg : expr) : ℤ → expr
| (int.of_nat n) := n.mk_numeral type has_zero has_one has_add
| -[1+n] := let ne := (n+1).mk_numeral type has_zero has_one has_add in
            `(@has_neg.neg.{0} %%type %%has_neg %%ne)

/--
`nat.to_pexpr n` creates a `pexpr` that will evaluate to `n`.
The `pexpr` does not hold any typing information:
`to_expr ``((%%(nat.to_pexpr 5) : ℤ))` will create a native integer numeral `(5 : ℤ)`.
-/
meta def nat.to_pexpr : ℕ → pexpr
| 0 := ``(0)
| 1 := ``(1)
| n := if n % 2 = 0 then ``(bit0 %%(nat.to_pexpr (n/2))) else ``(bit1 %%(nat.to_pexpr (n/2)))

/--
`int.to_pexpr n` creates a `pexpr` that will evaluate to `n`.
The `pexpr` does not hold any typing information:
`to_expr ``((%%(int.to_pexpr (-5)) : ℚ))` will create a native `ℚ` numeral `(-5 : ℚ)`.
-/
meta def int.to_pexpr : ℤ → pexpr
| (int.of_nat k) := k.to_pexpr
| (int.neg_succ_of_nat k) := ``(-%%((k+1).to_pexpr))

namespace expr

/--
Turns an expression into a natural number, assuming it is only built up from
`has_one.one`, `bit0`, `bit1`, `has_zero.zero`, `nat.zero`, and `nat.succ`.
-/
protected meta def to_nat : expr → option ℕ
| `(has_zero.zero) := some 0
| `(has_one.one) := some 1
| `(bit0 %%e) := bit0 <$> e.to_nat
| `(bit1 %%e) := bit1 <$> e.to_nat
| `(nat.succ %%e) := (+1) <$> e.to_nat
| `(nat.zero) := some 0
| _ := none

/--
Turns an expression into a integer, assuming it is only built up from
`has_one.one`, `bit0`, `bit1`, `has_zero.zero` and a optionally a single `has_neg.neg` as head.
-/
protected meta def to_int : expr → option ℤ
| `(has_neg.neg %%e) := do n ← e.to_nat, some (-n)
| e                  := coe <$> e.to_nat

/--
Turns an expression into a list, assuming it is only built up from `list.nil` and `list.cons`.
-/
protected meta def to_list {α} (f : expr → option α) : expr → option (list α)
| `(list.nil)          := some []
| `(list.cons %%x %%l) := list.cons <$> f x <*> l.to_list
| _                    := none

/--
`is_num_eq n1 n2` returns true if `n1` and `n2` are both numerals with the same numeral structure,
ignoring differences in type and type class arguments.
-/
meta def is_num_eq : expr → expr → bool
| `(@has_zero.zero _ _) `(@has_zero.zero _ _) := tt
| `(@has_one.one _ _) `(@has_one.one _ _) := tt
| `(bit0 %%a) `(bit0 %%b) := a.is_num_eq b
| `(bit1 %%a) `(bit1 %%b) := a.is_num_eq b
| `(-%%a) `(-%%b) := a.is_num_eq b
| `(%%a/%%a') `(%%b/%%b') :=  a.is_num_eq b
| _ _ := ff

end expr

/-! ### Declarations about `pexpr` -/

namespace pexpr

/--
If `e` is an annotation of `frozen_name` to `expr.const n`,
`e.get_frozen_name` returns `n`.
Otherwise, returns `name.anonymous`.
-/
meta def get_frozen_name (e : pexpr) : name :=
match e.is_annotation with
| some (`frozen_name, expr.const n _) := n
| _ := name.anonymous
end

/--
If `e : pexpr` is a sequence of applications `f e₁ e₂ ... eₙ`,
`e.get_app_fn_args` returns `(f, [e₁, ... eₙ])`.
See also `expr.get_app_fn_args`.
-/
meta def get_app_fn_args : pexpr → opt_param (list pexpr) [] → pexpr × list pexpr
| (expr.app e1 e2) r := get_app_fn_args e1 (e2::r)
| e1 r := (e1, r)

/--
If `e : pexpr` is a sequence of applications `f e₁ e₂ ... eₙ`,
`e.get_app_fn` returns `f`.
See also `expr.get_app_fn`.
-/
meta def get_app_fn : pexpr → list pexpr :=
prod.snd ∘ get_app_fn_args

/--
If `e : pexpr` is a sequence of applications `f e₁ e₂ ... eₙ`,
`e.get_app_args` returns `[e₁, ... eₙ]`.
See also `expr.get_app_args`.
-/
meta def get_app_args : pexpr → list pexpr :=
prod.snd ∘ get_app_fn_args

end pexpr

/-! ### Declarations about `expr` -/

namespace expr

/-- List of names removed by `clean`. All these names must resolve to functions defeq `id`. -/
meta def clean_ids : list name :=
[``id, ``id_rhs, ``id_delta, ``hidden]

/-- Clean an expression by removing `id`s listed in `clean_ids`. -/
meta def clean (e : expr) : expr :=
e.replace (λ e n,
     match e with
     | (app (app (const n _) _) e') :=
       if n ∈ clean_ids then some e' else none
     | (app (lam _ _ _ (var 0)) e') := some e'
     | _ := none
     end)

/-- `replace_with e s s'` replaces ocurrences of `s` with `s'` in `e`. -/
meta def replace_with (e : expr) (s : expr) (s' : expr) : expr :=
e.replace $ λc d, if c = s then some (s'.lift_vars 0 d) else none

/-- Implementation of `expr.mreplace`. -/
meta def mreplace_aux {m : Type* → Type*} [monad m] (R : expr → nat → m (option expr)) :
  expr → ℕ → m expr
| (app f x) n := option.mget_or_else (R (app f x) n)
  (do Rf ← mreplace_aux f n, Rx ← mreplace_aux x n, return $ app Rf Rx)
| (lam nm bi ty bd) n := option.mget_or_else (R (lam nm bi ty bd) n)
  (do Rty ← mreplace_aux ty n, Rbd ← mreplace_aux bd (n+1), return $ lam nm bi Rty Rbd)
| (pi nm bi ty bd) n := option.mget_or_else (R (pi nm bi ty bd) n)
  (do Rty ← mreplace_aux ty n, Rbd ← mreplace_aux bd (n+1), return $ pi nm bi Rty Rbd)
| (elet nm ty a b) n := option.mget_or_else (R (elet nm ty a b) n)
  (do Rty ← mreplace_aux ty n,
    Ra ← mreplace_aux a n,
    Rb ← mreplace_aux b n,
    return $ elet nm Rty Ra Rb)
| (macro c es) n := option.mget_or_else (R (macro c es) n) $
    macro c <$> es.mmap (λ e, mreplace_aux e n)
| e n := option.mget_or_else (R e n) (return e)

/--
Monadic analogue of `expr.replace`.

The `mreplace R e` visits each subexpression `s` of `e`, and is called with `R s n`, where
`n` is the number of binders above `e`.
If `R s n` fails, the whole replacement fails.
If `R s n` returns `some t`, `s` is replaced with `t` (and `mreplace` does not visit
its subexpressions).
If `R s n` return `none`, then `mreplace` continues visiting subexpressions of `s`.

WARNING: This function performs exponentially worse on large terms than `expr.replace`,
if a subexpression occurs more than once in an expression, `expr.replace` visits them only once,
but this function will visit every occurence of it. Do not use this on large expressions.
-/
meta def mreplace {m : Type* → Type*} [monad m] (R : expr → nat → m (option expr)) (e : expr) :
  m expr :=
mreplace_aux R e 0

/-- Match a variable. -/
meta def match_var {elab} : expr elab → option ℕ
| (var n) := some n
| _ := none

/-- Match a sort. -/
meta def match_sort {elab} : expr elab → option level
| (sort u) := some u
| _ := none

/-- Match a constant. -/
meta def match_const {elab} : expr elab → option (name × list level)
| (const n lvls) := some (n, lvls)
| _ := none

/-- Match a metavariable. -/
meta def match_mvar {elab} : expr elab →
  option (name × name × expr elab)
| (mvar unique pretty type) := some (unique, pretty, type)
| _ := none

/-- Match a local constant. -/
meta def match_local_const {elab} : expr elab →
  option (name × name × binder_info × expr elab)
| (local_const unique pretty bi type) := some (unique, pretty, bi, type)
| _ := none

/-- Match an application. -/
meta def match_app {elab} : expr elab → option (expr elab × expr elab)
| (app t u) := some (t, u)
| _ := none

/-- Match an application of `coe_fn`. -/
meta def match_app_coe_fn : expr → option (expr × expr × expr × expr × expr)
| (app `(@coe_fn %%α %%β %%inst %%fexpr) x) := some (α, β, inst, fexpr, x)
| _ := none

/-- Match an abstraction. -/
meta def match_lam {elab} : expr elab →
  option (name × binder_info × expr elab × expr elab)
| (lam var_name bi type body) := some (var_name, bi, type, body)
| _ := none

/-- Match a Π type. -/
meta def match_pi {elab} : expr elab →
  option (name × binder_info × expr elab × expr elab)
| (pi var_name bi type body) := some (var_name, bi, type, body)
| _ := none

/-- Match a let. -/
meta def match_elet {elab} : expr elab →
  option (name × expr elab × expr elab × expr elab)
| (elet var_name type assignment body) := some (var_name, type, assignment, body)
| _ := none

/-- Match a macro. -/
meta def match_macro {elab} : expr elab →
  option (macro_def × list (expr elab))
| (macro df args) := some (df, args)
| _ := none

/-- Tests whether an expression is a meta-variable. -/
meta def is_mvar : expr → bool
| (mvar _ _ _) := tt
| _            := ff

/-- Tests whether an expression is a sort. -/
meta def is_sort : expr → bool
| (sort _) := tt
| e         := ff

/-- Get the universe levels of a `const` expression -/
meta def univ_levels : expr → list level
| (const n ls) := ls
| _            := []

/--
Replace any metavariables in the expression with underscores, in preparation for printing
`refine ...` statements.
-/
meta def replace_mvars (e : expr) : expr :=
e.replace (λ e' _, if e'.is_mvar then some (unchecked_cast pexpr.mk_placeholder) else none)

/-- If `e` is a local constant, `to_implicit_local_const e` changes the binder info of `e` to
 `implicit`. See also `to_implicit_binder`, which also changes lambdas and pis. -/
meta def to_implicit_local_const : expr → expr
| (expr.local_const uniq n bi t) := expr.local_const uniq n binder_info.implicit t
| e := e

/-- If `e` is a local constant, lamda, or pi expression, `to_implicit_binder e` changes the binder
info of `e` to `implicit`. See also `to_implicit_local_const`, which only changes local constants.
-/
meta def to_implicit_binder : expr → expr
| (local_const n₁ n₂ _ d) := local_const n₁ n₂ binder_info.implicit d
| (lam n _ d b) := lam n binder_info.implicit d b
| (pi n _ d b) := pi n binder_info.implicit d b
| e  := e

/-- Returns a list of all local constants in an expression (without duplicates). -/
meta def list_local_consts (e : expr) : list expr :=
e.fold [] (λ e' _ es, if e'.is_local_constant then insert e' es else es)

/-- Returns the set of all local constants in an expression. -/
meta def list_local_consts' (e : expr) : expr_set :=
e.fold mk_expr_set (λ e' _ es, if e'.is_local_constant then es.insert e' else es)

/-- Returns the unique names of all local constants in an expression. -/
meta def list_local_const_unique_names (e : expr) : name_set :=
e.fold mk_name_set
  (λ e' _ es, if e'.is_local_constant then es.insert e'.local_uniq_name else es)

/-- Returns a `name_set` of all constants in an expression. -/
meta def list_constant (e : expr) : name_set :=
e.fold mk_name_set (λ e' _ es, if e'.is_constant then es.insert e'.const_name else es)

/-- Returns a `list name` containing the constant names of an `expr` in the same order
  that `expr.fold` traverses it. -/
meta def list_constant' (e : expr) : list name :=
(e.fold [] (λ e' _ es, if e'.is_constant then es.insert e'.const_name else es)).reverse

/-- Returns a list of all meta-variables in an expression (without duplicates). -/
meta def list_meta_vars (e : expr) : list expr :=
e.fold [] (λ e' _ es, if e'.is_mvar then insert e' es else es)

/-- Returns the set of all meta-variables in an expression. -/
meta def list_meta_vars' (e : expr) : expr_set :=
e.fold mk_expr_set (λ e' _ es, if e'.is_mvar then es.insert e' else es)

/-- Returns a list of all universe meta-variables in an expression (without duplicates). -/
meta def list_univ_meta_vars (e : expr) : list name :=
native.rb_set.to_list $ e.fold native.mk_rb_set $ λ e' i s,
match e' with
| (sort u) := u.fold_mvar (flip native.rb_set.insert) s
| (const _ ls) := ls.foldl (λ s' l, l.fold_mvar (flip native.rb_set.insert) s') s
| _ := s
end

/--
Test `t` contains the specified subexpression `e`, or a metavariable.
This represents the notion that `e` "may occur" in `t`,
possibly after subsequent unification.
-/
meta def contains_expr_or_mvar (t : expr) (e : expr) : bool :=
-- We can't use `t.has_meta_var` here, as that detects universe metavariables, too.
¬ t.list_meta_vars.empty ∨ e.occurs t

/-- Returns a `name_set` of all constants in an expression starting with a certain prefix. -/
meta def list_names_with_prefix (pre : name) (e : expr) : name_set :=
e.fold mk_name_set $ λ e' _ l,
  match e' with
  | expr.const n _ := if n.get_prefix = pre then l.insert n else l
  | _ := l
  end

/-- Returns true if `e` contains a name `n` where `p n` is true.
  Returns `true` if `p name.anonymous` is true. -/
meta def contains_constant (e : expr) (p : name → Prop) [decidable_pred p] : bool :=
e.fold ff (λ e' _ b, if p (e'.const_name) then tt else b)

/--
Returns true if `e` contains a `sorry`.
See also `name.contains_sorry`.
-/
meta def contains_sorry (e : expr) : bool :=
e.fold ff (λ e' _ b, if (is_sorry e').is_some then tt else b)

/--
`app_symbol_in e l` returns true iff `e` is an application of a constant whose name is in `l`.
-/
meta def app_symbol_in (e : expr) (l : list name) : bool :=
match e.get_app_fn with
| (expr.const n _) := n ∈ l
| _ := ff
end

/-- `get_simp_args e` returns the arguments of `e` that simp can reach via congruence lemmas. -/
meta def get_simp_args (e : expr) : tactic (list expr) :=
-- `mk_specialized_congr_lemma_simp` throws an assertion violation if its argument is not an app
if ¬ e.is_app then pure [] else do
cgr ← mk_specialized_congr_lemma_simp e,
pure $ do
  (arg_kind, arg) ← cgr.arg_kinds.zip e.get_app_args,
  guard $ arg_kind = congr_arg_kind.eq,
  pure arg

/-- Simplifies the expression `t` with the specified options.
  The result is `(new_e, pr)` with the new expression `new_e` and a proof
  `pr : e = new_e`. -/
meta def simp (t : expr)
  (cfg : simp_config := {}) (discharger : tactic unit := failed)
  (no_defaults := ff) (attr_names : list name := []) (hs : list simp_arg_type := []) :
  tactic (expr × expr × name_set) :=
do (s, to_unfold) ← mk_simp_set no_defaults attr_names hs,
   simplify s to_unfold t cfg `eq discharger

/-- Definitionally simplifies the expression `t` with the specified options.
  The result is the simplified expression. -/
meta def dsimp (t : expr)
  (cfg : dsimp_config := {})
  (no_defaults := ff) (attr_names : list name := []) (hs : list simp_arg_type := []) :
  tactic expr :=
do (s, to_unfold) ← mk_simp_set no_defaults attr_names hs,
   s.dsimplify to_unfold t cfg

/-- Get the names of the bound variables by a sequence of pis or lambdas. -/
meta def binding_names : expr → list name
| (pi n _ _ e)  := n :: e.binding_names
| (lam n _ _ e) := n :: e.binding_names
| e             := []

/-- head-reduce a single let expression -/
meta def reduce_let : expr → expr
| (elet _ _ v b) := b.instantiate_var v
| e              := e

/-- head-reduce all let expressions -/
meta def reduce_lets : expr → expr
| (elet _ _ v b) := reduce_lets $ b.instantiate_var v
| e              := e

/-- Instantiate lambdas in the second argument by expressions from the first. -/
meta def instantiate_lambdas : list expr → expr → expr
| (e'::es) (lam n bi t e) := instantiate_lambdas es (e.instantiate_var e')
| _        e              := e

/-- Repeatedly apply `expr.subst`. -/
meta def substs : expr → list expr → expr | e es := es.foldl expr.subst e

/-- `instantiate_lambdas_or_apps es e` instantiates lambdas in `e` by expressions from `es`.
If the length of `es` is larger than the number of lambdas in `e`,
then the term is applied to the remaining terms.
Also reduces head let-expressions in `e`, including those after instantiating all lambdas.

This is very similar to `expr.substs`, but this also reduces head let-expressions. -/
meta def instantiate_lambdas_or_apps : list expr → expr → expr
| (v::es) (lam n bi t b) := instantiate_lambdas_or_apps es $ b.instantiate_var v
| es      (elet _ _ v b) := instantiate_lambdas_or_apps es $ b.instantiate_var v
| es      e              := mk_app e es

/--
Some declarations work with open expressions, i.e. an expr that has free variables.
Terms will free variables are not well-typed, and one should not use them in tactics like
`infer_type` or `unify`. You can still do syntactic analysis/manipulation on them.
The reason for working with open types is for performance: instantiating variables requires
iterating through the expression. In one performance test `pi_binders` was more than 6x
quicker than `mk_local_pis` (when applied to the type of all imported declarations 100x).
-/
library_note "open expressions"

/-- Get the codomain/target of a pi-type.
  This definition doesn't instantiate bound variables, and therefore produces a term that is open.
  See note [open expressions]. -/
meta def pi_codomain : expr → expr
| (pi n bi d b) := pi_codomain b
| e             := e

/-- Get the body/value of a lambda-expression.
  This definition doesn't instantiate bound variables, and therefore produces a term that is open.
  See note [open expressions]. -/
meta def lambda_body : expr → expr
| (lam n bi d b) := lambda_body b
| e             := e

/-- Auxiliary defintion for `pi_binders`.
  See note [open expressions]. -/
meta def pi_binders_aux : list binder → expr → list binder × expr
| es (pi n bi d b) := pi_binders_aux (⟨n, bi, d⟩::es) b
| es e             := (es, e)

/-- Get the binders and codomain of a pi-type.
  This definition doesn't instantiate bound variables, and therefore produces a term that is open.
  The.tactic `get_pi_binders` in `tactic.core` does the same, but also instantiates the
  free variables.
  See note [open expressions]. -/
meta def pi_binders (e : expr) : list binder × expr :=
let (es, e) := pi_binders_aux [] e in (es.reverse, e)

/-- Auxiliary defintion for `get_app_fn_args`. -/
meta def get_app_fn_args_aux : list expr → expr → expr × list expr
| r (app f a) := get_app_fn_args_aux (a::r) f
| r e         := (e, r)

/-- A combination of `get_app_fn` and `get_app_args`: lists both the
  function and its arguments of an application -/
meta def get_app_fn_args : expr → expr × list expr :=
get_app_fn_args_aux []

/-- `drop_pis es e` instantiates the pis in `e` with the expressions from `es`. -/
meta def drop_pis : list expr → expr → tactic expr
| (v :: vs) (pi n bi d b) := do
  t ← infer_type v,
  guard (t =ₐ d),
  drop_pis vs (b.instantiate_var v)
| [] e := return e
| _  _ := failed

/-- `instantiate_pis es e` instantiates the pis in `e` with the expressions from `es`.
  Does not check whether the result remains type-correct. -/
meta def instantiate_pis : list expr → expr → expr
| (v :: vs) (pi n bi d b) := instantiate_pis vs (b.instantiate_var v)
| _ e := e

/-- `mk_op_lst op empty [x1, x2, ...]` is defined as `op x1 (op x2 ...)`.
  Returns `empty` if the list is empty. -/
meta def mk_op_lst (op : expr) (empty : expr) : list expr → expr
| []        := empty
| [e]       := e
| (e :: es) := op e $ mk_op_lst es

/-- `mk_and_lst [x1, x2, ...]` is defined as `x1 ∧ (x2 ∧ ...)`, or `true` if the list is empty. -/
meta def mk_and_lst : list expr → expr := mk_op_lst `(and) `(true)

/-- `mk_or_lst [x1, x2, ...]` is defined as `x1 ∨ (x2 ∨ ...)`, or `false` if the list is empty. -/
meta def mk_or_lst : list expr → expr := mk_op_lst `(or) `(false)

/-- `local_binding_info e` returns the binding info of `e` if `e` is a local constant.
Otherwise returns `binder_info.default`. -/
meta def local_binding_info : expr → binder_info
| (expr.local_const _ _ bi _) := bi
| _ := binder_info.default

/-- `is_default_local e` tests whether `e` is a local constant with binder info
`binder_info.default` -/
meta def is_default_local : expr → bool
| (expr.local_const _ _ binder_info.default _) := tt
| _ := ff

/-- `has_local_constant e l` checks whether local constant `l` occurs in expression `e` -/
meta def has_local_constant (e l : expr) : bool :=
e.has_local_in $ mk_name_set.insert l.local_uniq_name

/-- Turns a local constant into a binder -/
meta def to_binder : expr → binder
| (local_const _ nm bi t) := ⟨nm, bi, t⟩
| _                       := default

/-- Strip-away the context-dependent unique id for the given local const and return: its friendly
`name`, its `binder_info`, and its `type : expr`. -/
meta def get_local_const_kind : expr → name × binder_info × expr
| (expr.local_const _ n bi e) := (n, bi, e)
| _ := (name.anonymous, binder_info.default, expr.const name.anonymous [])

/-- `local_const_set_type e t` sets the type of `e` to `t`, if `e` is a `local_const`. -/
meta def local_const_set_type {elab : bool} : expr elab → expr elab → expr elab
| (expr.local_const x n bi t) new_t := expr.local_const x n bi new_t
| e                           new_t := e

/-- `unsafe_cast e` freely changes the `elab : bool` parameter of the passed `expr`. Mainly used to
access core `expr` manipulation functions for `pexpr`-based use, but which are restricted to
`expr tt` at the site of definition unnecessarily.

DANGER: Unless you know exactly what you are doing, this is probably not the function you are
looking for. For `pexpr → expr` see `tactic.to_expr`. For `expr → pexpr` see `to_pexpr`. -/
meta def unsafe_cast {elab₁ elab₂ : bool} : expr elab₁ → expr elab₂ := unchecked_cast

/-- `replace_subexprs e mappings` takes an `e : expr` and interprets a `list (expr × expr)` as
a collection of rules for variable replacements. A pair `(f, t)` encodes a rule which says "whenever
`f` is encountered in `e` verbatim, replace it with `t`". -/
meta def replace_subexprs {elab : bool} (e : expr elab) (mappings : list (expr × expr)) :
  expr elab :=
unsafe_cast $ e.unsafe_cast.replace $ λ e n,
  (mappings.filter $ λ ent : expr × expr, ent.1 = e).head'.map prod.snd

/-- `is_implicitly_included_variable e vs` accepts `e`, an `expr.local_const`, and a list `vs` of
    other `expr.local_const`s. It determines whether `e` should be considered "available in context"
    as a variable by virtue of the fact that the variables `vs` have been deemed such.

    For example, given `variables (n : ℕ) [prime n] [ih : even n]`, a reference to `n` implies that
    the typeclass instance `prime n` should be included, but `ih : even n` should not.

    DANGER: It is possible that for `f : expr` another `expr.local_const`, we have
    `is_implicitly_included_variable f vs = ff` but
    `is_implicitly_included_variable f (e :: vs) = tt`. This means that one usually wants to
    iteratively add a list of local constants (usually, the `variables` declared in the local scope)
    which satisfy `is_implicitly_included_variable` to an initial `vs`, repeating if any variables
    were added in a particular iteration. The function `all_implicitly_included_variables` below
    implements this behaviour.

    Note that if `e ∈ vs` then `is_implicitly_included_variable e vs = tt`. -/
meta def is_implicitly_included_variable (e : expr) (vs : list expr) : bool :=
if ¬(e.local_pp_name.to_string.starts_with "_") then
  e ∈ vs
else e.local_type.fold tt $ λ se _ b,
  if ¬b then ff
  else if ¬se.is_local_constant then tt
  else se ∈ vs

/-- Private work function for `all_implicitly_included_variables`, performing the actual series of
    iterations, tracking with a boolean whether any updates occured this iteration. -/
private meta def all_implicitly_included_variables_aux
  : list expr → list expr → list expr → bool → list expr
| []          vs rs tt := all_implicitly_included_variables_aux rs vs [] ff
| []          vs rs ff := vs
| (e :: rest) vs rs b :=
  let (vs, rs, b) :=
    if e.is_implicitly_included_variable vs then (e :: vs, rs, tt) else (vs, e :: rs, b) in
  all_implicitly_included_variables_aux rest vs rs b

/-- `all_implicitly_included_variables es vs` accepts `es`, a list of `expr.local_const`, and `vs`,
    another such list. It returns a list of all variables `e` in `es` or `vs` for which an inclusion
    of the variables in `vs` into the local context implies that `e` should also be included. See
    `is_implicitly_included_variable e vs` for the details.

    In particular, those elements of `vs` are included automatically. -/
meta def all_implicitly_included_variables (es vs : list expr) : list expr :=
all_implicitly_included_variables_aux es vs [] ff

/-- Infer the type of an application of the form `f x1 x2 ... xn`, where `f` is an identifier.
This also works if `x1, ... xn` contain free variables. -/
protected meta def simple_infer_type (env : environment) (e : expr) : exceptional expr := do
(@const tt n ls, es) ← return e.get_app_fn_args |
  exceptional.fail "expression is not a constant applied to arguments",
d ← env.get n,
return $ (d.type.instantiate_pis es).instantiate_univ_params $ d.univ_params.zip ls

/-- Auxilliary function for `head_eta_expand`. -/
meta def head_eta_expand_aux : ℕ → expr → expr → expr
| (n+1) e (pi x bi d b) :=
  lam x bi d $ head_eta_expand_aux n e b
| _ e _ := e

/-- `head_eta_expand n e t` eta-expands `e` `n` times, with the binders info and domains obtained
  by its type `t`. -/
meta def head_eta_expand (n : ℕ) (e t : expr) : expr :=
((e.lift_vars 0 n).mk_app $ (list.range n).reverse.map var).head_eta_expand_aux n t

/-- `e.eta_expand env dict` eta-expands all expressions that have as head a constant `n` in
`dict`. They are expanded until they are applied to one more argument than the maximum in
`dict.find n`. -/
protected meta def eta_expand (env : environment) (dict : name_map $ list ℕ) : expr → expr
| e := e.replace $ λ e _, do
  let (e0, es) := e.get_app_fn_args,
  let ns := (dict.find e0.const_name).iget,
  guard (bnot ns.empty),
  let e' := e0.mk_app $ es.map eta_expand,
  let needed_n := ns.foldr max 0 + 1,
  if needed_n ≤ es.length then some e'
  else do
    e'_type ← (e'.simple_infer_type env).to_option,
    some $ head_eta_expand (needed_n - es.length) e' e'_type

/--
`e.apply_replacement_fun f test` applies `f` to each identifier
(inductive type, defined function etc) in an expression, unless
* The identifier occurs in an application with first argument `arg`; and
* `test arg` is false.
However, if `f` is in the dictionary `relevant`, then the argument `relevant.find f`
is tested, instead of the first argument.

Reorder contains the information about what arguments to reorder:
e.g. `g x₁ x₂ x₃ ... xₙ` becomes `g x₂ x₁ x₃ ... xₙ` if `reorder.find g = some [1]`.
We assume that all functions where we want to reorder arguments are fully applied.
This can be done by applying `expr.eta_expand` first.
-/
protected meta def apply_replacement_fun (f : name → name) (test : expr → bool)
  (relevant : name_map ℕ) (reorder : name_map $ list ℕ) : expr → expr
| e := e.replace $ λ e _,
  match e with
  | const n ls := some $ const (f n) $
      -- if the first two arguments are reordered, we also reorder the first two universe parameters
      if 1 ∈ (reorder.find n).iget then ls.inth 1::ls.head::ls.drop 2 else ls
  | app g x :=
    let f := g.get_app_fn,
        nm := f.const_name,
        n_args := g.get_app_num_args in -- this might be inefficient
    if n_args ∈ (reorder.find nm).iget ∧ test g.get_app_args.head then
    -- interchange `x` and the last argument of `g`
    some $ apply_replacement_fun g.app_fn (apply_replacement_fun x) $
      apply_replacement_fun g.app_arg else
    if n_args = (relevant.find nm).lhoare 0 ∧ f.is_constant ∧ ¬ test x then
      some $ (f.mk_app $ g.get_app_args.map apply_replacement_fun) (apply_replacement_fun x) else
      none
  | _ := none
  end

end expr

/-! ### Declarations about `environment` -/

namespace environment

/-- Tests whether `n` is a structure. -/
meta def is_structure (env : environment) (n : name) : bool :=
(env.structure_fields n).is_some

/-- Get the full names of all projections of the structure `n`. Returns `none` if `n` is not a
  structure. -/
meta def structure_fields_full (env : environment) (n : name) : option (list name) :=
(env.structure_fields n).map (list.map $ λ n', n ++ n')

/-- Tests whether `nm` is a generalized inductive type that is not a normal inductive type.
  Note that `is_ginductive` returns `tt` even on regular inductive types.
  This returns `tt` if `nm` is (part of a) mutually defined inductive type or a nested inductive
  type. -/
meta def is_ginductive' (e : environment) (nm : name) : bool :=
e.is_ginductive nm ∧ ¬ e.is_inductive nm

/-- For all declarations `d` where `f d = some x` this adds `x` to the returned list.  -/
meta def decl_filter_map {α : Type} (e : environment) (f : declaration → option α) : list α :=
  e.fold [] $ λ d l, match f d with
                     | some r := r :: l
                     | none := l
                     end

/-- Maps `f` to all declarations in the environment. -/
meta def decl_map {α : Type} (e : environment) (f : declaration → α) : list α :=
  e.decl_filter_map $ λ d, some (f d)

/-- Lists all declarations in the environment -/
meta def get_decls (e : environment) : list declaration :=
  e.decl_map id

/-- Lists all trusted (non-meta) declarations in the environment -/
meta def get_trusted_decls (e : environment) : list declaration :=
  e.decl_filter_map (λ d, if d.is_trusted then some d else none)

/-- Lists the name of all declarations in the environment -/
meta def get_decl_names (e : environment) : list name :=
  e.decl_map declaration.to_name

/-- Fold a monad over all declarations in the environment. -/
meta def mfold {α : Type} {m : Type → Type} [monad m] (e : environment) (x : α)
  (fn : declaration → α → m α) : m α :=
e.fold (return x) (λ d t, t >>= fn d)

/-- Filters all declarations in the environment. -/
meta def filter (e : environment) (test : declaration → bool) : list declaration :=
e.fold [] $ λ d ds, if test d then d::ds else ds

/-- Filters all declarations in the environment. -/
meta def mfilter (e : environment) (test : declaration → tactic bool) : tactic (list declaration) :=
e.mfold [] $ λ d ds, do b ← test d, return $ if b then d::ds else ds

/-- Checks whether `s` is a prefix of the file where `n` is declared.
  This is used to check whether `n` is declared in mathlib, where `s` is the mathlib directory. -/
meta def is_prefix_of_file (e : environment) (s : string) (n : name) : bool :=
s.is_prefix_of $ (e.decl_olean n).get_or_else ""

end environment

/-!
### `is_eta_expansion`

 In this section we define the tactic `is_eta_expansion` which checks whether an expression
  is an eta-expansion of a structure. (not to be confused with eta-expanion for `λ`).

-/

namespace expr

/-- `is_eta_expansion_of args univs l` checks whether for all elements `(nm, pr)` in `l` we have
  `pr = nm.{univs} args`.
  Used in `is_eta_expansion`, where `l` consists of the projections and the fields of the value we
  want to eta-reduce. -/
meta def is_eta_expansion_of (args : list expr) (univs : list level) (l : list (name × expr)) :
  bool :=
l.all $ λ⟨proj, val⟩, val = (const proj univs).mk_app args

/-- `is_eta_expansion_test l` checks whether there is a list of expresions `args` such that for all
  elements `(nm, pr)` in `l` we have `pr = nm args`. If so, returns the last element of `args`.
  Used in `is_eta_expansion`, where `l` consists of the projections and the fields of the value we
  want to eta-reduce. -/
meta def is_eta_expansion_test : list (name × expr) → option expr
| []              := none
| (⟨proj, val⟩::l) :=
  match val.get_app_fn with
  | (const nm univs : expr) :=
    if nm = proj then
      let args := val.get_app_args in
      let e := args.ilast in
      if is_eta_expansion_of args univs l then some e else none
    else
      none
  | _                       := none
  end

/-- `is_eta_expansion_aux val l` checks whether `val` can be eta-reduced to an expression `e`.
  Here `l` is intended to consists of the projections and the fields of `val`.
  This tactic calls `is_eta_expansion_test l`, but first removes all proofs from the list `l` and
  afterward checks whether the resulting expression `e` unifies with `val`.
  This last check is necessary, because `val` and `e` might have different types. -/
meta def is_eta_expansion_aux (val : expr) (l : list (name × expr)) : tactic (option expr) :=
do l' ← l.mfilter (λ⟨proj, val⟩, bnot <$> is_proof val),
  match is_eta_expansion_test l' with
  | some e := option.map (λ _, e) <$> try_core (unify e val)
  | none   := return none
  end

/-- `is_eta_expansion val` checks whether there is an expression `e` such that `val` is the
  eta-expansion of `e`.
  With eta-expansion we here mean the eta-expansion of a structure, not of a function.
  For example, the eta-expansion of `x : α × β` is `⟨x.1, x.2⟩`.
  This assumes that `val` is a fully-applied application of the constructor of a structure.

  This is useful to reduce expressions generated by the notation
    `{ field_1 := _, ..other_structure }`
  If `other_structure` is itself a field of the structure, then the elaborator will insert an
  eta-expanded version of `other_structure`. -/
meta def is_eta_expansion (val : expr) : tactic (option expr) := do
  e ← get_env,
  type ← infer_type val,
  projs ← e.structure_fields_full type.get_app_fn.const_name,
  let args := (val.get_app_args).drop type.get_app_args.length,
  is_eta_expansion_aux val (projs.zip args)

end expr

/-! ### Declarations about `declaration` -/

namespace declaration

/--
`declaration.update_with_fun f test tgt decl`
sets the name of the given `decl : declaration` to `tgt`, and applies both `expr.eta_expand` and
`expr.apply_replacement_fun` to the value and type of `decl`.
-/
protected meta def update_with_fun (env : environment) (f : name → name) (test : expr → bool)
  (relevant : name_map ℕ) (reorder : name_map $ list ℕ) (tgt : name) (decl : declaration) :
  declaration :=
let decl := decl.update_name $ tgt in
let decl := decl.update_type $
  (decl.type.eta_expand env reorder).apply_replacement_fun f test relevant reorder in
decl.update_value $
  (decl.value.eta_expand env reorder).apply_replacement_fun f test relevant reorder

/-- Checks whether the declaration is declared in the current file.
  This is a simple wrapper around `environment.in_current_file`
  Use `environment.in_current_file` instead if performance matters. -/
meta def in_current_file (d : declaration) : tactic bool :=
do e ← get_env, return $ e.in_current_file d.to_name

/-- Checks whether a declaration is a theorem -/
meta def is_theorem : declaration → bool
| (thm _ _ _ _) := tt
| _             := ff

/-- Checks whether a declaration is a constant -/
meta def is_constant : declaration → bool
| (cnst _ _ _ _) := tt
| _              := ff

/-- Checks whether a declaration is a axiom -/
meta def is_axiom : declaration → bool
| (ax _ _ _) := tt
| _          := ff

/-- Checks whether a declaration is automatically generated in the environment.
  There is no cheap way to check whether a declaration in the namespace of a generalized
  inductive type is automatically generated, so for now we say that all of them are automatically
  generated. -/
meta def is_auto_generated (e : environment) (d : declaration) : bool :=
e.is_constructor d.to_name ∨
(e.is_projection d.to_name).is_some ∨
(e.is_constructor d.to_name.get_prefix ∧
  d.to_name.last ∈ ["inj", "inj_eq", "sizeof_spec", "inj_arrow"]) ∨
(e.is_inductive d.to_name.get_prefix ∧
  d.to_name.last ∈ ["below", "binduction_on", "brec_on", "cases_on", "dcases_on", "drec_on", "drec",
  "rec", "rec_on", "no_confusion", "no_confusion_type", "sizeof", "ibelow", "has_sizeof_inst"]) ∨
d.to_name.has_prefix (λ nm, e.is_ginductive' nm)

/--
Returns true iff `d` is an automatically-generated or internal declaration.
-/
meta def is_auto_or_internal (env : environment) (d : declaration) : bool :=
d.to_name.is_internal || d.is_auto_generated env

/-- Returns the list of universe levels of a declaration. -/
meta def univ_levels (d : declaration) : list level :=
d.univ_params.map level.param

/-- Returns the `reducibility_hints` field of a `defn`, and `reducibility_hints.opaque` otherwise -/
protected meta def reducibility_hints : declaration → reducibility_hints
| (declaration.defn _ _ _ _ red _) := red
| _ := _root_.reducibility_hints.opaque

/-- formats the arguments of a `declaration.thm` -/
private meta def print_thm (nm : name) (tp : expr) (body : task expr) : tactic format :=
do tp ← pp tp, body ← pp body.get,
   return $ "<theorem " ++ to_fmt nm ++ " : " ++ tp ++ " := " ++ body ++ ">"

/-- formats the arguments of a `declaration.defn` -/
private meta def print_defn (nm : name) (tp : expr) (body : expr) (is_trusted : bool) :
  tactic format :=
do tp ← pp tp, body ← pp body,
   return $ "<" ++ (if is_trusted then "def " else "meta def ") ++ to_fmt nm ++ " : " ++ tp ++
     " := " ++ body ++ ">"

/-- formats the arguments of a `declaration.cnst` -/
private meta def print_cnst (nm : name) (tp : expr) (is_trusted : bool) : tactic format :=
do tp ← pp tp,
   return $ "<" ++ (if is_trusted then "constant " else "meta constant ") ++ to_fmt nm ++ " : "
     ++ tp ++ ">"

/-- formats the arguments of a `declaration.ax` -/
private meta def print_ax (nm : name) (tp : expr) : tactic format :=
do tp ← pp tp,
   return $ "<axiom " ++ to_fmt nm ++ " : " ++ tp ++ ">"

/-- pretty-prints a `declaration` object. -/
meta def to_tactic_format : declaration → tactic format
| (declaration.thm nm _ tp bd) := print_thm nm tp bd
| (declaration.defn nm _ tp bd _ is_trusted) := print_defn nm tp bd is_trusted
| (declaration.cnst nm _ tp is_trusted) := print_cnst nm tp is_trusted
| (declaration.ax nm _ tp) := print_ax nm tp

meta instance : has_to_tactic_format declaration :=
⟨to_tactic_format⟩

end declaration

meta instance pexpr.decidable_eq {elab} : decidable_eq (expr elab) :=
unchecked_cast
expr.has_decidable_eq


/-
Copyright (c) 2020 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jannis Limperg
-/

import tactic.dependencies

open tactic
open native.rb_map (set_of_list)

namespace native

meta def rb_set.equals {α} (xs ys : rb_set α) : bool :=
xs.fold tt (λ x b, b ∧ ys.contains x) &&
ys.fold tt (λ y b, b ∧ xs.contains y)

end native

open native

example (n m : ℕ) (f : fin n) : let k := m, o := k in o > 0 → true :=
begin
  intros k o h,
  (do [n, m, f, k, o, h] ← [`n, `m, `f, `k, `o, `h].mmap get_local,

      -- hyp_depends_on_locals
      h_dep_m ← hyp_depends_on_locals h [m],
      guard h_dep_m <|> fail! "h_dep_m = {h_dep_m}",
      h_dep_n ← hyp_depends_on_locals h [n],
      guard ¬ h_dep_n <|> fail! "h_dep_n = {h_dep_n}",
      m_dep_n ← hyp_depends_on_locals m [n],
      guard ¬ m_dep_n <|> fail! "m_dep_n = {m_dep_n}",
      f_dep_n ← hyp_depends_on_locals f [n],
      guard f_dep_n <|> fail! "f_dep_n = {f_dep_n}",
      f_dep_n_m ← hyp_depends_on_locals f [n, m],
      guard f_dep_n_m <|> fail! "f_dep_n_m = {f_dep_n_m}",

      -- hyps_depend_on_locals
      dep_fk ← hyps_depend_on_locals [n, m, f, k, o, h] [f, k],
      guard (dep_fk = [ff, ff, ff, ff, tt, tt]) <|> fail! "dep_fk = {dep_fk}",
      dep_m ← hyps_depend_on_locals [n, m, f, k, o, h] [m],
      guard (dep_m = [ff, ff, ff, tt, tt, tt]) <|> fail! "dep_m = {dep_m}",

      -- hyp_depends_on_locals_inclusive
      h_idep_h ← hyp_depends_on_locals_inclusive h [h],
      guard h_idep_h <|> fail! "h_idep_h = {h_idep_h}",
      h_idep_n ← hyp_depends_on_locals_inclusive h [n],
      guard ¬ h_idep_n <|> fail! "h_idep_n = {h_idep_n}",

      -- hyps_depend_on_locals_inclusive
      idep_fk ← hyps_depend_on_locals_inclusive [n, m, f, k, o, h] [f, k],
      guard (idep_fk = [ff, ff, tt, tt, tt, tt]) <|> fail! "idep_fk = {idep_fk}",
      idep_m ← hyps_depend_on_locals_inclusive [n, m, f, k, o, h] [m],
      guard (idep_m = [ff, tt, ff, tt, tt, tt]) <|> fail! "idep_m = {idep_m}",

      -- dependency_set_of_hyp
      f_dep_set ← dependency_set_of_hyp f,
      guard (f_dep_set.equals (set_of_list [n])) <|> fail! "f_dep_set = {f_dep_set}",
      h_dep_set ← dependency_set_of_hyp h,
      guard (h_dep_set.equals (set_of_list [o, k, m])) <|> fail! "h_dep_set = {h_dep_set}",
      n_dep_set ← dependency_set_of_hyp n,
      guard n_dep_set.empty <|> fail! "n_dep_set = {n_dep_set}",

      -- dependency_sets_of_hyps
      fhn_dep_sets ← dependency_sets_of_hyps [f, h, n],
      guard ((fhn_dep_sets.zip_with rb_set.equals ([[n], [o, k, m], []].map set_of_list)).band) <|>
        fail! "fhn_dep_sets = {fhn_dep_sets}",

      -- dependency_set_of_hyp_inclusive
      f_idep_set ← dependency_set_of_hyp_inclusive f,
      guard (f_idep_set.equals (set_of_list [n, f])) <|> fail! "f_idep_set = {f_idep_set}",
      h_idep_set ← dependency_set_of_hyp_inclusive h,
      guard (h_idep_set.equals (set_of_list [o, k, m, h])) <|> fail! "h_idep_set = {h_idep_set}",
      n_idep_set ← dependency_set_of_hyp_inclusive n,
      guard (n_idep_set.equals (set_of_list [n])) <|> fail! "n_idep_set = {n_idep_set}",

      -- dependency_sets_of_hyps_inclusive
      fhn_idep_sets ← dependency_sets_of_hyps_inclusive [f, h, n],
      guard ((fhn_idep_sets.zip_with rb_set.equals ([[f, n], [h, o, k, m], [n]].map set_of_list)).band) <|>
        fail! "fhn_idep_sets = {fhn_idep_sets}",

      -- reverse_dependencies_of_hyps
      n_revdep_set ← reverse_dependencies_of_hyps [n],
      guard (n_revdep_set = [f]) <|> fail! "n_revdep_set = {n_revdep_set}",
      n_f_revdep_set ← reverse_dependencies_of_hyps [n, f],
      guard (n_f_revdep_set = []) <|> fail! "n_f_revdep_set = {n_f_revdep_set}",
      m_revdep_set ← reverse_dependencies_of_hyps [m],
      guard (m_revdep_set = [k, o, h]) <|> fail! "m_revdep_set = {m_revdep_set}",
      m_o_revdep_set ← reverse_dependencies_of_hyps [m, o],
      guard (m_o_revdep_set = [k, h]) <|> fail! "m_o_revdep_set = {m_o_revdep_set}",
      f_revdep_set ← reverse_dependencies_of_hyps [f],
      guard (f_revdep_set = []) <|> fail! "f_revdep_set = {f_revdep_set}",

      -- reverse_dependencies_of_hyps_inclusive
      n_irevdep_set ← reverse_dependencies_of_hyps_inclusive [n],
      guard (n_irevdep_set = [n, f]) <|> fail! "n_irevdep_set = {n_irevdep_set}",
      n_f_irevdep_set ← reverse_dependencies_of_hyps_inclusive [n, f],
      guard (n_f_irevdep_set = [n, f]) <|> fail! "n_f_irevdep_set = {n_f_irevdep_set}",
      m_irevdep_set ← reverse_dependencies_of_hyps_inclusive [m],
      guard (m_irevdep_set = [m, k, o, h]) <|> fail! "m_irevdep_set = {m_irevdep_set}",
      m_o_irevdep_set ← reverse_dependencies_of_hyps_inclusive [m, o],
      guard (m_o_irevdep_set = [m, k, o, h]) <|> fail! "m_o_irevdep_set = {m_o_irevdep_set}",
      f_irevdep_set ← reverse_dependencies_of_hyps_inclusive [f],
      guard (f_irevdep_set = [f]) <|> fail! "f_irevdep_set = {f_irevdep_set}",

      -- revert_lst'
      (n_reverted₁, reverted) ← revert_lst' [n, m],
      guard (n_reverted₁ = 6) <|> fail! "n_reverted₁ = {n_reverted₁}",
      guard
        (reverted.map expr.local_uniq_name =
        [n, m, f, k, o, h].map expr.local_uniq_name),
      `[ guard_target ∀ (n m : ℕ) (f : fin n), let k := m, o := k in o > 0 → true ],

      intros,
      [n, m, f, k, o, h] ← [`n, `m, `f, `k, `o, `h].mmap get_local,

      -- revert_reverse_dependencies_of_hyps
      n_reverted₂ ← revert_reverse_dependencies_of_hyps [n, k],
      guard (n_reverted₂ = 3) <|> fail! "n_reverted₂ = {n_reverted₂}",
      `[ guard_hyp n : ℕ ],
      `[ guard_hyp m : ℕ ],
      `[ guard_hyp k : ℕ := m ],
      `[ guard_target ∀ (f : fin n), let o := k in o > 0 → true ],

      pure ()
  ),
  intros,
  trivial
end


import tools.super
open super tactic monad

example (a b : ℕ → Prop) (h : ∀x, (¬a x → b x) ∧ ¬b x ∧ ¬a x) := by do

c ← get_local `h >>= clause.of_classical_proof,
trace c,

cs ← get_clauses_classical [c],
trace cs,

c0 ← returnopt $ cs^.nth 0,
c1 ← returnopt $ cs^.nth 1,
c2 ← returnopt $ cs^.nth 2,

trace c0^.type,
trace c0^.proof,

triv


import Lean

example : True := by
  apply True.intro
      --^ textDocument/hover

example : True := by
  simp [True.intro]
      --^ textDocument/hover

example (n : Nat) : True := by
  match n with
  | Nat.zero => _
  --^ textDocument/hover
  | n + 1 => _

/-- My tactic -/
macro "mytac" o:("only"?) e:term : tactic => `(exact $e)

example : True := by
  mytac only True.intro
--^ textDocument/hover
      --^ textDocument/hover
           --^ textDocument/hover

/-- My way better tactic -/
macro_rules
  | `(tactic| mytac $[only]? $e) => `(apply $e)

example : True := by
  mytac only True.intro
--^ textDocument/hover

/-- My ultimate tactic -/
elab_rules : tactic
  | `(tactic| mytac $[only]? $e) => `(tactic| refine $e) >>= Lean.Elab.Tactic.evalTactic

example : True := by
  mytac only True.intro
--^ textDocument/hover

/-- My notation -/
macro "mynota" e:term : term => e

#check mynota 1
     --^ textDocument/hover

/-- My way better notation -/
macro_rules
  | `(mynota $e) => `(2 * $e)

#check mynota 1
     --^ textDocument/hover

-- macro_rules take precedence over elab_rules for term/command, so use new syntax
syntax "mynota'" term : term

/-- My ultimate notation -/
elab_rules : term
  | `(mynota' $e) => `($e * $e) >>= (Lean.Elab.Term.elabTerm · none)

#check mynota' 1
     --^ textDocument/hover

/-- My command -/
macro "mycmd" e:term : command => `(def hi := $e)

mycmd 1
--^ textDocument/hover

/-- My way better command -/
macro_rules
  | `(mycmd $e) => `(@[inline] def hi := $e)

mycmd 1
--^ textDocument/hover

syntax "mycmd'" term : command
/-- My ultimate command -/
elab_rules : command
  | `(mycmd' $e) => `(/-- hi -/ @[inline] def hi := $e) >>= Lean.Elab.Command.elabCommand

mycmd' 1
--^ textDocument/hover

#check ({ a := })  -- should not show `sorry`
        --^ textDocument/hover

example : True := by
  simp [id True.intro]
      --^ textDocument/hover
        --^ textDocument/hover


/-
Copyright (c) 2022 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.Eqns
import Lean.Util.CollectFVars
import Lean.Meta.Tactic.Split
import Lean.Meta.Tactic.Apply

namespace Lean.Elab.Eqns
open Meta

structure EqnInfoCore where
  declName    : Name
  levelParams : List Name
  type        : Expr
  value       : Expr
  deriving Inhabited

partial def expand : Expr → Expr
  | Expr.letE _ t v b _ => expand (b.instantiate1 v)
  | Expr.mdata _ b _    => expand b
  | e => e

def expandRHS? (mvarId : MVarId) : MetaM (Option MVarId) := do
  let target ← getMVarType' mvarId
  let some (_, lhs, rhs) := target.eq? | return none
  unless rhs.isLet || rhs.isMData do return none
  return some (← replaceTargetDefEq mvarId (← mkEq lhs (expand rhs)))

def funext? (mvarId : MVarId) : MetaM (Option MVarId) := do
  let target ← getMVarType' mvarId
  let some (_, lhs, rhs) := target.eq? | return none
  unless rhs.isLambda do return none
  commitWhenSome? do
    let [mvarId] ← apply mvarId (← mkConstWithFreshMVarLevels ``funext) | return none
    let (_, mvarId) ← intro1 mvarId
    return some mvarId

def simpMatch? (mvarId : MVarId) : MetaM (Option MVarId) := do
  let mvarId' ← Split.simpMatchTarget mvarId
  if mvarId != mvarId' then return some mvarId' else return none

def simpIf? (mvarId : MVarId) : MetaM (Option MVarId) := do
  let mvarId' ← simpIfTarget mvarId (useDecide := true)
  if mvarId != mvarId' then return some mvarId' else return none

structure Context where
  declNames : Array Name

/--
  Auxiliary method for `mkEqnTypes`. We should "keep going"/"processing" the goal
   `... |- f ... = rhs` at `mkEqnTypes` IF `rhs` contains a recursive application containing loose bound
  variables. We do that to make sure we can create an elimination principle for the recursive functions.

  Remark: we have considered using the same heuristic used in the `BRecOn` module.
  That is we would do case-analysis on the `match` application because the recursive
  argument (may) depend on it. We abandoned this approach because it was incompatible
  with the generation of induction principles.

  Remark: we could also always return `true` here, and split **all** match expressions on the `rhs`
  even if they are not relevant for the `brecOn` construction.
  TODO: reconsider this design decision in the future.
  Another possible design option is to "split" other control structures such as `if-then-else`.
-/
private def keepGoing (mvarId : MVarId) : ReaderT Context (StateRefT (Array Expr) MetaM) Bool := do
  let target ← getMVarType' mvarId
  let some (_, lhs, rhs) := target.eq? | return false
  let ctx ← read
  return Option.isSome <| rhs.find? fun e => ctx.declNames.any e.isAppOf && e.hasLooseBVars

private def lhsDependsOn (type : Expr) (fvarId : FVarId) : MetaM Bool :=
  forallTelescope type fun _ type => do
    if let some (_, lhs, _) ← matchEq? type then
      dependsOn lhs fvarId
    else
      dependsOn type fvarId

/--
  Eliminate `namedPatterns` from equation, and trivial hypotheses.
-/
def simpEqnType (eqnType : Expr) : MetaM Expr := do
  forallTelescopeReducing (← instantiateMVars eqnType) fun ys type => do
    let proofVars := collect type
    trace[Meta.debug] "simpEqnType: {type}"
    let mut type ← Match.unfoldNamedPattern type
    let mut eliminated : FVarIdSet := {}
    for y in ys.reverse do
      trace[Meta.debug] ">> simpEqnType: {← inferType y}, {type}"
      if proofVars.contains y.fvarId! then
        let some (_, Expr.fvar fvarId _, rhs) ← matchEq? (← inferType y) | throwError "unexpected hypothesis in altenative{indentExpr eqnType}"
        eliminated := eliminated.insert fvarId
        type := type.replaceFVarId fvarId rhs
      else if eliminated.contains y.fvarId! then
        if (← dependsOn type y.fvarId!) then
          type ← mkForallFVars #[y] type
      else
        if let some (_, lhs, rhs) ← matchEq? (← inferType y) then
          if (← isDefEq lhs rhs) then
            if !(← dependsOn type y.fvarId!) then
              continue
            else if !(← lhsDependsOn type y.fvarId!) then
              -- Since the `lhs` of the `type` does not depend on `y`, we replace it with `Eq.refl` in the `rhs`
              type := type.replaceFVar y (← mkEqRefl lhs)
              continue
        type ← mkForallFVars #[y] type
    return type
where
  -- Collect eq proof vars used in `namedPatterns`
  collect (e : Expr) : FVarIdSet :=
    let go (e : Expr) (ω) : ST ω FVarIdSet := do
      let ref ← ST.mkRef {}
      e.forEach fun e => do
        if e.isAppOfArity ``namedPattern 4 && e.appArg!.isFVar then
          ST.Prim.Ref.modify ref (·.insert e.appArg!.fvarId!)
      ST.Prim.Ref.get ref
    runST (go e)

private def saveEqn (mvarId : MVarId) : StateRefT (Array Expr) MetaM Unit := withMVarContext mvarId do
  let target ← getMVarType' mvarId
  let fvarState := collectFVars {} target
  let fvarState ← (← getLCtx).foldrM (init := fvarState) fun decl fvarState => do
    if fvarState.fvarSet.contains decl.fvarId then
      return collectFVars fvarState (← instantiateMVars decl.type)
    else
      return fvarState
  let mut fvarIds ← sortFVarIds <| fvarState.fvarSet.toArray
  -- Include propositions that are not in fvarState.fvarSet, and only contains variables in
  for decl in (← getLCtx) do
    unless fvarState.fvarSet.contains decl.fvarId do
      if (← isProp decl.type) then
        let type ← instantiateMVars decl.type
        let missing? := type.find? fun e => e.isFVar && !fvarState.fvarSet.contains e.fvarId!
        if missing?.isNone then
          fvarIds := fvarIds.push decl.fvarId
  let type ← mkForallFVars (fvarIds.map mkFVar) target
  let type ← simpEqnType type
  modify (·.push type)

partial def mkEqnTypes (declNames : Array Name) (mvarId : MVarId) : MetaM (Array Expr) := do
  let (_, eqnTypes) ← go mvarId |>.run { declNames } |>.run #[]
  return eqnTypes
where
  go (mvarId : MVarId) : ReaderT Context (StateRefT (Array Expr) MetaM) Unit := do
    if !(← keepGoing mvarId) then
      saveEqn mvarId
    else if let some mvarId ← expandRHS? mvarId then
      go mvarId
    else if let some mvarId ← funext? mvarId then
      go mvarId
    else if let some mvarId ← simpMatch? mvarId then
      go mvarId
    else if let some mvarIds ← splitTarget? mvarId then
      mvarIds.forM go
    else
      saveEqn mvarId

structure EqnsExtState where
  map : Std.PHashMap Name (Array Name) := {}
  deriving Inhabited

/- We generate the equations on demand, and do not save them on .olean files. -/
builtin_initialize eqnsExt : EnvExtension EqnsExtState ←
  registerEnvExtension (pure {})

/-- Try to close goal using `rfl` with smart unfolding turned off. -/
def tryURefl (mvarId : MVarId) : MetaM Bool :=
  withOptions (smartUnfolding.set . false) do
    try applyRefl mvarId; return true catch _ => return false

/-- Delta reduce the equation left-hand-side -/
def deltaLHS (mvarId : MVarId) : MetaM MVarId := withMVarContext mvarId do
  let target ← getMVarType' mvarId
  let some (_, lhs, rhs) := target.eq? | throwTacticEx `deltaLHS mvarId "equality expected"
  let some lhs ← delta? lhs | throwTacticEx `deltaLHS mvarId "failed to delta reduce lhs"
  replaceTargetDefEq mvarId (← mkEq lhs rhs)

def deltaRHS? (mvarId : MVarId) (declName : Name) : MetaM (Option MVarId) := withMVarContext mvarId do
  let target ← getMVarType' mvarId
  let some (_, lhs, rhs) := target.eq? | throwTacticEx `deltaRHS mvarId "equality expected"
  let some rhs ← delta? rhs.consumeMData (. == declName) | return none
  replaceTargetDefEq mvarId (← mkEq lhs rhs)

private partial def whnfAux (e : Expr) : MetaM Expr := do
  let e ← whnfI e -- Must reduce instances too, otherwise it will not be able to reduce `(Nat.rec ... ... (OfNat.ofNat 0))`
  let f := e.getAppFn
  match f with
  | Expr.proj _ _ s _ => return mkAppN (f.updateProj! (← whnfAux s)) e.getAppArgs
  | _ => return e

/-- Apply `whnfR` to lhs, return `none` if `lhs` was not modified -/
def whnfReducibleLHS? (mvarId : MVarId) : MetaM (Option MVarId) := withMVarContext mvarId do
  let target ← getMVarType' mvarId
  let some (_, lhs, rhs) := target.eq? | throwTacticEx `whnfReducibleLHS mvarId "equality expected"
  let lhs' ← whnfAux lhs
  if lhs' != lhs then
    return some (← replaceTargetDefEq mvarId (← mkEq lhs' rhs))
  else
    return none

def tryContradiction (mvarId : MVarId) : MetaM Bool := do
  try contradiction mvarId { genDiseq := true }; return true catch _ => return false

structure UnfoldEqnExtState where
  map : Std.PHashMap Name Name := {}
  deriving Inhabited

/- We generate the unfold equation on demand, and do not save them on .olean files. -/
builtin_initialize unfoldEqnExt : EnvExtension UnfoldEqnExtState ←
  registerEnvExtension (pure {})

/--
  Auxiliary method for `mkUnfoldEq`. The structure is based on `mkEqnTypes`.
  `mvarId` is the goal to be proved. It is a goal of the form
  ```
  declName x_1 ... x_n = body[x_1, ..., x_n]
  ```
  The proof is constracted using the automatically generated equational theorems.
  We basically keep splitting the `match` and `if-then-else` expressions in the right hand side
  until one of the equational theorems is applicable.
-/
partial def mkUnfoldProof (declName : Name) (mvarId : MVarId) : MetaM Unit := do
  let some eqs ← getEqnsFor? declName | throwError "failed to generate equations for '{declName}'"
  let tryEqns (mvarId : MVarId) : MetaM Bool :=
    eqs.anyM fun eq => commitWhen do
      try
        let subgoals ← apply mvarId (← mkConstWithFreshMVarLevels eq)
        subgoals.allM assumptionCore
      catch _ =>
        return false
  let rec go (mvarId : MVarId) : MetaM Unit := do
    if (← tryEqns mvarId) then
      return ()
    else if let some mvarId ← funext? mvarId then
      go mvarId
    else if let some mvarId ← simpMatch? mvarId then
      go mvarId
    else if let some mvarIds ← splitTarget? mvarId then
      mvarIds.forM go
    else
     throwError "failed to generate unfold theorem for '{declName}'\n{MessageData.ofGoal mvarId}"
  go mvarId

/-- Generate the "unfold" lemma for `declName`. -/
def mkUnfoldEq (declName : Name) (info : EqnInfoCore) : MetaM Name := withLCtx {} {} do
  let env ← getEnv
  withOptions (tactic.hygienic.set . false) do
    let baseName := mkPrivateName env declName
    lambdaTelescope info.value fun xs body => do
      let us := info.levelParams.map mkLevelParam
      let type ← mkEq (mkAppN (Lean.mkConst declName us) xs) body
      let goal ← mkFreshExprSyntheticOpaqueMVar type
      mkUnfoldProof declName goal.mvarId!
      let type ← mkForallFVars xs type
      let value ← mkLambdaFVars xs (← instantiateMVars goal)
      let name := baseName ++ `_unfold
      addDecl <| Declaration.thmDecl {
        name, type, value
        levelParams := info.levelParams
      }
      return name

def getUnfoldFor? (declName : Name) (getInfo? : Unit → Option EqnInfoCore) : MetaM (Option Name) := do
  let env ← getEnv
  if let some eq := unfoldEqnExt.getState env |>.map.find? declName then
    return some eq
  else if let some info := getInfo? () then
    let eq ← mkUnfoldEq declName info
    modifyEnv fun env => unfoldEqnExt.modifyState env fun s => { s with map := s.map.insert declName eq }
    return some eq
  else
    return none

builtin_initialize
  registerTraceClass `Elab.definition.unfoldEqn

end Lean.Elab.Eqns


namespace util.data.nonempty_list

universe u
variable {α : Type u}

-- structure nonempty_list (α : Type u) :=
--   (head : α)
--   (tail : list α)

inductive nonempty_list (α : Type u)
| singleton : α → nonempty_list
| cons : α → nonempty_list → nonempty_list

namespace nonempty_list

-- def singleton : α → nonempty_list α := λ x, { head := x, tail := [] }

@[reducible] def head : nonempty_list α → α
| (nonempty_list.singleton x) := x
| (nonempty_list.cons x _)    := x

@[reducible] def to_list : nonempty_list α → list α
| (singleton x) := [x]
| (cons x xs)   := x :: to_list xs

@[reducible] def tail : nonempty_list α → list α
| (singleton _) := []
| (cons _ xs)   := to_list xs

-- def append (xs : nonempty_list α) (ys : nonempty_list α) : nonempty_list α := {
--   head := xs.head,
--   tail := xs.tail ++ ys.to_list
-- }

def append : nonempty_list α → nonempty_list α → nonempty_list α
| (singleton x) ys := cons x ys
| (cons x xs)   ys := cons x (append xs ys)

instance : has_append (nonempty_list α) := ⟨ append ⟩

-- lemma append_assoc : Π (xs ys zs : nonempty_list α), append (append xs ys) zs = append xs (append ys zs) :=
-- begin
--   intros,
--   unfold append,
--   simp
-- end

@[simp] lemma singleton_append (x : α) (xs : nonempty_list α) : singleton x ++ xs = cons x xs :=
rfl

@[simp] lemma cons_append (x : α) (xs : nonempty_list α) (ys : nonempty_list α) : cons x xs ++ ys = cons x (xs ++ ys) :=
rfl

lemma append_assoc (xs ys zs : nonempty_list α) : (xs ++ ys) ++ zs = xs ++ (ys ++ zs) :=
begin
  induction xs,
  simp *,
  simp *
end

end nonempty_list

end util.data.nonempty_list


/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sebastian Ullrich, Leonardo de Moura
-/
prelude
import Init.SimpLemmas
import Init.Control.Except
import Init.Control.StateRef

open Function

@[simp] theorem monadLift_self [Monad m] (x : m α) : monadLift x = x :=
  rfl

class LawfulFunctor (f : Type u → Type v) [Functor f] : Prop where
  map_const          : (Functor.mapConst : α → f β → f α) = Functor.map ∘ const β
  id_map   (x : f α) : id <$> x = x
  comp_map (g : α → β) (h : β → γ) (x : f α) : (h ∘ g) <$> x = h <$> g <$> x

export LawfulFunctor (map_const id_map comp_map)

attribute [simp] id_map

@[simp] theorem id_map' [Functor m] [LawfulFunctor m] (x : m α) : (fun a => a) <$> x = x :=
  id_map x

class LawfulApplicative (f : Type u → Type v) [Applicative f] extends LawfulFunctor f : Prop where
  seqLeft_eq  (x : f α) (y : f β)     : x <* y = const β <$> x <*> y
  seqRight_eq (x : f α) (y : f β)     : x *> y = const α id <$> x <*> y
  pure_seq    (g : α → β) (x : f α)   : pure g <*> x = g <$> x
  map_pure    (g : α → β) (x : α)     : g <$> (pure x : f α) = pure (g x)
  seq_pure    {α β : Type u} (g : f (α → β)) (x : α) : g <*> pure x = (fun h => h x) <$> g
  seq_assoc   {α β γ : Type u} (x : f α) (g : f (α → β)) (h : f (β → γ)) : h <*> (g <*> x) = ((@comp α β γ) <$> h) <*> g <*> x
  comp_map g h x := (by
    repeat rw [← pure_seq]
    simp [seq_assoc, map_pure, seq_pure])

export LawfulApplicative (seqLeft_eq seqRight_eq pure_seq map_pure seq_pure seq_assoc)

attribute [simp] map_pure seq_pure

@[simp] theorem pure_id_seq [Applicative f] [LawfulApplicative f] (x : f α) : pure id <*> x = x := by
  simp [pure_seq]

class LawfulMonad (m : Type u → Type v) [Monad m] extends LawfulApplicative m : Prop where
  bind_pure_comp (f : α → β) (x : m α) : x >>= (fun a => pure (f a)) = f <$> x
  bind_map       {α β : Type u} (f : m (α → β)) (x : m α) : f >>= (. <$> x) = f <*> x
  pure_bind      (x : α) (f : α → m β) : pure x >>= f = f x
  bind_assoc     (x : m α) (f : α → m β) (g : β → m γ) : x >>= f >>= g = x >>= fun x => f x >>= g
  map_pure g x    := (by rw [← bind_pure_comp, pure_bind])
  seq_pure g x    := (by rw [← bind_map]; simp [map_pure, bind_pure_comp])
  seq_assoc x g h := (by simp [← bind_pure_comp, ← bind_map, bind_assoc, pure_bind])

export LawfulMonad (bind_pure_comp bind_map pure_bind bind_assoc)
attribute [simp] pure_bind bind_assoc

@[simp] theorem bind_pure [Monad m] [LawfulMonad m] (x : m α) : x >>= pure = x := by
  show x >>= (fun a => pure (id a)) = x
  rw [bind_pure_comp, id_map]

theorem map_eq_pure_bind [Monad m] [LawfulMonad m] (f : α → β) (x : m α) : f <$> x = x >>= fun a => pure (f a) := by
  rw [← bind_pure_comp]

theorem seq_eq_bind_map {α β : Type u} [Monad m] [LawfulMonad m] (f : m (α → β)) (x : m α) : f <*> x = f >>= (. <$> x) := by
  rw [← bind_map]

theorem bind_congr [Bind m] {x : m α} {f g : α → m β} (h : ∀ a, f a = g a) : x >>= f = x >>= g := by
  simp [funext h]

@[simp] theorem bind_pure_unit [Monad m] [LawfulMonad m] {x : m PUnit} : (x >>= fun _ => pure ⟨⟩) = x := by
  rw [bind_pure]

theorem map_congr [Functor m] {x : m α} {f g : α → β} (h : ∀ a, f a = g a) : (f <$> x : m β) = g <$> x := by
  simp [funext h]

theorem seq_eq_bind {α β : Type u} [Monad m] [LawfulMonad m] (mf : m (α → β)) (x : m α) : mf <*> x = mf >>= fun f => f <$> x := by
  rw [bind_map]

theorem seqRight_eq_bind [Monad m] [LawfulMonad m] (x : m α) (y : m β) : x *> y = x >>= fun _ => y := by
  rw [seqRight_eq]
  simp [map_eq_pure_bind, seq_eq_bind_map, const]

theorem seqLeft_eq_bind [Monad m] [LawfulMonad m] (x : m α) (y : m β) : x <* y = x >>= fun a => y >>= fun _ => pure a := by
  rw [seqLeft_eq]; simp [map_eq_pure_bind, seq_eq_bind_map]

/-! # Id -/

namespace Id

@[simp] theorem map_eq (x : Id α) (f : α → β) : f <$> x = f x := rfl
@[simp] theorem bind_eq (x : Id α) (f : α → id β) : x >>= f = f x := rfl
@[simp] theorem pure_eq (a : α) : (pure a : Id α) = a := rfl

instance : LawfulMonad Id := by
  refine' { .. } <;> intros <;> rfl

end Id

/-! # ExceptT -/

namespace ExceptT

theorem ext [Monad m] {x y : ExceptT ε m α} (h : x.run = y.run) : x = y := by
  simp [run] at h
  assumption

@[simp] theorem run_pure [Monad m] (x : α) : run (pure x : ExceptT ε m α) = pure (Except.ok x) := rfl

@[simp] theorem run_lift  [Monad.{u, v} m] (x : m α) : run (ExceptT.lift x : ExceptT ε m α) = (Except.ok <$> x : m (Except ε α)) := rfl

@[simp] theorem run_throw [Monad m] : run (throw e : ExceptT ε m β) = pure (Except.error e) := rfl

@[simp] theorem run_bind_lift [Monad m] [LawfulMonad m] (x : m α) (f : α → ExceptT ε m β) : run (ExceptT.lift x >>= f : ExceptT ε m β) = x >>= fun a => run (f a) := by
  simp[ExceptT.run, ExceptT.lift, bind, ExceptT.bind, ExceptT.mk, ExceptT.bindCont, map_eq_pure_bind]

@[simp] theorem bind_throw [Monad m] [LawfulMonad m] (f : α → ExceptT ε m β) : (throw e >>= f) = throw e := by
  simp [throw, throwThe, MonadExceptOf.throw, bind, ExceptT.bind, ExceptT.bindCont, ExceptT.mk]

theorem run_bind [Monad m] (x : ExceptT ε m α)
        : run (x >>= f : ExceptT ε m β)
          =
          run x >>= fun
                     | Except.ok x => run (f x)
                     | Except.error e => pure (Except.error e) :=
  rfl

@[simp] theorem lift_pure [Monad m] [LawfulMonad m] (a : α) : ExceptT.lift (pure a) = (pure a : ExceptT ε m α) := by
  simp [ExceptT.lift, pure, ExceptT.pure]

@[simp] theorem run_map [Monad m] [LawfulMonad m] (f : α → β) (x : ExceptT ε m α)
    : (f <$> x).run = Except.map f <$> x.run := by
  simp [Functor.map, ExceptT.map, map_eq_pure_bind]
  apply bind_congr
  intro a; cases a <;> simp [Except.map]

protected theorem seq_eq {α β ε : Type u} [Monad m] (mf : ExceptT ε m (α → β)) (x : ExceptT ε m α) : mf <*> x = mf >>= fun f => f <$> x :=
  rfl

protected theorem bind_pure_comp [Monad m] [LawfulMonad m] (f : α → β) (x : ExceptT ε m α) : x >>= pure ∘ f = f <$> x := by
  intros; rfl

protected theorem seqLeft_eq {α β ε : Type u} {m : Type u → Type v} [Monad m] [LawfulMonad m] (x : ExceptT ε m α) (y : ExceptT ε m β) : x <* y = const β <$> x <*> y := by
  show (x >>= fun a => y >>= fun _ => pure a) = (const (α := α) β <$> x) >>= fun f => f <$> y
  rw [← ExceptT.bind_pure_comp]
  apply ext
  simp [run_bind]
  apply bind_congr
  intro
  | Except.error _ => simp
  | Except.ok _ =>
    simp [map_eq_pure_bind]; apply bind_congr; intro b;
    cases b <;> simp [comp, Except.map, const]

protected theorem seqRight_eq [Monad m] [LawfulMonad m] (x : ExceptT ε m α) (y : ExceptT ε m β) : x *> y = const α id <$> x <*> y := by
  show (x >>= fun _ => y) = (const α id <$> x) >>= fun f => f <$> y
  rw [← ExceptT.bind_pure_comp]
  apply ext
  simp [run_bind]
  apply bind_congr
  intro a; cases a <;> simp

instance [Monad m] [LawfulMonad m] : LawfulMonad (ExceptT ε m) where
  id_map         := by intros; apply ext; simp
  map_const      := by intros; rfl
  seqLeft_eq     := ExceptT.seqLeft_eq
  seqRight_eq    := ExceptT.seqRight_eq
  pure_seq       := by intros; apply ext; simp [ExceptT.seq_eq, run_bind]
  bind_pure_comp := ExceptT.bind_pure_comp
  bind_map       := by intros; rfl
  pure_bind      := by intros; apply ext; simp [run_bind]
  bind_assoc     := by intros; apply ext; simp [run_bind]; apply bind_congr; intro a; cases a <;> simp

end ExceptT

/-! # ReaderT -/

namespace ReaderT

theorem ext {x y : ReaderT ρ m α} (h : ∀ ctx, x.run ctx = y.run ctx) : x = y := by
  simp [run] at h
  exact funext h

@[simp] theorem run_pure [Monad m] (a : α) (ctx : ρ) : (pure a : ReaderT ρ m α).run ctx = pure a := rfl

@[simp] theorem run_bind [Monad m] (x : ReaderT ρ m α) (f : α → ReaderT ρ m β) (ctx : ρ)
    : (x >>= f).run ctx = x.run ctx >>= λ a => (f a).run ctx := rfl

@[simp] theorem run_mapConst [Monad m] (a : α) (x : ReaderT ρ m β) (ctx : ρ)
    : (Functor.mapConst a x).run ctx = Functor.mapConst a (x.run ctx) := rfl

@[simp] theorem run_map [Monad m] (f : α → β) (x : ReaderT ρ m α) (ctx : ρ)
    : (f <$> x).run ctx = f <$> x.run ctx := rfl

@[simp] theorem run_monadLift [MonadLiftT n m] (x : n α) (ctx : ρ)
    : (monadLift x : ReaderT ρ m α).run ctx = (monadLift x : m α) := rfl

@[simp] theorem run_monadMap [MonadFunctor n m] (f : {β : Type u} → n β → n β) (x : ReaderT ρ m α) (ctx : ρ)
    : (monadMap @f x : ReaderT ρ m α).run ctx = monadMap @f (x.run ctx) := rfl

@[simp] theorem run_read [Monad m] (ctx : ρ) : (ReaderT.read : ReaderT ρ m ρ).run ctx = pure ctx := rfl

@[simp] theorem run_seq {α β : Type u} [Monad m] (f : ReaderT ρ m (α → β)) (x : ReaderT ρ m α) (ctx : ρ)
    : (f <*> x).run ctx = (f.run ctx <*> x.run ctx) := rfl

@[simp] theorem run_seqRight [Monad m] (x : ReaderT ρ m α) (y : ReaderT ρ m β) (ctx : ρ)
    : (x *> y).run ctx = (x.run ctx *> y.run ctx) := rfl

@[simp] theorem run_seqLeft [Monad m] (x : ReaderT ρ m α) (y : ReaderT ρ m β) (ctx : ρ)
    : (x <* y).run ctx = (x.run ctx <* y.run ctx) := rfl

instance [Monad m] [LawfulFunctor m] : LawfulFunctor (ReaderT ρ m) where
  id_map    := by intros; apply ext; simp
  map_const := by intros; funext a b; apply ext; intros; simp [map_const]
  comp_map  := by intros; apply ext; intros; simp [comp_map]

instance [Monad m] [LawfulApplicative m] : LawfulApplicative (ReaderT ρ m) where
  seqLeft_eq  := by intros; apply ext; intros; simp [seqLeft_eq]
  seqRight_eq := by intros; apply ext; intros; simp [seqRight_eq]
  pure_seq    := by intros; apply ext; intros; simp [pure_seq]
  map_pure    := by intros; apply ext; intros; simp [map_pure]
  seq_pure    := by intros; apply ext; intros; simp [seq_pure]
  seq_assoc   := by intros; apply ext; intros; simp [seq_assoc]

instance [Monad m] [LawfulMonad m] : LawfulMonad (ReaderT ρ m) where
  bind_pure_comp := by intros; apply ext; intros; simp [LawfulMonad.bind_pure_comp]
  bind_map       := by intros; apply ext; intros; simp [bind_map]
  pure_bind      := by intros; apply ext; intros; simp
  bind_assoc     := by intros; apply ext; intros; simp

end ReaderT

/-! # StateRefT -/

instance [Monad m] [LawfulMonad m] : LawfulMonad (StateRefT' ω σ m) :=
  inferInstanceAs (LawfulMonad (ReaderT (ST.Ref ω σ) m))

/-! # StateT -/

namespace StateT

theorem ext {x y : StateT σ m α} (h : ∀ s, x.run s = y.run s) : x = y :=
  funext h

@[simp] theorem run'_eq [Monad m] (x : StateT σ m α) (s : σ) : run' x s = (·.1) <$> run x s :=
  rfl

@[simp] theorem run_pure [Monad m] (a : α) (s : σ) : (pure a : StateT σ m α).run s = pure (a, s) := rfl

@[simp] theorem run_bind [Monad m] (x : StateT σ m α) (f : α → StateT σ m β) (s : σ)
    : (x >>= f).run s = x.run s >>= λ p => (f p.1).run p.2 := by
  simp [bind, StateT.bind, run]

@[simp] theorem run_map {α β σ : Type u} [Monad m] [LawfulMonad m] (f : α → β) (x : StateT σ m α) (s : σ) : (f <$> x).run s = (fun (p : α × σ) => (f p.1, p.2)) <$> x.run s := by
  simp [Functor.map, StateT.map, run, map_eq_pure_bind]

@[simp] theorem run_get [Monad m] (s : σ)    : (get : StateT σ m σ).run s = pure (s, s) := rfl

@[simp] theorem run_set [Monad m] (s s' : σ) : (set s' : StateT σ m PUnit).run s = pure (⟨⟩, s') := rfl

@[simp] theorem run_modify [Monad m] (f : σ → σ) (s : σ) : (modify f : StateT σ m PUnit).run s = pure (⟨⟩, f s) := rfl

@[simp] theorem run_modifyGet [Monad m] (f : σ → α × σ) (s : σ) : (modifyGet f : StateT σ m α).run s = pure ((f s).1, (f s).2) := by
  simp [modifyGet, MonadStateOf.modifyGet, StateT.modifyGet, run]

@[simp] theorem run_lift {α σ : Type u} [Monad m] (x : m α) (s : σ) : (StateT.lift x : StateT σ m α).run s = x >>= fun a => pure (a, s) := rfl

@[simp] theorem run_bind_lift {α σ : Type u} [Monad m] [LawfulMonad m] (x : m α) (f : α → StateT σ m β) (s : σ) : (StateT.lift x >>= f).run s = x >>= fun a => (f a).run s := by
  simp [StateT.lift, StateT.run, bind, StateT.bind]

@[simp] theorem run_monadLift {α σ : Type u} [Monad m] [MonadLiftT n m] (x : n α) (s : σ) : (monadLift x : StateT σ m α).run s = (monadLift x : m α) >>= fun a => pure (a, s) := rfl

@[simp] theorem run_monadMap [Monad m] [MonadFunctor n m] (f : {β : Type u} → n β → n β) (x : StateT σ m α) (s : σ)
    : (monadMap @f x : StateT σ m α).run s = monadMap @f (x.run s) := rfl

@[simp] theorem run_seq {α β σ : Type u} [Monad m] [LawfulMonad m] (f : StateT σ m (α → β)) (x : StateT σ m α) (s : σ) : (f <*> x).run s = (f.run s >>= fun fs => (fun (p : α × σ) => (fs.1 p.1, p.2)) <$> x.run fs.2) := by
  show (f >>= fun g => g <$> x).run s = _
  simp

@[simp] theorem run_seqRight [Monad m] [LawfulMonad m] (x : StateT σ m α) (y : StateT σ m β) (s : σ) : (x *> y).run s = (x.run s >>= fun p => y.run p.2) := by
  show (x >>= fun _ => y).run s = _
  simp

@[simp] theorem run_seqLeft {α β σ : Type u} [Monad m] [LawfulMonad m] (x : StateT σ m α) (y : StateT σ m β) (s : σ) : (x <* y).run s = (x.run s >>= fun p => y.run p.2 >>= fun p' => pure (p.1, p'.2)) := by
  show (x >>= fun a => y >>= fun _ => pure a).run s = _
  simp

theorem seqRight_eq [Monad m] [LawfulMonad m] (x : StateT σ m α) (y : StateT σ m β) : x *> y = const α id <$> x <*> y := by
  apply ext; intro s
  simp [map_eq_pure_bind, const]
  apply bind_congr; intro p; cases p
  simp [Prod.eta]

theorem seqLeft_eq [Monad m] [LawfulMonad m] (x : StateT σ m α) (y : StateT σ m β) : x <* y = const β <$> x <*> y := by
  apply ext; intro s
  simp [map_eq_pure_bind]

instance [Monad m] [LawfulMonad m] : LawfulMonad (StateT σ m) where
  id_map         := by intros; apply ext; intros; simp[Prod.eta]
  map_const      := by intros; rfl
  seqLeft_eq     := seqLeft_eq
  seqRight_eq    := seqRight_eq
  pure_seq       := by intros; apply ext; intros; simp
  bind_pure_comp := by intros; apply ext; intros; simp; apply LawfulMonad.bind_pure_comp
  bind_map       := by intros; rfl
  pure_bind      := by intros; apply ext; intros; simp
  bind_assoc     := by intros; apply ext; intros; simp

end StateT


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

namespace Lean.Compiler

scoped notation:max "◾" => lcErased

namespace LCNF

def erasedExpr := mkConst ``lcErased

def _root_.Lean.Expr.isErased (e : Expr) :=
  e.isAppOf ``lcErased

def isPropFormerTypeQuick : Expr → Bool
  | .forallE _ _ b _ => isPropFormerTypeQuick b
  | .sort .zero => true
  | _ => false

/--
Return true iff `type` is `Prop` or `As → Prop`.
-/
partial def isPropFormerType (type : Expr) : MetaM Bool := do
  match isPropFormerTypeQuick type with
  | true => return true
  | false => go type #[]
where
  go (type : Expr) (xs : Array Expr) : MetaM Bool := do
    match type with
    | .sort .zero => return true
    | .forallE n d b c => Meta.withLocalDecl n c (d.instantiateRev xs) fun x => go b (xs.push x)
    | _ =>
      let type ← Meta.whnfD (type.instantiateRev xs)
      match type with
      | .sort .zero => return true
      | .forallE .. => go type #[]
      | _ => return false

/--
Return true iff `e : Prop` or `e : As → Prop`.
-/
def isPropFormer (e : Expr) : MetaM Bool := do
  isPropFormerType (← Meta.inferType e)

/-!
The code generator uses a format based on A-normal form.
This normal form uses many let-expressions and it is very convenient for
applying compiler transformations. However, it creates a few issues
in a dependently typed programming language.

- Many casts are needed.
- It is too expensive to ensure we are not losing typeability when creating join points
  and simplifying let-values
- It may not be possible to create a join point because the resulting expression is
  not type correct. For example, suppose we are trying to create a join point for
  making the following `match` terminal.
  ```
  let x := match a with | true => b | false => c;
  k[x]
  ```
  and want to transform this code into
  ```
  let jp := fun x => k[x]
  match a with
  | true => jp b
  | false => jp c
  ```
  where `jp` is a new join point (i.e., a local function that is always fully applied and
  tail recursive). In many examples in the Lean code-base, we have to skip this transformation
  because it produces a type-incorrect term. Recall that types/propositions in `k[x]` may rely on
  the fact that `x` is definitionally equal to `match a with ...` before the creation of
  the join point.

Thus, in the first code generator pass, we convert types into a `LCNFType` (Lean Compiler Normal Form Type).
The method `toLCNFType` produces a type with the following properties:

- All constants occurring in the result type are inductive datatypes.
- The arguments of type formers are type formers, or `◾`. We use `◾` to denote erased information.
- All type definitions are expanded. If reduction gets stuck, it is replaced with `◾`.

Remark: you can view `◾` occurring in a type position as the "any type".
Remark: in our runtime, `◾` is represented as `box(0)`.

The goal is to preserve as much information as possible and avoid the problems described above.
Then, we don't have `let x := v; ...` in LCNF code when `x` is a type former.
If the user provides a `let x := v; ...` where x is a type former, we can always expand it when
converting into LCNF.
Thus, given a `let x := v, ...` in occurring in LCNF, we know `x` cannot occur in any type since it is
not a type former.

We try to preserve type information because they unlock new optimizations, and we can type check
the result produced by each code generator step.

Below, we provide some example programs and their erased variants:
-- 1. Source type: `f: (n: Nat) -> (tupleN Nat n)`.
      LCNF type: `f: Nat -> ◾`.
      We convert the return type `(tupleN Nat n) to `◾`, since we cannot reduce
      `(tupleN Nat n)` to a term of the form `(InductiveTy ...)`.

-- 2. Source type: `f: (n: Nat) (fin: Fin n) -> (tupleN Nat fin)`.
      LCNF type: `f: Nat -> Fin ◾ -> ◾`.
      Since `(Fin n)` has dependency on `n`, we erase the `n` to get the
      type `(Fin ◾)`.
-/

open Meta in
/--
Convert a Lean type into a LCNF type used by the code generator.
-/
partial def toLCNFType (type : Expr) : MetaM Expr := do
  if (← isProp type) then
    return erasedExpr
  let type ← whnfEta type
  match type with
  | .sort u     => return .sort u
  | .const ..   => visitApp type #[]
  | .lam n d b bi =>
    withLocalDecl n bi d fun x => do
      let d ← toLCNFType d
      let b ← toLCNFType (b.instantiate1 x)
      if b.isErased then
        return b
      else
        return Expr.lam n d (b.abstract #[x]) bi
  | .forallE .. => visitForall type #[]
  | .app ..  => type.withApp visitApp
  | .fvar .. => visitApp type #[]
  | _        => return erasedExpr
where
  whnfEta (type : Expr) : MetaM Expr := do
    let type ← whnf type
    let type' := type.eta
    if type' != type then
      whnfEta type'
    else
      return type

  visitForall (e : Expr) (xs : Array Expr) : MetaM Expr := do
    match e with
    | .forallE n d b bi =>
      let d := d.instantiateRev xs
      withLocalDecl n bi d fun x => do
        let d := (← toLCNFType d).abstract xs
        return .forallE n d (← visitForall b (xs.push x)) bi
    | _ =>
      let e ← toLCNFType (e.instantiateRev xs)
      return e.abstract xs

  visitApp (f : Expr) (args : Array Expr) := do
    let fNew ← match f with
      | .const declName us =>
        let .inductInfo _ ← getConstInfo declName | return erasedExpr
        pure <| .const declName us
      | .fvar .. => pure f
      | _ => return erasedExpr
    let mut result := fNew
    for arg in args do
      if (← isProp arg) then
        result := mkApp result erasedExpr
      else if (← isPropFormer arg) then
        result := mkApp result erasedExpr
      else if (← isTypeFormer arg) then
        result := mkApp result (← toLCNFType arg)
      else
        result := mkApp result erasedExpr
    return result

mutual

partial def joinTypes (a b : Expr) : Expr :=
  joinTypes? a b |>.getD erasedExpr

partial def joinTypes? (a b : Expr) : Option Expr := do
  if a.isErased || b.isErased then
    return erasedExpr -- See comment at `compatibleTypes`.
  else if a == b then
    return a
  else
    let a' := a.headBeta
    let b' := b.headBeta
    if a != a' || b != b' then
      joinTypes? a' b'
    else
      match a, b with
      | .mdata _ a, b => joinTypes? a b
      | a, .mdata _ b => joinTypes? a b
      | .app f a, .app g b =>
        (do return .app (← joinTypes? f g) (← joinTypes? a b))
         <|>
        return erasedExpr
      | .forallE n d₁ b₁ _, .forallE _ d₂ b₂ _ =>
        (do return .forallE n (← joinTypes? d₁ d₂) (joinTypes b₁ b₂) .default)
        <|>
        return erasedExpr
      | .lam n d₁ b₁ _, .lam _ d₂ b₂ _ =>
        (do return .lam n (← joinTypes? d₁ d₂) (joinTypes b₁ b₂) .default)
        <|>
        return erasedExpr
      | _, _ => return erasedExpr

end

/--
Return `true` if `type` is a LCNF type former type.

Remark: This is faster than `Lean.Meta.isTypeFormer`, as this
        assumes that the input `type` is an LCNF type.
-/
partial def isTypeFormerType (type : Expr) : Bool :=
  match type.headBeta with
  | .sort .. => true
  | .forallE _ _ b _ => isTypeFormerType b
  | _ => false

/--
Given a LCNF `type` of the form `forall (a_1 : A_1) ... (a_n : A_n), B[a_1, ..., a_n]` and `p_1 : A_1, ... p_n : A_n`,
return `B[p_1, ..., p_n]`.

Remark: similar to `Meta.instantiateForall`, buf for LCNF types.
-/
def instantiateForall (type : Expr) (ps : Array Expr) : CoreM Expr :=
  go 0 type
where
  go (i : Nat) (type : Expr) : CoreM Expr :=
    if h : i < ps.size then
      if let .forallE _ _ b _ := type.headBeta then
        go (i+1) (b.instantiate1 ps[i])
      else
        throwError "invalid instantiateForall, too many parameters"
    else
      return type
termination_by go i _ => ps.size - i

/--
Return `true` if `type` is a predicate.
Examples: `Nat → Prop`, `Prop`, `Int → Bool → Prop`.
-/
partial def isPredicateType (type : Expr) : Bool :=
  match type.headBeta with
  | .sort .zero => true
  | .forallE _ _ b _ => isPredicateType b
  | _ => false

/--
Return `true` if `type` is a LCNF type former type or it is an "any" type.
This function is similar to `isTypeFormerType`, but more liberal.
For example, `isTypeFormerType` returns false for `◾` and `Nat → ◾`, but
this function returns true.
-/
partial def maybeTypeFormerType (type : Expr) : Bool :=
  match type.headBeta with
  | .sort .. => true
  | .forallE _ _ b _ => maybeTypeFormerType b
  | _ => type.isErased

/--
`isClass? type` return `some ClsName` if the LCNF `type` is an instance of the class `ClsName`.
-/
def isClass? (type : Expr) : CoreM (Option Name) := do
  let .const declName _ := type.getAppFn | return none
  if isClass (← getEnv) declName then
    return declName
  else
    return none

/--
`isArrowClass? type` return `some ClsName` if the LCNF `type` is an instance of the class `ClsName`, or
if it is arrow producing an instance of the class `ClsName`.
-/
partial def isArrowClass? (type : Expr) : CoreM (Option Name) := do
  match type.headBeta with
  | .forallE _ _ b _ => isArrowClass? b
  | _ => isClass? type

partial def getArrowArity (e : Expr) :=
  match e.headBeta with
  | .forallE _ _ b _ => getArrowArity b + 1
  | _ => 0

/-- Return `true` if `type` is an inductive datatype with 0 constructors. -/
def isInductiveWithNoCtors (type : Expr) : CoreM Bool := do
  let .const declName _ := type.getAppFn | return false
  let some (.inductInfo info) := (← getEnv).find? declName | return false
  return info.numCtors == 0

end Lean.Compiler.LCNF