feat(frontends/lean/coercion_elaborator): implement "coercion lifting"

closes #644
This commit is contained in:
Leonardo de Moura 2015-05-30 14:45:14 -07:00
parent b76445df39
commit ea9c810fca
4 changed files with 82 additions and 13 deletions

View file

@ -7,6 +7,7 @@ Author: Leonardo de Moura
#include "kernel/type_checker.h"
#include "kernel/metavar.h"
#include "kernel/constraint.h"
#include "kernel/abstract.h"
#include "library/coercion.h"
#include "library/unifier.h"
#include "library/choice_iterator.h"
@ -21,24 +22,46 @@ coercion_elaborator::coercion_elaborator(coercion_info_manager & info, expr cons
lean_assert(use_id || length(m_coercions) == length(m_choices));
}
list<expr> get_coercions_from_to(type_checker & /* from_tc */, type_checker & to_tc,
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) {
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 (is_arrow(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_arrow(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
list<expr> coe = get_coercions_from_to(from_tc, to_tc, binding_body(whnf_from_type), binding_body(whnf_to_type), new_cs);
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(from_tc.mk_fresh_name(), "f", whnf_from_type, binder_info());
expr x = mk_local(from_tc.mk_fresh_name(), "x", binding_domain(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, from_type, const_name(fn));
r = get_coercions(env, whnf_from_type, const_name(fn));
} else if (is_pi(whnf_to_type)) {
r = get_coercions_to_fun(env, from_type);
r = get_coercions_to_fun(env, whnf_from_type);
} else if (is_sort(whnf_to_type)) {
r = get_coercions_to_sort(env, from_type);
r = get_coercions_to_sort(env, whnf_from_type);
}
if (r)
cs += new_cs;
return r;
}
}
optional<constraints> coercion_elaborator::next() {
if (!m_choices)

View file

@ -481,6 +481,10 @@ pair<expr, expr> elaborator::ensure_fun(expr f, constraint_seq & cs) {
bool elaborator::has_coercions_from(expr const & a_type) {
try {
expr a_cls = get_app_fn(m_coercion_from_tc->whnf(a_type).first);
while (is_pi(a_cls)) {
expr local = mk_local(binding_name(a_cls), binding_domain(a_cls), binding_info(a_cls));
a_cls = get_app_fn(m_coercion_from_tc->whnf(instantiate(binding_body(a_cls), local)).first);
}
return is_constant(a_cls) && ::lean::has_coercions_from(env(), const_name(a_cls));
} catch (exception&) {
return false;

38
tests/lean/644.lean Normal file
View file

@ -0,0 +1,38 @@
import data.list
constant A : Type₁
constant B : Type₁
constant coe : A → B
attribute coe [coercion]
variable f : B → B
variable a : A
set_option pp.coercions true
check f a
constant C : Type₁
variable g : (C → B) → B
variable h : C → A
check g h
definition tst (g : C → B) : Prop := g = h
open bool list
definition bool_to_Prop [coercion] [reducible] (b : bool) : Prop := b = tt
definition bpred_dec [instance] {A : Type} (p : A → bool) : ∀ a, decidable (p a = tt) :=
begin
intro a,
eapply (bool.rec_on (p a)),
right, contradiction,
left, reflexivity
end
definition negb : bool → bool := bool.rec tt ff
check filter negb [tt, ff, tt, ff]
eval filter negb [tt, ff, tt, ff]
example : filter negb [tt, ff, tt, ff] = [ff, ff] :=
rfl

View file

@ -0,0 +1,4 @@
f (coe a) : B
g (λ (x : C), coe (h x)) : B
filter (λ (x : bool), bool_to_Prop (negb x)) [tt, ff, tt, ff] : list bool
[ff, ff]