// If restricted is true, we don't use (e <-> true) rewrite
list<expr_pair> apply(expr const & e, expr const & H, bool restrited) {
expr c, Hdec, A, arg1, arg2;
if (is_relation(e)) {
return mk_singleton(e, H);
} else if (is_standard(m_env) && is_not(m_env, e, arg1)) {
expr new_e = mk_iff(arg1, mk_false());
expr new_H = mk_app(mk_constant(get_iff_false_intro_name()), arg1, H);
return mk_singleton(new_e, new_H);
} else if (is_standard(m_env) && is_and(e, arg1, arg2)) {
// TODO(Leo): we can extend this trick to any type that has only one constructor
expr H1 = mk_app(mk_constant(get_and_elim_left_name()), arg1, arg2, H);
expr H2 = mk_app(mk_constant(get_and_elim_right_name()), arg1, arg2, H);
auto r1 = apply(arg1, H1, restrited);
auto r2 = apply(arg2, H2, restrited);
return append(r1, r2);
} else if (is_pi(e)) {
expr local = mk_local(m_tc.mk_fresh_name(), binding_name(e), binding_domain(e), binding_info(e));
expr new_e = instantiate(binding_body(e), local);
expr new_H = mk_app(H, local);
auto r = apply(new_e, new_H, restrited);
unsigned len = length(r);
if (len == 0) {
return r;
} else if (len == 1 && head(r).first == new_e && head(r).second == new_H) {
return mk_singleton(e, H);
} else {
return lift(local, r);
}
} else if (is_standard(m_env) && is_ite(e, c, Hdec, A, arg1, arg2) && is_prop(e)) {
// TODO(Leo): support HoTT mode if users request
expr not_c = mk_not(m_tc, c);
expr Hc = mk_local(m_tc.mk_fresh_name(), c);
expr Hnc = mk_local(m_tc.mk_fresh_name(), not_c);
expr H1 = mk_app({mk_constant(get_implies_of_if_pos_name()),
c, arg1, arg2, Hdec, e, Hc});
expr H2 = mk_app({mk_constant(get_implies_of_if_neg_name()),
c, arg1, arg2, Hdec, e, Hnc});
auto r1 = lift(Hc, apply(arg1, H1, restrited));
auto r2 = lift(Hnc, apply(arg2, H2, restrited));
return append(r1, r2);
} else if (!restrited) {
constraint_seq cs;
expr new_e = m_tc.whnf(e, cs);
if (new_e != e && !cs) {
if (auto r = apply(new_e, H, true))
return r;
}
if (is_standard(m_env) && is_prop(e)) {
expr new_e = mk_iff(e, mk_true());
expr new_H = mk_app(mk_constant(get_iff_true_intro_name()), arg1, H);
return mk_singleton(new_e, new_H);
} else {
return list<expr_pair>();
}
} else {
return list<expr_pair>();
}
}
expr mk_expr_placeholder(optional<expr> const & type, expr_placeholder_kind k) {
name n(to_prefix(k), next_placeholder_id());
if (type)
return mk_local(n, *type);
else
return mk_constant(n);
}
bool match_pattern(type_checker & tc, expr const & pattern, declaration const & d, unsigned max_steps, bool cheap) {
name_generator ngen = tc.mk_ngen();
buffer<level> ls;
unsigned num_ls = d.get_num_univ_params();
for (unsigned i = 0; i < num_ls; i++)
ls.push_back(mk_meta_univ(ngen.next()));
expr dt = instantiate_type_univ_params(d, to_list(ls.begin(), ls.end()));
unsigned num_e = get_expect_num_args(tc, pattern);
unsigned num_d = get_expect_num_args(tc, dt);
if (num_e > num_d)
return false;
for (unsigned i = 0; i < num_d - num_e; i++) {
dt = tc.whnf(dt).first;
expr local = mk_local(ngen.next(), binding_domain(dt));
dt = instantiate(binding_body(dt), local);
}
try {
unifier_config cfg;
cfg.m_max_steps = max_steps;
cfg.m_kind = cheap ? unifier_kind::Cheap : unifier_kind::Liberal;
cfg.m_ignore_context_check = true;
auto r = unify(tc.env(), pattern, dt, tc.mk_ngen(), substitution(), cfg);
return static_cast<bool>(r.pull());
} catch (exception&) {
return false;
}
}
expr update_mlocal(expr const & e, expr const & new_type) {
if (is_eqp(mlocal_type(e), new_type))
return e;
else if (is_metavar(e))
return mk_metavar(mlocal_name(e), new_type, e.get_tag());
else
return mk_local(mlocal_name(e), local_pp_name(e), new_type, local_info(e), e.get_tag());
}
list<expr> get_coercions_from_to(type_checker & from_tc, type_checker & to_tc,
expr const & from_type, expr const & to_type, constraint_seq & cs, bool lift_coe) {
constraint_seq new_cs;
environment const & env = to_tc.env();
expr whnf_from_type = from_tc.whnf(from_type, new_cs);
expr whnf_to_type = to_tc.whnf(to_type, new_cs);
if (lift_coe && is_pi(whnf_from_type)) {
// Try to lift coercions.
// The idea is to convert a coercion from A to B, into a coercion from D->A to D->B
if (!is_pi(whnf_to_type))
return list<expr>(); // failed
if (!from_tc.is_def_eq(binding_domain(whnf_from_type), binding_domain(whnf_to_type), justification(), new_cs))
return list<expr>(); // failed, the domains must be definitionally equal
expr x = mk_local(mk_fresh_name(), "x", binding_domain(whnf_from_type), binder_info());
expr A = instantiate(binding_body(whnf_from_type), x);
expr B = instantiate(binding_body(whnf_to_type), x);
list<expr> coe = get_coercions_from_to(from_tc, to_tc, A, B, new_cs, lift_coe);
if (coe) {
cs += new_cs;
// Remark: each coercion c in coe is a function from A to B
// We create a new list: (fun (f : D -> A) (x : D), c (f x))
expr f = mk_local(mk_fresh_name(), "f", whnf_from_type, binder_info());
expr fx = mk_app(f, x);
return map(coe, [&](expr const & c) { return Fun(f, Fun(x, mk_app(c, fx))); });
} else {
return list<expr>();
}
} else {
expr const & fn = get_app_fn(whnf_to_type);
list<expr> r;
if (is_constant(fn)) {
r = get_coercions(env, whnf_from_type, const_name(fn));
} else if (is_pi(whnf_to_type)) {
r = get_coercions_to_fun(env, whnf_from_type);
} else if (is_sort(whnf_to_type)) {
r = get_coercions_to_sort(env, whnf_from_type);
}
if (r)
cs += new_cs;
return r;
}
}
bool is_ceqv(type_checker & tc, expr e) {
if (has_expr_metavar(e))
return false;
name_set to_find;
// Define a procedure for removing arguments from to_find.
auto visitor_fn = [&](expr const & e, unsigned) {
if (is_local(e)) {
to_find.erase(mlocal_name(e));
return false;
} else if (is_metavar(e)) {
return false;
} else {
return true;
}
};
environment const & env = tc.env();
bool is_std = is_standard(env);
buffer<expr> hypotheses; // arguments that are propositions
while (is_pi(e)) {
if (!to_find.empty()) {
// Support for dependent types.
// We may find the instantiation for the previous arguments
// by matching the type.
for_each(binding_domain(e), visitor_fn);
}
expr local = mk_local(tc.mk_fresh_name(), binding_domain(e));
if (binding_info(e).is_inst_implicit()) {
// If the argument can be instantiated by type class resolution, then
// we don't need to find it in the lhs
} else if (is_std && tc.is_prop(binding_domain(e)).first) {
// If the argument is a proposition, we store it in hypotheses.
// We check whether the lhs occurs in hypotheses or not.
hypotheses.push_back(binding_domain(e));
} else {
to_find.insert(mlocal_name(local));
}
e = instantiate(binding_body(e), local);
}
expr lhs, rhs;
if (!is_simp_relation(env, e, lhs, rhs))
return false;
// traverse lhs, and remove found variables from to_find
for_each(lhs, visitor_fn);
if (!to_find.empty())
return false;
// basic looping ceq detection: the left-hand-side should not occur in the right-hand-side,
// nor it should occur in any of the hypothesis
if (occurs(lhs, rhs))
return false;
if (std::any_of(hypotheses.begin(), hypotheses.end(), [&](expr const & h) { return occurs(lhs, h); }))
return false;
return true;
}
void visit_binding(expr const & _e) {
if (should_visit(_e)) {
buffer<expr> ls;
expr e = _e;
while (is_lambda(e) || is_pi(e)) {
expr d = instantiate_rev(binding_domain(e), ls.size(), ls.data());
expr l = mk_local(mk_fresh_name(), binding_name(e), d, binding_info(e));
ls.push_back(l);
e = binding_body(e);
}
visit(instantiate_rev(e, ls.size(), ls.data()));
}
}
tactic intros_tactic(list<name> _ns, bool relax_main_opaque) {
auto fn = [=](environment const & env, io_state const &, proof_state const & s) {
list<name> ns = _ns;
goals const & gs = s.get_goals();
if (empty(gs)) {
throw_no_goal_if_enabled(s);
return optional<proof_state>();
}
goal const & g = head(gs);
name_generator ngen = s.get_ngen();
auto tc = mk_type_checker(env, ngen.mk_child(), relax_main_opaque);
expr t = g.get_type();
expr m = g.get_meta();
bool gen_names = empty(ns);
try {
while (true) {
if (!gen_names && is_nil(ns))
break;
if (!is_pi(t)) {
if (!is_nil(ns)) {
t = tc->ensure_pi(t).first;
} else {
expr new_t = tc->whnf(t).first;
if (!is_pi(new_t))
break;
t = new_t;
}
}
name new_name;
if (!is_nil(ns)) {
new_name = head(ns);
ns = tail(ns);
} else {
new_name = get_unused_name(binding_name(t), m);
}
expr new_local = mk_local(ngen.next(), new_name, binding_domain(t), binding_info(t));
t = instantiate(binding_body(t), new_local);
m = mk_app(m, new_local);
}
goal new_g(m, t);
return some(proof_state(s, goals(new_g, tail(gs)), ngen));
} catch (exception &) {
return optional<proof_state>();
}
};
return tactic01(fn);
}
optional<constraints> try_instance(expr const & inst, expr const & inst_type) {
type_checker & tc = m_C->tc();
name_generator & ngen = m_C->m_ngen;
tag g = inst.get_tag();
try {
flet<local_context> scope(m_ctx, m_ctx);
buffer<expr> locals;
expr meta_type = m_meta_type;
while (true) {
meta_type = tc.whnf(meta_type).first;
if (!is_pi(meta_type))
break;
expr local = mk_local(ngen.next(), binding_name(meta_type),
binding_domain(meta_type), binding_info(meta_type));
m_ctx.add_local(local);
locals.push_back(local);
meta_type = instantiate(binding_body(meta_type), local);
}
expr type = inst_type;
expr r = inst;
buffer<constraint> cs;
while (true) {
type = tc.whnf(type).first;
if (!is_pi(type))
break;
expr arg;
if (binding_info(type).is_inst_implicit()) {
pair<expr, constraint> ac = mk_class_instance_elaborator(m_C, m_ctx, some_expr(binding_domain(type)),
g, m_depth+1);
arg = ac.first;
cs.push_back(ac.second);
} else {
arg = m_ctx.mk_meta(m_C->m_ngen, some_expr(binding_domain(type)), g);
}
r = mk_app(r, arg, g);
type = instantiate(binding_body(type), arg);
}
r = Fun(locals, r);
trace(meta_type, r);
bool relax = m_C->m_relax;
constraint c = mk_eq_cnstr(m_meta, r, m_jst, relax);
return optional<constraints>(mk_constraints(c, cs));
} catch (exception &) {
return optional<constraints>();
}
}
environment mk_rec_on(environment const & env, name const & n) {
if (!inductive::is_inductive_decl(env, n))
throw exception(sstream() << "error in 'rec_on' generation, '" << n << "' is not an inductive datatype");
name rec_on_name(n, "rec_on");
name_generator ngen;
declaration rec_decl = env.get(inductive::get_elim_name(n));
buffer<expr> locals;
expr rec_type = rec_decl.get_type();
while (is_pi(rec_type)) {
expr local = mk_local(ngen.next(), binding_name(rec_type), binding_domain(rec_type), binding_info(rec_type));
rec_type = instantiate(binding_body(rec_type), local);
locals.push_back(local);
}
// locals order
// A C minor_premises indices major-premise
// new_locals order
// A C indices major-premise minor-premises
buffer<expr> new_locals;
unsigned idx_major_sz = *inductive::get_num_indices(env, n) + 1;
unsigned minor_sz = *inductive::get_num_minor_premises(env, n);
unsigned AC_sz = locals.size() - minor_sz - idx_major_sz;
for (unsigned i = 0; i < AC_sz; i++)
new_locals.push_back(locals[i]);
for (unsigned i = 0; i < idx_major_sz; i++)
new_locals.push_back(locals[AC_sz + minor_sz + i]);
unsigned rec_on_major_idx = new_locals.size() - 1;
for (unsigned i = 0; i < minor_sz; i++)
new_locals.push_back(locals[AC_sz + i]);
expr rec_on_type = Pi(new_locals, rec_type);
levels ls = param_names_to_levels(rec_decl.get_univ_params());
expr rec = mk_constant(rec_decl.get_name(), ls);
expr rec_on_val = Fun(new_locals, mk_app(rec, locals));
bool use_conv_opt = true;
environment new_env = module::add(env,
check(env, mk_definition(env, rec_on_name, rec_decl.get_univ_params(),
rec_on_type, rec_on_val, use_conv_opt)));
new_env = set_reducible(new_env, rec_on_name, reducible_status::Reducible);
new_env = add_unfold_hint(new_env, rec_on_name, rec_on_major_idx);
new_env = add_aux_recursor(new_env, rec_on_name);
return add_protected(new_env, rec_on_name);
}
expr visit_binding(expr e) {
expr_kind k = e.kind();
buffer<expr> es;
buffer<expr> ls;
while (e.kind() == k) {
expr d = visit(instantiate_rev(binding_domain(e), ls.size(), ls.data()));
expr l = mk_local(m_tc.mk_fresh_name(), binding_name(e), d, binding_info(e));
ls.push_back(l);
es.push_back(e);
e = binding_body(e);
}
e = visit(instantiate_rev(e, ls.size(), ls.data()));
expr r = abstract_locals(e, ls.size(), ls.data());
while (!ls.empty()) {
expr d = mlocal_type(ls.back());
ls.pop_back();
d = abstract_locals(d, ls.size(), ls.data());
r = update_binding(es.back(), d, r);
es.pop_back();
}
return r;
}
static environment mk_brec_on(environment const & env, name const & n, bool ind) {
if (!is_recursive_datatype(env, n))
return env;
if (is_inductive_predicate(env, n))
return env;
inductive::inductive_decls decls = *inductive::is_inductive_decl(env, n);
type_checker tc(env);
name_generator ngen;
unsigned nparams = std::get<1>(decls);
declaration ind_decl = env.get(n);
declaration rec_decl = env.get(inductive::get_elim_name(n));
// declaration below_decl = env.get(name(n, ind ? "ibelow" : "below"));
unsigned nindices = *inductive::get_num_indices(env, n);
unsigned nminors = *inductive::get_num_minor_premises(env, n);
unsigned ntypeformers = length(std::get<2>(decls));
level_param_names lps = rec_decl.get_univ_params();
bool is_reflexive = is_reflexive_datatype(tc, n);
level lvl = mk_param_univ(head(lps));
levels lvls = param_names_to_levels(tail(lps));
level rlvl;
level_param_names blps;
levels blvls; // universe level parameters of brec_on/binduction_on
// The arguments of brec_on (binduction_on) are the ones in the recursor - minor premises.
// The universe we map to is also different (l+1 for below of reflexive types) and (0 fo ibelow).
expr ref_type;
if (ind) {
// we are eliminating to Prop
blps = tail(lps);
blvls = lvls;
rlvl = mk_level_zero();
ref_type = instantiate_univ_param(rec_decl.get_type(), param_id(lvl), mk_level_zero());
} else if (is_reflexive) {
blps = lps;
blvls = cons(lvl, lvls);
rlvl = get_datatype_level(ind_decl.get_type());
// if rlvl is of the form (max 1 l), then rlvl <- l
if (is_max(rlvl) && is_one(max_lhs(rlvl)))
rlvl = max_rhs(rlvl);
rlvl = mk_max(mk_succ(lvl), rlvl);
// inner_prod, inner_prod_intro, pr1, pr2 do not use the same universe levels for
// reflective datatypes.
ref_type = instantiate_univ_param(rec_decl.get_type(), param_id(lvl), mk_succ(lvl));
} else {
// we can simplify the universe levels for non-reflexive datatypes
blps = lps;
blvls = cons(lvl, lvls);
rlvl = mk_max(mk_level_one(), lvl);
ref_type = rec_decl.get_type();
}
buffer<expr> ref_args;
to_telescope(ngen, ref_type, ref_args);
if (ref_args.size() != nparams + ntypeformers + nminors + nindices + 1)
throw_corrupted(n);
// args contains the brec_on/binduction_on arguments
buffer<expr> args;
buffer<name> typeformer_names;
// add parameters and typeformers
for (unsigned i = 0; i < nparams; i++)
args.push_back(ref_args[i]);
for (unsigned i = nparams; i < nparams + ntypeformers; i++) {
args.push_back(ref_args[i]);
typeformer_names.push_back(mlocal_name(ref_args[i]));
}
// add indices and major premise
for (unsigned i = nparams + ntypeformers + nminors; i < ref_args.size(); i++)
args.push_back(ref_args[i]);
// create below terms (one per datatype)
// (below.{lvls} params type-formers)
// Remark: it also creates the result type
buffer<expr> belows;
expr result_type;
unsigned k = 0;
for (auto const & decl : std::get<2>(decls)) {
name const & n1 = inductive::inductive_decl_name(decl);
if (n1 == n) {
result_type = ref_args[nparams + k];
for (unsigned i = nparams + ntypeformers + nminors; i < ref_args.size(); i++)
result_type = mk_app(result_type, ref_args[i]);
}
k++;
name bname = name(n1, ind ? "ibelow" : "below");
expr below = mk_constant(bname, blvls);
for (unsigned i = 0; i < nparams; i++)
below = mk_app(below, ref_args[i]);
for (unsigned i = nparams; i < nparams + ntypeformers; i++)
below = mk_app(below, ref_args[i]);
belows.push_back(below);
}
// create functionals (one for each type former)
// Pi idxs t, below idxs t -> C idxs t
buffer<expr> Fs;
name F_name("F");
for (unsigned i = nparams, j = 0; i < nparams + ntypeformers; i++, j++) {
expr const & C = ref_args[i];
buffer<expr> F_args;
to_telescope(ngen, mlocal_type(C), F_args);
expr F_result = mk_app(C, F_args);
expr F_below = mk_app(belows[j], F_args);
F_args.push_back(mk_local(ngen.next(), "f", F_below, binder_info()));
expr F_type = Pi(F_args, F_result);
expr F = mk_local(ngen.next(), F_name.append_after(j+1), F_type, binder_info());
Fs.push_back(F);
args.push_back(F);
}
// We define brec_on/binduction_on using the recursor for this type
levels rec_lvls = cons(rlvl, lvls);
expr rec = mk_constant(rec_decl.get_name(), rec_lvls);
// add parameters to rec
for (unsigned i = 0; i < nparams; i++)
rec = mk_app(rec, ref_args[i]);
// add type formers to rec
// Pi indices t, prod (C ... t) (below ... t)
for (unsigned i = nparams, j = 0; i < nparams + ntypeformers; i++, j++) {
expr const & C = ref_args[i];
buffer<expr> C_args;
to_telescope(ngen, mlocal_type(C), C_args);
expr C_t = mk_app(C, C_args);
expr below_t = mk_app(belows[j], C_args);
expr prod = mk_prod(tc, C_t, below_t, ind);
rec = mk_app(rec, Fun(C_args, prod));
}
// add minor premises to rec
for (unsigned i = nparams + ntypeformers, j = 0; i < nparams + ntypeformers + nminors; i++, j++) {
expr minor = ref_args[i];
expr minor_type = mlocal_type(minor);
buffer<expr> minor_args;
minor_type = to_telescope(ngen, minor_type, minor_args);
buffer<expr> pairs;
for (expr & minor_arg : minor_args) {
buffer<expr> minor_arg_args;
expr minor_arg_type = to_telescope(tc, mlocal_type(minor_arg), minor_arg_args);
if (auto k = is_typeformer_app(typeformer_names, minor_arg_type)) {
buffer<expr> C_args;
get_app_args(minor_arg_type, C_args);
expr new_minor_arg_type = mk_prod(tc, minor_arg_type, mk_app(belows[*k], C_args), ind);
minor_arg = update_mlocal(minor_arg, Pi(minor_arg_args, new_minor_arg_type));
if (minor_arg_args.empty()) {
pairs.push_back(minor_arg);
} else {
expr r = mk_app(minor_arg, minor_arg_args);
expr r_1 = Fun(minor_arg_args, mk_pr1(tc, r, ind));
expr r_2 = Fun(minor_arg_args, mk_pr2(tc, r, ind));
pairs.push_back(mk_pair(tc, r_1, r_2, ind));
}
}
}
expr b = foldr([&](expr const & a, expr const & b) { return mk_pair(tc, a, b, ind); },
[&]() { return mk_unit_mk(rlvl, ind); },
pairs.size(), pairs.data());
unsigned F_idx = *is_typeformer_app(typeformer_names, minor_type);
expr F = Fs[F_idx];
buffer<expr> F_args;
get_app_args(minor_type, F_args);
F_args.push_back(b);
expr new_arg = mk_pair(tc, mk_app(F, F_args), b, ind);
rec = mk_app(rec, Fun(minor_args, new_arg));
}
// add indices and major to rec
for (unsigned i = nparams + ntypeformers + nminors; i < ref_args.size(); i++)
rec = mk_app(rec, ref_args[i]);
name brec_on_name = name(n, ind ? "binduction_on" : "brec_on");
expr brec_on_type = Pi(args, result_type);
expr brec_on_value = Fun(args, mk_pr1(tc, rec, ind));
bool use_conv_opt = true;
declaration new_d = mk_definition(env, brec_on_name, blps, brec_on_type, brec_on_value,
use_conv_opt);
environment new_env = module::add(env, check(env, new_d));
new_env = set_reducible(new_env, brec_on_name, reducible_status::Reducible);
if (!ind)
new_env = add_unfold_hint(new_env, brec_on_name, nparams + nindices + ntypeformers);
return add_protected(new_env, brec_on_name);
}
expr normalize_binding(expr const & e) {
expr d = normalize(binding_domain(e));
expr l = mk_local(m_ngen.next(), binding_name(e), d, binding_info(e));
expr b = abstract(normalize(instantiate(binding_body(e), l)), l);
return update_binding(e, d, b);
}
expr abstract_type_context::push_local(name const & pp_name, expr const & type, binder_info const & bi) {
return mk_local(mk_fresh_name(), pp_name, type, bi);
}
expr update_local(expr const & e, expr const & new_type, binder_info const & bi) {
if (is_eqp(mlocal_type(e), new_type) && local_info(e) == bi)
return e;
else
return mk_local(mlocal_name(e), local_pp_name(e), new_type, bi, e.get_tag());
}
expr visit_binding(expr const & b) {
expr new_domain = visit(binding_domain(b));
expr l = mk_local(m_tc.mk_fresh_name(), new_domain);
expr new_body = abstract(visit(instantiate(binding_body(b), l)), l);
return update_binding(b, new_domain, new_body);
}
void test_inductive() {
// declare list type
lean_exception ex = 0;
lean_env env = mk_env();
lean_name l_name = mk_name("l");
lean_univ l = mk_uparam("l");
lean_univ one = mk_one();
lean_univ m1l = mk_max(one, l);
lean_expr Typel = mk_sort(l);
lean_expr Typem1l = mk_sort(m1l);
lean_expr list_type = mk_pi("A", Typel, Typem1l);
lean_name list_name = mk_name("list");
lean_expr list = mk_const("list", l);
lean_expr v0 = mk_var(0);
// nil : Pi (A : Type.{l}), list.{l} A
lean_expr list_v0 = mk_app(list, v0);
lean_expr nil_type = mk_pi("A", Typel, list_v0);
lean_expr nil = mk_local("nil", nil_type);
// cons : Pi (A : Type.{l}), A -> list.{l} A -> list.{l} A
lean_expr v1 = mk_var(1);
lean_expr v2 = mk_var(2);
lean_expr list_v2 = mk_app(list, v2);
lean_expr list_v1 = mk_app(list, v1);
lean_expr cons_type1 = mk_pi("tail", list_v1, list_v2);
lean_expr cons_type2 = mk_pi("head", v0, cons_type1);
lean_expr cons_type = mk_pi("A", Typel, cons_type2);
lean_expr cons = mk_local("cons", cons_type);
//
lean_list_expr cs1, cs2, list_cs;
lean_inductive_type list_ind_type;
lean_list_inductive_type li1, list_ind_types;
lean_list_name ls1, ls;
lean_inductive_decl list_decl;
lean_env new_env;
check(lean_list_name_mk_nil(&ls1, &ex));
check(lean_list_name_mk_cons(l_name, ls1, &ls, &ex));
check(lean_list_expr_mk_nil(&cs1, &ex));
check(lean_list_expr_mk_cons(nil, cs1, &cs2, &ex));
check(lean_list_expr_mk_cons(cons, cs2, &list_cs, &ex));
check(lean_inductive_type_mk(list_name, list_type, list_cs, &list_ind_type, &ex));
check(lean_list_inductive_type_mk_nil(&li1, &ex));
check(lean_list_inductive_type_mk_cons(list_ind_type, li1, &list_ind_types, &ex));
check(lean_inductive_decl_mk(ls, 1, list_ind_types, &list_decl, &ex));
check(lean_env_add_inductive(env, list_decl, &new_env, &ex));
{
unsigned n;
lean_inductive_decl d;
lean_name cons_name = mk_name("cons");
lean_name r_name;
lean_list_inductive_type types;
check(lean_env_get_inductive_type_num_indices(new_env, list_name, &n, &ex) && n == 0);
check(lean_env_get_inductive_type_num_minor_premises(new_env, list_name, &n, &ex) && n == 2);
check(!lean_env_is_inductive_type(env, list_name, &d, &ex));
check(lean_env_is_inductive_type(new_env, list_name, &d, &ex));
check(lean_inductive_decl_get_num_params(d, &n, &ex) && n == 1);
check(lean_inductive_decl_get_types(d, &types, &ex));
check(lean_list_inductive_type_is_cons(types));
check(lean_env_is_constructor(new_env, cons_name, &r_name, &ex) && lean_name_eq(list_name, r_name));
lean_inductive_decl_del(d);
lean_name_del(cons_name);
lean_name_del(r_name);
}
lean_env_del(env);
lean_name_del(list_name);
lean_name_del(l_name);
lean_univ_del(l);
lean_univ_del(one);
lean_univ_del(m1l);
lean_expr_del(Typel);
lean_expr_del(Typem1l);
lean_expr_del(list_type);
lean_expr_del(list);
lean_expr_del(v0);
lean_expr_del(list_v0);
lean_expr_del(nil_type);
lean_expr_del(nil);
lean_expr_del(v1);
lean_expr_del(v2);
lean_expr_del(list_v2);
lean_expr_del(list_v1);
lean_expr_del(cons_type1);
lean_expr_del(cons_type2);
lean_expr_del(cons_type);
lean_expr_del(cons);
lean_list_expr_del(cs1);
lean_list_expr_del(cs2);
lean_list_expr_del(list_cs);
lean_inductive_type_del(list_ind_type);
lean_list_inductive_type_del(li1);
lean_list_inductive_type_del(list_ind_types);
lean_list_name_del(ls1);
lean_list_name_del(ls);
lean_inductive_decl_del(list_decl);
lean_env_del(new_env);
}
/** \brief Given a term <tt>a : a_type</tt>, and a metavariable \c m, creates a constraint
that considers coercions from a_type to the type assigned to \c m. */
constraint mk_coercion_cnstr(type_checker & from_tc, type_checker & to_tc, coercion_info_manager & infom,
expr const & m, expr const & a, expr const & a_type,
justification const & j, unsigned delay_factor, bool lift_coe) {
auto choice_fn = [=, &from_tc, &to_tc, &infom](expr const & meta, expr const & d_type, substitution const & s) {
expr new_a_type;
justification new_a_type_jst;
if (is_meta(a_type)) {
auto p = substitution(s).instantiate_metavars(a_type);
new_a_type = p.first;
new_a_type_jst = p.second;
} else {
new_a_type = a_type;
}
if (is_meta(new_a_type)) {
if (delay_factor < to_delay_factor(cnstr_group::DelayedChoice)) {
// postpone...
return lazy_list<constraints>(constraints(mk_coercion_cnstr(from_tc, to_tc, infom, m, a, a_type, justification(),
delay_factor+1, lift_coe)));
} else {
// giveup...
return lazy_list<constraints>(constraints(mk_eq_cnstr(meta, a, justification())));
}
}
constraint_seq cs;
new_a_type = from_tc.whnf(new_a_type, cs);
if ((lift_coe && is_pi_meta(d_type)) || (!lift_coe && is_meta(d_type))) {
// case-split
buffer<expr> locals;
expr it_from = new_a_type;
expr it_to = d_type;
while (is_pi(it_from) && is_pi(it_to)) {
expr dom_from = binding_domain(it_from);
expr dom_to = binding_domain(it_to);
if (!from_tc.is_def_eq(dom_from, dom_to, justification(), cs))
return lazy_list<constraints>();
expr local = mk_local(mk_fresh_name(), binding_name(it_from), dom_from, binder_info());
locals.push_back(local);
it_from = instantiate(binding_body(it_from), local);
it_to = instantiate(binding_body(it_to), local);
}
buffer<expr> alts;
get_coercions_from(from_tc.env(), it_from, alts);
expr fn_a;
if (!locals.empty())
fn_a = mk_local(mk_fresh_name(), "f", new_a_type, binder_info());
buffer<constraints> choices;
buffer<expr> coes;
// first alternative: no coercion
constraint_seq cs1 = cs + mk_eq_cnstr(meta, a, justification());
choices.push_back(cs1.to_list());
unsigned i = alts.size();
while (i > 0) {
--i;
expr coe = alts[i];
if (!locals.empty())
coe = Fun(fn_a, Fun(locals, mk_app(coe, mk_app(fn_a, locals))));
expr new_a = copy_tag(a, mk_app(coe, a));
coes.push_back(coe);
constraint_seq csi = cs + mk_eq_cnstr(meta, new_a, new_a_type_jst);
choices.push_back(csi.to_list());
}
return choose(std::make_shared<coercion_elaborator>(infom, meta,
to_list(choices.begin(), choices.end()),
to_list(coes.begin(), coes.end())));
} else {
list<expr> coes = get_coercions_from_to(from_tc, to_tc, new_a_type, d_type, cs, lift_coe);
if (is_nil(coes)) {
expr new_a = a;
infom.erase_coercion_info(a);
cs += mk_eq_cnstr(meta, new_a, new_a_type_jst);
return lazy_list<constraints>(cs.to_list());
} else if (is_nil(tail(coes))) {
expr new_a = copy_tag(a, mk_app(head(coes), a));
infom.save_coercion_info(a, new_a);
cs += mk_eq_cnstr(meta, new_a, new_a_type_jst);
return lazy_list<constraints>(cs.to_list());
} else {
list<constraints> choices = map2<constraints>(coes, [&](expr const & coe) {
expr new_a = copy_tag(a, mk_app(coe, a));
constraint c = mk_eq_cnstr(meta, new_a, new_a_type_jst);
return (cs + c).to_list();
});
return choose(std::make_shared<coercion_elaborator>(infom, meta, choices, coes, false));
}
}
};
return mk_choice_cnstr(m, choice_fn, delay_factor, true, j);
}
void add_congr_core(environment const & env, simp_rule_sets & s, name const & n) {
declaration const & d = env.get(n);
type_checker tc(env);
buffer<level> us;
unsigned num_univs = d.get_num_univ_params();
for (unsigned i = 0; i < num_univs; i++) {
us.push_back(mk_meta_univ(name(*g_prefix, i)));
}
levels ls = to_list(us);
expr pr = mk_constant(n, ls);
expr e = instantiate_type_univ_params(d, ls);
buffer<bool> explicit_args;
buffer<expr> metas;
unsigned idx = 0;
while (is_pi(e)) {
expr mvar = mk_metavar(name(*g_prefix, idx), binding_domain(e));
idx++;
explicit_args.push_back(is_explicit(binding_info(e)));
metas.push_back(mvar);
e = instantiate(binding_body(e), mvar);
pr = mk_app(pr, mvar);
}
expr rel, lhs, rhs;
if (!is_simp_relation(env, e, rel, lhs, rhs) || !is_constant(rel)) {
throw exception(sstream() << "invalid congruence rule, '" << n
<< "' resulting type is not of the form t ~ s, where '~' is a transitive and reflexive relation");
}
name_set found_mvars;
buffer<expr> lhs_args, rhs_args;
expr const & lhs_fn = get_app_args(lhs, lhs_args);
expr const & rhs_fn = get_app_args(rhs, rhs_args);
if (is_constant(lhs_fn)) {
if (!is_constant(rhs_fn) || const_name(lhs_fn) != const_name(rhs_fn) || lhs_args.size() != rhs_args.size()) {
throw exception(sstream() << "invalid congruence rule, '" << n
<< "' resulting type is not of the form (" << const_name(lhs_fn) << " ...) "
<< "~ (" << const_name(lhs_fn) << " ...), where ~ is '" << const_name(rel) << "'");
}
for (expr const & lhs_arg : lhs_args) {
if (is_sort(lhs_arg))
continue;
if (!is_metavar(lhs_arg) || found_mvars.contains(mlocal_name(lhs_arg))) {
throw exception(sstream() << "invalid congruence rule, '" << n
<< "' the left-hand-side of the congruence resulting type must be of the form ("
<< const_name(lhs_fn) << " x_1 ... x_n), where each x_i is a distinct variable or a sort");
}
found_mvars.insert(mlocal_name(lhs_arg));
}
} else if (is_binding(lhs)) {
if (lhs.kind() != rhs.kind()) {
throw exception(sstream() << "invalid congruence rule, '" << n
<< "' kinds of the left-hand-side and right-hand-side of "
<< "the congruence resulting type do not match");
}
if (!is_valid_congr_rule_binding_lhs(lhs, found_mvars)) {
throw exception(sstream() << "invalid congruence rule, '" << n
<< "' left-hand-side of the congruence resulting type must "
<< "be of the form (fun/Pi (x : A), B x)");
}
} else {
throw exception(sstream() << "invalid congruence rule, '" << n
<< "' left-hand-side is not an application nor a binding");
}
buffer<expr> congr_hyps;
lean_assert(metas.size() == explicit_args.size());
for (unsigned i = 0; i < metas.size(); i++) {
expr const & mvar = metas[i];
if (explicit_args[i] && !found_mvars.contains(mlocal_name(mvar))) {
buffer<expr> locals;
expr type = mlocal_type(mvar);
while (is_pi(type)) {
expr local = mk_local(tc.mk_fresh_name(), binding_domain(type));
locals.push_back(local);
type = instantiate(binding_body(type), local);
}
expr h_rel, h_lhs, h_rhs;
if (!is_simp_relation(env, type, h_rel, h_lhs, h_rhs) || !is_constant(h_rel))
continue;
unsigned j = 0;
for (expr const & local : locals) {
j++;
if (!only_found_mvars(mlocal_type(local), found_mvars)) {
throw exception(sstream() << "invalid congruence rule, '" << n
<< "' argument #" << j << " of parameter #" << (i+1) << " contains "
<< "unresolved parameters");
}
}
if (!only_found_mvars(h_lhs, found_mvars)) {
throw exception(sstream() << "invalid congruence rule, '" << n
<< "' argument #" << (i+1) << " is not a valid hypothesis, the left-hand-side contains "
<< "unresolved parameters");
}
if (!is_valid_congr_hyp_rhs(h_rhs, found_mvars)) {
throw exception(sstream() << "invalid congruence rule, '" << n
<< "' argument #" << (i+1) << " is not a valid hypothesis, the right-hand-side must be "
<< "of the form (m l_1 ... l_n) where m is parameter that was not "
<< "'assigned/resolved' yet and l_i's are locals");
}
found_mvars.insert(mlocal_name(mvar));
congr_hyps.push_back(mvar);
}
}
congr_rule rule(n, ls, to_list(metas), lhs, rhs, pr, to_list(congr_hyps));
s.insert(const_name(rel), rule);
}
environment mk_projections(environment const & env, name const & n, buffer<name> const & proj_names,
implicit_infer_kind infer_k, bool inst_implicit) {
// Given an inductive datatype C A (where A represent parameters)
// intro : Pi A (x_1 : B_1[A]) (x_2 : B_2[A, x_1]) ..., C A
//
// we generate projections of the form
// proj_i A (c : C A) : B_i[A, (proj_1 A n), ..., (proj_{i-1} A n)]
// C.rec A (fun (x : C A), B_i[A, ...]) (fun (x_1 ... x_n), x_i) c
auto p = get_nparam_intro_rule(env, n);
name_generator ngen;
unsigned nparams = p.first;
inductive::intro_rule intro = p.second;
expr intro_type = inductive::intro_rule_type(intro);
name rec_name = inductive::get_elim_name(n);
declaration ind_decl = env.get(n);
if (env.impredicative() && is_prop(ind_decl.get_type()))
throw exception(sstream() << "projection generation, '" << n << "' is a proposition");
declaration rec_decl = env.get(rec_name);
level_param_names lvl_params = ind_decl.get_univ_params();
levels lvls = param_names_to_levels(lvl_params);
buffer<expr> params; // datatype parameters
for (unsigned i = 0; i < nparams; i++) {
if (!is_pi(intro_type))
throw_ill_formed(n);
expr param = mk_local(ngen.next(), binding_name(intro_type), binding_domain(intro_type), binder_info());
intro_type = instantiate(binding_body(intro_type), param);
params.push_back(param);
}
expr C_A = mk_app(mk_constant(n, lvls), params);
binder_info c_bi = inst_implicit ? mk_inst_implicit_binder_info() : binder_info();
expr c = mk_local(ngen.next(), name("c"), C_A, c_bi);
buffer<expr> intro_type_args; // arguments that are not parameters
expr it = intro_type;
while (is_pi(it)) {
expr local = mk_local(ngen.next(), binding_name(it), binding_domain(it), binding_info(it));
intro_type_args.push_back(local);
it = instantiate(binding_body(it), local);
}
buffer<expr> projs; // projections generated so far
unsigned i = 0;
environment new_env = env;
for (name const & proj_name : proj_names) {
if (!is_pi(intro_type))
throw exception(sstream() << "generating projection '" << proj_name << "', '"
<< n << "' does not have sufficient data");
expr result_type = binding_domain(intro_type);
buffer<expr> proj_args;
proj_args.append(params);
proj_args.push_back(c);
expr type_former = Fun(c, result_type);
expr minor_premise = Fun(intro_type_args, mk_var(intro_type_args.size() - i - 1));
expr major_premise = c;
type_checker tc(new_env);
level l = sort_level(tc.ensure_sort(tc.infer(result_type).first).first);
levels rec_lvls = append(to_list(l), lvls);
expr rec = mk_constant(rec_name, rec_lvls);
buffer<expr> rec_args;
rec_args.append(params);
rec_args.push_back(type_former);
rec_args.push_back(minor_premise);
rec_args.push_back(major_premise);
expr rec_app = mk_app(rec, rec_args);
expr proj_type = Pi(proj_args, result_type);
proj_type = infer_implicit_params(proj_type, nparams, infer_k);
expr proj_val = Fun(proj_args, rec_app);
bool opaque = false;
bool use_conv_opt = false;
declaration new_d = mk_definition(env, proj_name, lvl_params, proj_type, proj_val,
opaque, rec_decl.get_module_idx(), use_conv_opt);
new_env = module::add(new_env, check(new_env, new_d));
new_env = set_reducible(new_env, proj_name, reducible_status::Reducible);
new_env = add_unfold_c_hint(new_env, proj_name, nparams);
new_env = save_projection_info(new_env, proj_name, inductive::intro_rule_name(intro), nparams, i, inst_implicit);
expr proj = mk_app(mk_app(mk_constant(proj_name, lvls), params), c);
intro_type = instantiate(binding_body(intro_type), proj);
i++;
}
return new_env;
}
environment mk_no_confusion(environment const & env, name const & n) {
optional<environment> env1 = mk_no_confusion_type(env, n);
if (!env1)
return env;
environment new_env = *env1;
type_checker tc(new_env);
inductive::inductive_decls decls = *inductive::is_inductive_decl(new_env, n);
unsigned nparams = std::get<1>(decls);
name_generator ngen;
declaration no_confusion_type_decl = new_env.get(name{n, "no_confusion_type"});
declaration cases_decl = new_env.get(name(n, "cases_on"));
level_param_names lps = no_confusion_type_decl.get_univ_params();
levels ls = param_names_to_levels(lps);
expr no_confusion_type_type = instantiate_type_univ_params(no_confusion_type_decl, ls);
name eq_name("eq");
name heq_name("heq");
name eq_refl_name{"eq", "refl"};
name heq_refl_name{"heq", "refl"};
buffer<expr> args;
expr type = no_confusion_type_type;
type = to_telescope(ngen, type, args, some(mk_implicit_binder_info()));
lean_assert(args.size() >= nparams + 3);
unsigned nindices = args.size() - nparams - 3; // 3 is for P v1 v2
expr range = mk_app(mk_constant(no_confusion_type_decl.get_name(), ls), args);
expr P = args[args.size()-3];
expr v1 = args[args.size()-2];
expr v2 = args[args.size()-1];
expr v_type = mlocal_type(v1);
level v_lvl = sort_level(tc.ensure_type(v_type).first);
expr eq_v = mk_app(mk_constant(eq_name, to_list(v_lvl)), v_type);
expr H12 = mk_local(ngen.next(), "H12", mk_app(eq_v, v1, v2), binder_info());
args.push_back(H12);
name no_confusion_name{n, "no_confusion"};
expr no_confusion_ty = Pi(args, range);
// The gen proof is of the form
// (fun H11 : v1 = v1, cases_on Params (fun Indices v1, no_confusion_type Params Indices P v1 v1) Indices v1
// <for-each case>
// (fun H : (equations -> P), H (refl) ... (refl))
// ...
// )
// H11 is for creating the generalization
expr H11 = mk_local(ngen.next(), "H11", mk_app(eq_v, v1, v1), binder_info());
// Create the type former (fun Indices v1, no_confusion_type Params Indices P v1 v1)
buffer<expr> type_former_args;
for (unsigned i = nparams; i < nparams + nindices; i++)
type_former_args.push_back(args[i]);
type_former_args.push_back(v1);
buffer<expr> no_confusion_type_args;
for (unsigned i = 0; i < nparams + nindices; i++)
no_confusion_type_args.push_back(args[i]);
no_confusion_type_args.push_back(P);
no_confusion_type_args.push_back(v1);
no_confusion_type_args.push_back(v1);
expr no_confusion_type_app = mk_app(mk_constant(no_confusion_type_decl.get_name(), ls), no_confusion_type_args);
expr type_former = Fun(type_former_args, no_confusion_type_app);
// create cases_on
levels clvls = ls;
expr cases_on = mk_app(mk_app(mk_constant(cases_decl.get_name(), clvls), nparams, args.data()), type_former);
cases_on = mk_app(mk_app(cases_on, nindices, args.data() + nparams), v1);
expr cot = tc.infer(cases_on).first;
while (is_pi(cot)) {
buffer<expr> minor_args;
expr minor = to_telescope(tc, binding_domain(cot), minor_args);
lean_assert(!minor_args.empty());
expr H = minor_args.back();
expr Ht = mlocal_type(H);
buffer<expr> refl_args;
while (is_pi(Ht)) {
buffer<expr> eq_args;
expr eq_fn = get_app_args(binding_domain(Ht), eq_args);
if (const_name(eq_fn) == eq_name) {
refl_args.push_back(mk_app(mk_constant(eq_refl_name, const_levels(eq_fn)), eq_args[0], eq_args[1]));
} else {
refl_args.push_back(mk_app(mk_constant(heq_refl_name, const_levels(eq_fn)), eq_args[0], eq_args[1]));
}
Ht = binding_body(Ht);
}
expr pr = mk_app(H, refl_args);
cases_on = mk_app(cases_on, Fun(minor_args, pr));
cot = binding_body(cot);
}
expr gen = Fun(H11, cases_on);
// Now, we use gen to build the final proof using eq.rec
//
// eq.rec InductiveType v1 (fun (a : InductiveType), v1 = a -> no_confusion_type Params Indices v1 a) gen v2 H12 H12
//
name eq_rec_name{"eq", "rec"};
expr eq_rec = mk_app(mk_constant(eq_rec_name, {head(ls), v_lvl}), v_type, v1);
// create eq_rec type_former
// (fun (a : InductiveType), v1 = a -> no_confusion_type Params Indices v1 a)
expr a = mk_local(ngen.next(), "a", v_type, binder_info());
expr H1a = mk_local(ngen.next(), "H1a", mk_app(eq_v, v1, a), binder_info());
// reusing no_confusion_type_args... we just replace the last argument with a
no_confusion_type_args.pop_back();
no_confusion_type_args.push_back(a);
expr no_confusion_type_app_1a = mk_app(mk_constant(no_confusion_type_decl.get_name(), ls), no_confusion_type_args);
expr rec_type_former = Fun(a, Pi(H1a, no_confusion_type_app_1a));
// finalize eq_rec
eq_rec = mk_app(mk_app(eq_rec, rec_type_former, gen, v2, H12), H12);
//
expr no_confusion_val = Fun(args, eq_rec);
bool opaque = false;
bool use_conv_opt = true;
declaration new_d = mk_definition(new_env, no_confusion_name, lps, no_confusion_ty, no_confusion_val,
opaque, no_confusion_type_decl.get_module_idx(), use_conv_opt);
new_env = module::add(new_env, check(new_env, new_d));
return add_protected(new_env, no_confusion_name);
}
optional<environment> mk_no_confusion_type(environment const & env, name const & n) {
optional<inductive::inductive_decls> decls = inductive::is_inductive_decl(env, n);
if (!decls)
throw exception(sstream() << "error in 'no_confusion' generation, '" << n << "' is not an inductive datatype");
if (is_inductive_predicate(env, n))
return optional<environment>(); // type is a proposition
name_generator ngen;
unsigned nparams = std::get<1>(*decls);
declaration ind_decl = env.get(n);
declaration cases_decl = env.get(name(n, "cases_on"));
level_param_names lps = cases_decl.get_univ_params();
level rlvl = mk_param_univ(head(lps));
levels ilvls = param_names_to_levels(tail(lps));
if (length(ilvls) != length(ind_decl.get_univ_params()))
return optional<environment>(); // type does not have only a restricted eliminator
expr ind_type = instantiate_type_univ_params(ind_decl, ilvls);
name eq_name("eq");
name heq_name("heq");
// All inductive datatype parameters and indices are arguments
buffer<expr> args;
ind_type = to_telescope(ngen, ind_type, args, some(mk_implicit_binder_info()));
if (!is_sort(ind_type) || args.size() < nparams)
throw_corrupted(n);
lean_assert(!(env.impredicative() && is_zero(sort_level(ind_type))));
unsigned nindices = args.size() - nparams;
// Create inductive datatype
expr I = mk_app(mk_constant(n, ilvls), args);
// Add (P : Type)
expr P = mk_local(ngen.next(), "P", mk_sort(rlvl), binder_info());
args.push_back(P);
// add v1 and v2 elements of the inductive type
expr v1 = mk_local(ngen.next(), "v1", I, binder_info());
expr v2 = mk_local(ngen.next(), "v2", I, binder_info());
args.push_back(v1);
args.push_back(v2);
expr R = mk_sort(rlvl);
name no_confusion_type_name{n, "no_confusion_type"};
expr no_confusion_type_type = Pi(args, R);
// Create type former
buffer<expr> type_former_args;
for (unsigned i = nparams; i < nparams + nindices; i++)
type_former_args.push_back(args[i]);
type_former_args.push_back(v1);
expr type_former = Fun(type_former_args, R);
// Create cases_on
levels clvls = levels(mk_succ(rlvl), ilvls);
expr cases_on = mk_app(mk_app(mk_constant(cases_decl.get_name(), clvls), nparams, args.data()), type_former);
cases_on = mk_app(cases_on, nindices, args.data() + nparams);
expr cases_on1 = mk_app(cases_on, v1);
expr cases_on2 = mk_app(cases_on, v2);
type_checker tc(env);
expr t1 = tc.infer(cases_on1).first;
expr t2 = tc.infer(cases_on2).first;
buffer<expr> outer_cases_on_args;
unsigned idx1 = 0;
while (is_pi(t1)) {
buffer<expr> minor1_args;
expr minor1 = to_telescope(tc, binding_domain(t1), minor1_args);
expr curr_t2 = t2;
buffer<expr> inner_cases_on_args;
unsigned idx2 = 0;
while (is_pi(curr_t2)) {
buffer<expr> minor2_args;
expr minor2 = to_telescope(tc, binding_domain(curr_t2), minor2_args);
if (idx1 != idx2) {
// infeasible case, constructors do not match
inner_cases_on_args.push_back(Fun(minor2_args, P));
} else {
if (minor1_args.size() != minor2_args.size())
throw_corrupted(n);
buffer<expr> rtype_hyp;
// add equalities
for (unsigned i = 0; i < minor1_args.size(); i++) {
expr lhs = minor1_args[i];
expr rhs = minor2_args[i];
expr lhs_type = mlocal_type(lhs);
expr rhs_type = mlocal_type(rhs);
level l = sort_level(tc.ensure_type(lhs_type).first);
expr h_type;
if (tc.is_def_eq(lhs_type, rhs_type).first) {
h_type = mk_app(mk_constant(eq_name, to_list(l)), lhs_type, lhs, rhs);
} else {
h_type = mk_app(mk_constant(heq_name, to_list(l)), lhs_type, lhs, rhs_type, rhs);
}
rtype_hyp.push_back(mk_local(ngen.next(), local_pp_name(lhs).append_after("_eq"), h_type, binder_info()));
}
inner_cases_on_args.push_back(Fun(minor2_args, mk_arrow(Pi(rtype_hyp, P), P)));
}
idx2++;
curr_t2 = binding_body(curr_t2);
}
outer_cases_on_args.push_back(Fun(minor1_args, mk_app(cases_on2, inner_cases_on_args)));
idx1++;
t1 = binding_body(t1);
}
expr no_confusion_type_value = Fun(args, mk_app(cases_on1, outer_cases_on_args));
bool opaque = false;
bool use_conv_opt = true;
declaration new_d = mk_definition(env, no_confusion_type_name, lps, no_confusion_type_type, no_confusion_type_value,
opaque, ind_decl.get_module_idx(), use_conv_opt);
environment new_env = module::add(env, check(env, new_d));
return some(add_protected(new_env, no_confusion_type_name));
}
