Fix PR#7519, but high cost in update_level

2 files changed, 45 insertions, 32 deletions

diff --git a/typing/ctype.ml b/typing/ctype.ml
index e5094ec0e8..a506b3bfed 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -658,6 +658,35 @@ let rec generalize_spine ty =
       List.iter generalize_spine tyl
   | _ -> ()
 
+(*
+   Check whether the abbreviation expands to a well-defined type.
+   During the typing of a class, abbreviations for correspondings
+   types expand to non-generic types.
+*)
+let generic_abbrev env path =
+  try
+    let (_, body, _) = Env.find_type_expansion path env in
+    (repr body).level = generic_level
+  with
+    Not_found ->
+      false
+
+let generic_private_abbrev env path =
+  try
+    match Env.find_type path env with
+      {type_kind = Type_abstract;
+       type_private = Private;
+       type_manifest = Some body} ->
+         (repr body).level = generic_level
+    | _ -> false
+  with Not_found -> false
+
+let is_contractive env p =
+  try
+    let decl = Env.find_type p env in
+    in_pervasives p && decl.type_manifest = None || is_datatype decl
+  with Not_found -> false
+
 let forward_try_expand_once = (* Forward declaration *)
   ref (fun _env _ty -> raise Cannot_expand)
 
@@ -719,6 +748,19 @@ let rec update_level env level ty =
           if level < get_level env p then raise (Unify [(ty, newvar2 level)]);
           iter_type_expr (update_level env level) ty
         end
+    | Tconstr(p, _tl, _abbrev) when generic_abbrev env p ->
+        let snap = snapshot () in
+        begin try
+          set_level ty level;
+          iter_type_expr (update_level env level) ty
+        with Unify _ -> try
+          backtrack snap;
+          link_type ty (!forward_try_expand_once env ty);
+          update_level env level ty
+        with Cannot_expand ->
+          set_level ty level;
+          iter_type_expr (update_level env level) ty
+        end          
     | Tpackage (p, nl, tl) when level < Path.binding_time p ->
         let p' = normalize_package_path env p in
         if Path.same p p' then raise (Unify [(ty, newvar2 level)]);
@@ -1545,35 +1587,6 @@ let full_expand env ty =
   | _ ->
       ty
 
-(*
-   Check whether the abbreviation expands to a well-defined type.
-   During the typing of a class, abbreviations for correspondings
-   types expand to non-generic types.
-*)
-let generic_abbrev env path =
-  try
-    let (_, body, _) = Env.find_type_expansion path env in
-    (repr body).level = generic_level
-  with
-    Not_found ->
-      false
-
-let generic_private_abbrev env path =
-  try
-    match Env.find_type path env with
-      {type_kind = Type_abstract;
-       type_private = Private;
-       type_manifest = Some body} ->
-         (repr body).level = generic_level
-    | _ -> false
-  with Not_found -> false
-
-let is_contractive env p =
-  try
-    let decl = Env.find_type p env in
-    in_pervasives p && decl.type_manifest = None || is_datatype decl
-  with Not_found -> false
-
 
                               (*****************)
                               (*  Occur check  *)
diff --git a/typing/typecore.ml b/typing/typecore.ml
index a1e47a10e6..a616ca84d2 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -2800,7 +2800,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
       let (id, new_env) = Env.enter_module name.txt modl.mod_type env in
       Ctype.init_def(Ident.current_time());
       Typetexp.widen context;
-      let body = type_expect new_env sbody ty_expected in
+      let body = type_expect new_env sbody (correct_levels ty_expected) in
       (* go back to original level *)
       end_def ();
       (* Unification of body.exp_type with the fresh variable ty
@@ -2809,11 +2809,11 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
          type body.exp_type.  Thus, this unification enforces the
          scoping condition on "let module". *)
       begin try
-        Ctype.unify_var new_env ty body.exp_type
+        Ctype.unify_var new_env ty body.exp_type;
       with Unify _ ->
         raise(Error(loc, env, Scoping_let_module(name.txt, body.exp_type)))
       end;
-      re {
+      rue {
         exp_desc = Texp_letmodule(id, name, modl, body);
         exp_loc = loc; exp_extra = [];
         exp_type = ty;