tactic change_goal_tactic(elaborate_fn const & elab, expr const & e) {
return tactic([=](environment const & env, io_state const & ios, proof_state const & s) {
proof_state new_s = s;
goals const & gs = new_s.get_goals();
if (!gs) {
throw_no_goal_if_enabled(s);
return proof_state_seq();
}
expr t = head(gs).get_type();
bool report_unassigned = true;
if (auto new_e = elaborate_with_respect_to(env, ios, elab, new_s, e, none_expr(), report_unassigned)) {
goals const & gs = new_s.get_goals();
goal const & g = head(gs);
substitution subst = new_s.get_subst();
auto tc = mk_type_checker(env);
constraint_seq cs;
if (tc->is_def_eq(t, *new_e, justification(), cs)) {
if (cs) {
unifier_config cfg(ios.get_options());
buffer<constraint> cs_buf;
cs.linearize(cs_buf);
to_buffer(new_s.get_postponed(), cs_buf);
unify_result_seq rseq = unify(env, cs_buf.size(), cs_buf.data(), subst, cfg);
return map2<proof_state>(rseq, [=](pair<substitution, constraints> const & p) -> proof_state {
substitution const & subst = p.first;
constraints const & postponed = p.second;
substitution new_subst = subst;
expr final_e = new_subst.instantiate_all(*new_e);
expr M = g.mk_meta(mk_fresh_name(), final_e);
goal new_g(M, final_e);
assign(new_subst, g, M);
return proof_state(new_s, cons(new_g, tail(gs)), new_subst, postponed);
});
}
expr M = g.mk_meta(mk_fresh_name(), *new_e);
goal new_g(M, *new_e);
assign(subst, g, M);
return proof_state_seq(proof_state(new_s, cons(new_g, tail(gs)), subst));
} else {
throw_tactic_exception_if_enabled(new_s, [=](formatter const & fmt) {
format r = format("invalid 'change' tactic, the given type");
r += pp_indent_expr(fmt, *new_e);
r += compose(line(), format("does not match the goal type"));
r += pp_indent_expr(fmt, t);
return r;
});
return proof_state_seq();
}
}
return proof_state_seq();
});
}
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));
}
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;
}
}
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()));
}
}
environment mk_projections(environment const & env, name const & n,
implicit_infer_kind infer_k, bool inst_implicit) {
auto p = get_nparam_intro_rule(env, n);
unsigned num_params = p.first;
inductive::intro_rule ir = p.second;
expr type = inductive::intro_rule_type(ir);
buffer<name> proj_names;
unsigned i = 0;
while (is_pi(type)) {
if (i >= num_params)
proj_names.push_back(mk_fresh_name(env, proj_names, n + binding_name(type)));
i++;
type = binding_body(type);
}
return mk_projections(env, n, proj_names, infer_k, inst_implicit);
}
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");
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(mk_fresh_name(), 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]);
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));
environment new_env = module::add(env,
check(env, mk_definition_inferring_trusted(env, rec_on_name, rec_decl.get_univ_params(),
rec_on_type, rec_on_val, reducibility_hints::mk_abbreviation())));
new_env = set_reducible(new_env, rec_on_name, reducible_status::Reducible, true);
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(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;
}
/** \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);
}
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);
}
