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; } }
static optional<pair<expr, expr>> mk_op(environment const & env, old_local_context & ctx, type_checker_ptr & tc, name const & op, unsigned nunivs, unsigned nargs, std::initializer_list<expr> const & explicit_args, constraint_seq & cs, tag g) { levels lvls; for (unsigned i = 0; i < nunivs; i++) lvls = levels(mk_meta_univ(mk_fresh_name()), lvls); expr c = mk_constant(op, lvls); expr op_type = instantiate_type_univ_params(env.get(op), lvls); buffer<expr> args; for (unsigned i = 0; i < nargs; i++) { if (!is_pi(op_type)) return optional<pair<expr, expr>>(); expr arg = ctx.mk_meta(some_expr(binding_domain(op_type)), g); args.push_back(arg); op_type = instantiate(binding_body(op_type), arg); } expr r = mk_app(c, args, g); for (expr const & explicit_arg : explicit_args) { if (!is_pi(op_type)) return optional<pair<expr, expr>>(); r = mk_app(r, explicit_arg); expr type = tc->infer(explicit_arg, cs); justification j = mk_app_justification(r, op_type, explicit_arg, type); if (!tc->is_def_eq(binding_domain(op_type), type, j, cs)) return optional<pair<expr, expr>>(); op_type = instantiate(binding_body(op_type), explicit_arg); } return some(mk_pair(r, op_type)); }
static simp_rule_sets add_core(type_checker & tc, simp_rule_sets const & s, name const & cname) { declaration const & d = tc.env().get(cname); 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 e = instantiate_type_univ_params(d, ls); expr h = mk_constant(cname, ls); return add_core(tc, s, cname, ls, e, h); }
optional<constraints> try_instance(name const & inst) { environment const & env = m_C->env(); if (auto decl = env.find(inst)) { name_generator & ngen = m_C->m_ngen; buffer<level> ls_buffer; unsigned num_univ_ps = decl->get_num_univ_params(); for (unsigned i = 0; i < num_univ_ps; i++) ls_buffer.push_back(mk_meta_univ(ngen.next())); levels ls = to_list(ls_buffer.begin(), ls_buffer.end()); expr inst_cnst = copy_tag(m_meta, mk_constant(inst, ls)); expr inst_type = instantiate_type_univ_params(*decl, ls); return try_instance(inst_cnst, inst_type); } else { return optional<constraints>(); } }
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)); }
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); }
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); }
static optional<head_index> get_backward_target(type_context & ctx, name const & c) { declaration const & d = ctx.env().get(c); list<level> us = param_names_to_levels(d.get_univ_params()); expr type = ctx.try_to_pi(instantiate_type_univ_params(d, us)); return get_backward_target(ctx, type); }