Fix bug #4420: check_types was losing universe constraints.

2 files changed, 27 insertions, 5 deletions

diff --git a/tactics/tactics.ml b/tactics/tactics.ml
index 131730ebc0..b57fd70ee1 100644
--- a/tactics/tactics.ml
+++ b/tactics/tactics.ml
@@ -634,24 +634,27 @@ let check_types env sigma mayneedglobalcheck deep newc origc =
   let t1 = Retyping.get_type_of env sigma newc in
   if deep then begin
     let t2 = Retyping.get_type_of env sigma origc in
-    let sigma, t2 = Evarsolve.refresh_universes ~onlyalg:true (Some false) env sigma t2 in
-    if not (snd (infer_conv ~pb:Reduction.CUMUL env sigma t1 t2)) then
+    let sigma, t2 = Evarsolve.refresh_universes
+		      ~onlyalg:true (Some false) env sigma t2 in
+    let sigma, b = infer_conv ~pb:Reduction.CUMUL env sigma t1 t2 in
+    if not b then
       if
         isSort (whd_betadeltaiota env sigma t1) &&
         isSort (whd_betadeltaiota env sigma t2)
-      then
-        mayneedglobalcheck := true
+      then (mayneedglobalcheck := true; sigma)
       else
         errorlabstrm "convert-check-hyp" (str "Types are incompatible.")
+    else sigma
   end
   else
     if not (isSort (whd_betadeltaiota env sigma t1)) then
       errorlabstrm "convert-check-hyp" (str "Not a type.")
+    else sigma
 
 (* Now we introduce different instances of the previous tacticals *)
 let change_and_check cv_pb mayneedglobalcheck deep t env sigma c =
   let sigma, t' = t sigma in
-  check_types env sigma mayneedglobalcheck deep t' c;
+  let sigma = check_types env sigma mayneedglobalcheck deep t' c in
   let sigma, b = infer_conv ~pb:cv_pb env sigma t' c in
   if not b then errorlabstrm "convert-check-hyp" (str "Not convertible.");
   sigma, t'
diff --git a/test-suite/bugs/closed/4420.v b/test-suite/bugs/closed/4420.v
new file mode 100644
index 0000000000..0e16cb2399
--- /dev/null
+++ b/test-suite/bugs/closed/4420.v
@@ -0,0 +1,19 @@
+Module foo.
+  Context (Char : Type).
+  Axiom foo : Type -> Type.
+  Goal foo Char = foo Char.
+    change foo with (fun x => foo x).
+    cbv beta.
+    reflexivity.
+  Defined. 
+End foo.
+
+Inductive foo (A : Type) : Prop := I. (*Top.1*)
+Lemma bar : foo Type. (*Top.3*)
+Proof.
+  Set Printing Universes.
+change foo with (fun x : Type => foo x). (*Top.4*)
+cbv beta.
+apply I. (* I Type@{Top.3} : (fun x : Type@{Top.4} => foo x) Type@{Top.3} *)
+Defined.
+