diff --git a/src/library/normalize.cpp b/src/library/normalize.cpp index e25b7c8f0..a6cc03831 100644 --- a/src/library/normalize.cpp +++ b/src/library/normalize.cpp @@ -4,6 +4,7 @@ Released under Apache 2.0 license as described in the file LICENSE. Author: Leonardo de Moura */ +#include "util/interrupt.h" #include "util/name_generator.h" #include "kernel/type_checker.h" #include "kernel/instantiate.h" @@ -14,7 +15,7 @@ namespace lean { class normalize_fn { type_checker & m_tc; name_generator m_ngen; - std::function m_pred; + std::function m_pred; // NOLINT bool m_save_cnstrs; constraint_seq m_cnstrs; @@ -34,6 +35,7 @@ class normalize_fn { } expr normalize(expr e) { + check_system("normalize"); if (!m_pred(e)) return e; auto w = m_tc.whnf(e); @@ -58,7 +60,7 @@ public: m_pred([](expr const &) { return true; }), m_save_cnstrs(save) {} - normalize_fn(type_checker & tc, std::function const & fn): + normalize_fn(type_checker & tc, std::function const & fn): // NOLINT m_tc(tc), m_ngen(m_tc.mk_ngen()), m_pred(fn) {} @@ -101,7 +103,8 @@ expr normalize(type_checker & tc, expr const & e, constraint_seq & cs) { return r; } -expr normalize(type_checker & tc, expr const & e, std::function const & pred, constraint_seq & cs) { +expr normalize(type_checker & tc, expr const & e, std::function const & pred, // NOLINT + constraint_seq & cs) { normalize_fn fn(tc, pred); expr r = fn(e); cs += fn.get_cnstrs(); diff --git a/src/library/normalize.h b/src/library/normalize.h index 0f35bd4f1..af44fbc2b 100644 --- a/src/library/normalize.h +++ b/src/library/normalize.h @@ -28,6 +28,6 @@ expr normalize(type_checker & tc, expr const & e, constraint_seq & cs); \remark A sub-expression is evaluated only if \c pred returns true. */ -expr normalize(type_checker & tc, expr const & e, std::function const & pred, +expr normalize(type_checker & tc, expr const & e, std::function const & pred, // NOLINT constraint_seq & cs); } diff --git a/src/library/unifier.cpp b/src/library/unifier.cpp index 17b79cf70..710af564a 100644 --- a/src/library/unifier.cpp +++ b/src/library/unifier.cpp @@ -21,6 +21,7 @@ Author: Leonardo de Moura #include "kernel/type_checker.h" #include "kernel/kernel_exception.h" #include "kernel/error_msgs.h" +#include "library/normalize.h" #include "library/occurs.h" #include "library/locals.h" #include "library/module.h" @@ -726,13 +727,18 @@ struct unifier_fn { auto status = occurs_context_check(m_subst, rhs, *m, locals, bad_local); if (status == occurs_check_status::FailLocal || status == occurs_check_status::FailCircular) { // Try to normalize rhs - // TODO(Leo): use a custom normalizer that uses reduction to solve just the failure. - // TODO(Leo): this code is using only whnf, we may fail to eliminate the failure. // Example: ?M := f (pr1 (pair 0 ?M)) constraint_seq cs; - expr rhs_whnf = whnf(rhs, relax, cs); - if (rhs != rhs_whnf && process_constraints(cs)) - return process_metavar_eq(lhs, rhs_whnf, j, relax); + auto is_target_fn = [&](expr const & e) { + if (status == occurs_check_status::FailLocal && occurs(bad_local, e)) + return true; + else if (status == occurs_check_status::FailCircular && occurs(*m, e)) + return true; + return false; + }; + expr rhs_n = normalize(*m_tc[relax], rhs, is_target_fn, cs); + if (rhs != rhs_n && process_constraints(cs)) + return process_metavar_eq(lhs, rhs_n, j, relax); } switch (status) { case occurs_check_status::FailLocal: diff --git a/tests/lean/run/vector3.lean b/tests/lean/run/vector3.lean new file mode 100644 index 000000000..1f871857e --- /dev/null +++ b/tests/lean/run/vector3.lean @@ -0,0 +1,33 @@ +import logic data.nat.basic +open nat + +inductive vector (A : Type) : nat → Type := +vnil : vector A zero, +vcons : Π {n : nat}, A → vector A n → vector A (succ n) + +namespace vector + definition no_confusion_type {A : Type} {n : nat} (P : Type) (v₁ v₂ : vector A n) : Type := + cases_on v₁ + (cases_on v₂ + (P → P) + (λ n₂ h₂ t₂, P)) + (λ n₁ h₁ t₁, cases_on v₂ + P + (λ n₂ h₂ t₂, (Π (H : n₁ = n₂), h₁ = h₂ → eq.rec_on H t₁ = t₂ → P) → P)) + + definition no_confusion {A : Type} {n : nat} {P : Type} {v₁ v₂ : vector A n} : v₁ = v₂ → no_confusion_type P v₁ v₂ := + assume H₁₂ : v₁ = v₂, + have aux : v₁ = v₁ → no_confusion_type P v₁ v₁, from + take H₁₁, cases_on v₁ + (assume h : P, h) + (take n₁ h₁ t₁, assume h : (Π (H : n₁ = n₁), h₁ = h₁ → t₁ = t₁ → P), + h rfl rfl rfl), + eq.rec aux H₁₂ H₁₂ + + theorem vcons.inj₁ {A : Type} {n : nat} (a₁ a₂ : A) (v₁ v₂ : vector A n) : vcons a₁ v₁ = vcons a₂ v₂ → a₁ = a₂ := + assume h, no_confusion h (λ n h t, h) + + theorem vcons.inj₂ {A : Type} {n : nat} (a₁ a₂ : A) (v₁ v₂ : vector A n) : vcons a₁ v₁ = vcons a₂ v₂ → v₁ = v₂ := + assume h, no_confusion h (λ n h t, t) + +end vector