bool is_ceqv(tmp_type_context & tctx, 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 = tctx.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 = tctx.mk_tmp_local(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 && tctx.is_prop(binding_domain(e))) {
// 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;
}
bool is_simp_relation(environment const & env, expr const & e, expr & rel, expr & lhs, expr & rhs) {
buffer<expr> args;
rel = get_app_args(e, args);
if (!is_constant(rel) || !is_simp_relation(env, const_name(rel)))
return false;
relation_info const * rel_info = get_relation_info(env, const_name(rel));
if (!rel_info || rel_info->get_lhs_pos() >= args.size() || rel_info->get_rhs_pos() >= args.size())
return false;
lhs = args[rel_info->get_lhs_pos()];
rhs = args[rel_info->get_rhs_pos()];
return true;
}
bool is_permutation_ceqv(environment const & env, expr e) {
unsigned num_args = 0;
while (is_pi(e)) {
e = binding_body(e);
num_args++;
}
expr lhs, rhs;
if (is_simp_relation(env, e, lhs, rhs)) {
buffer<optional<unsigned>> permutation;
permutation.resize(num_args);
return is_permutation(lhs, rhs, 0, permutation);
} else {
return false;
}
}
simp_rule_sets add_core(type_checker & tc, simp_rule_sets const & s,
name const & id, levels const & univ_metas, expr const & e, expr const & h) {
list<expr_pair> ceqvs = to_ceqvs(tc, e, h);
environment const & env = tc.env();
simp_rule_sets new_s = s;
for (expr_pair const & p : ceqvs) {
expr new_e = p.first;
expr new_h = p.second;
bool is_perm = is_permutation_ceqv(env, new_e);
buffer<expr> metas;
unsigned idx = 0;
while (is_pi(new_e)) {
expr mvar = mk_metavar(name(*g_prefix, idx), binding_domain(new_e));
idx++;
metas.push_back(mvar);
new_e = instantiate(binding_body(new_e), mvar);
}
expr rel, lhs, rhs;
if (is_simp_relation(env, new_e, rel, lhs, rhs) && is_constant(rel)) {
new_s.insert(const_name(rel), simp_rule(id, univ_metas, to_list(metas), lhs, rhs, new_h, is_perm));
}
}
return new_s;
}
bool is_relation(expr const & e) {
if (!is_app(e)) return false;
expr const & fn = get_app_fn(e);
return is_constant(fn) && is_simp_relation(m_env, const_name(fn));
}
bool is_simp_relation(environment const & env, expr const & e, expr & lhs, expr & rhs) {
expr rel;
return is_simp_relation(env, e, rel, lhs, rhs);
}
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);
}
