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;
}
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));
}
