Prevent possibility of forgetting to re-widen

Previously, there were separate narrow () and widen ()
functions that had to operate as pairs. This commit
changes to use a bracketing style that means we can't
forget to widen once we narrow.

typing/typeclass.ml

@@ -1376,14 +1376,14 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
          }
   | Pcl_constraint (scl', scty) ->
       Ctype.begin_class_def ();
-      Typetexp.narrow ();
-      let cl = class_expr cl_num val_env met_env virt self_scope scl' in
-      complete_class_type cl.cl_loc val_env virt Class_type cl.cl_type;
-      Typetexp.widen ();
-      Typetexp.narrow ();
-      let clty = class_type val_env virt self_scope scty in
-      complete_class_type clty.cltyp_loc val_env virt Class clty.cltyp_type;
-      Typetexp.widen ();
+      let cl = Typetexp.narrow_in (fun () ->
+        let cl = class_expr cl_num val_env met_env virt self_scope scl' in
+        complete_class_type cl.cl_loc val_env virt Class_type cl.cl_type;
+        cl) in
+      let clty = Typetexp.narrow_in (fun () ->
+        let clty = class_type val_env virt self_scope scty in
+        complete_class_type clty.cltyp_loc val_env virt Class clty.cltyp_type;
+        clty) in
       Ctype.end_def ();
 
       Ctype.limited_generalize_class_type

typing/typecore.ml

@@ -4674,29 +4674,30 @@ and type_expect_
       let ty = newvar() in
       (* remember original level *)
       begin_def ();
-      Typetexp.narrow ();
-      let modl, md_shape = !type_module env smodl in
-      Mtype.lower_nongen (get_level ty) modl.mod_type;
-      let pres =
-        match modl.mod_type with
-        | Mty_alias _ -> Mp_absent
-        | _ -> Mp_present
-      in
-      let scope = create_scope () in
-      let md =
-        { md_type = modl.mod_type; md_attributes = []; md_loc = name.loc;
-          md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); }
-      in
-      let (id, new_env) =
-        match name.txt with
-        | None -> None, env
-        | Some name ->
-          let id, env =
-            Env.enter_module_declaration ~scope ~shape:md_shape name pres md env
-          in
-          Some id, env
-      in
-      Typetexp.widen ();
+      let modl, pres, id, new_env = Typetexp.narrow_in begin fun () ->
+        let modl, md_shape = !type_module env smodl in
+        Mtype.lower_nongen (get_level ty) modl.mod_type;
+        let pres =
+          match modl.mod_type with
+          | Mty_alias _ -> Mp_absent
+          | _ -> Mp_present
+        in
+        let scope = create_scope () in
+        let md =
+          { md_type = modl.mod_type; md_attributes = []; md_loc = name.loc;
+            md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); }
+        in
+        let (id, new_env) =
+          match name.txt with
+          | None -> None, env
+          | Some name ->
+            let id, env =
+              Env.enter_module_declaration ~scope ~shape:md_shape name pres md env
+            in
+            Some id, env
+        in
+        modl, pres, id, new_env
+      end in
       (* ideally, we should catch Expr_type_clash errors
          in type_expect triggered by escaping identifiers from the local module
          and refine them into Scoping_let_module errors
@@ -6075,33 +6076,33 @@ and type_unpacks ?(in_function : (Location.t * type_expr * bool) option)
   let extended_env, tunpacks =
     List.fold_left (fun (env, tunpacks) unpack ->
       begin_def ();
-      Typetexp.narrow ();
-      let modl, md_shape =
-        !type_module env
-          Ast_helper.(
-            Mod.unpack ~loc:unpack.tu_loc
-              (Exp.ident ~loc:unpack.tu_name.loc
-                 (mkloc (Longident.Lident unpack.tu_name.txt)
-                    unpack.tu_name.loc)))
-      in
-      Mtype.lower_nongen (get_level ty) modl.mod_type;
-      let pres =
-        match modl.mod_type with
-        | Mty_alias _ -> Mp_absent
-        | _ -> Mp_present
-      in
-      let scope = create_scope () in
-      let md =
-        { md_type = modl.mod_type; md_attributes = [];
-          md_loc = unpack.tu_name.loc;
-          md_uid = unpack.tu_uid; }
-      in
-      let (id, env) =
-        Env.enter_module_declaration ~scope ~shape:md_shape
-          unpack.tu_name.txt pres md env
-      in
-      Typetexp.widen ();
-      env, (id, unpack.tu_name, pres, modl) :: tunpacks
+      Typetexp.narrow_in begin fun () ->
+        let modl, md_shape =
+          !type_module env
+            Ast_helper.(
+              Mod.unpack ~loc:unpack.tu_loc
+                (Exp.ident ~loc:unpack.tu_name.loc
+                   (mkloc (Longident.Lident unpack.tu_name.txt)
+                      unpack.tu_name.loc)))
+        in
+        Mtype.lower_nongen (get_level ty) modl.mod_type;
+        let pres =
+          match modl.mod_type with
+          | Mty_alias _ -> Mp_absent
+          | _ -> Mp_present
+        in
+        let scope = create_scope () in
+        let md =
+          { md_type = modl.mod_type; md_attributes = [];
+            md_loc = unpack.tu_name.loc;
+            md_uid = unpack.tu_uid; }
+        in
+        let (id, env) =
+          Env.enter_module_declaration ~scope ~shape:md_shape
+            unpack.tu_name.txt pres md env
+        in
+        env, (id, unpack.tu_name, pres, modl) :: tunpacks
+      end
     ) (env, []) unpacks
   in
   (* ideally, we should catch Expr_type_clash errors

typing/typedecl.ml

@@ -293,10 +293,9 @@ let make_constructor env loc type_path type_params svars sargs sret_type =
         transl_constructor_arguments env None true sargs
       in
         targs, None, args, None
-  | Some sret_type ->
-      (* if it's a generalized constructor we must first narrow and
-         then widen so as to not introduce any new constraints *)
-      narrow ();
+  | Some sret_type -> narrow_in begin fun () ->
+      (* if it's a generalized constructor we must work in a narrowed
+         context so as to not introduce any new constraints *)
       reset_type_variables ();
       let univars, closed =
         match svars with
@@ -337,8 +336,8 @@ let make_constructor env loc type_path type_params svars sargs sret_type =
          Btype.iter_type_expr_cstr_args set_level args;
          set_level ret_type;
       end;
-      widen ();
       targs, Some tret_type, args, Some ret_type
+    end
 
 let transl_declaration env sdecl (id, uid) =
   (* Bind type parameters *)

typing/typemod.ml

@@ -3037,10 +3037,11 @@ let type_package env m p fl =
   (* Same as Pexp_letmodule *)
   (* remember original level *)
   Ctype.begin_def ();
-  Typetexp.narrow ();
-  let modl, _mod_shape = type_module env m in
-  let scope = Ctype.create_scope () in
-  Typetexp.widen ();
+  let modl, scope = Typetexp.narrow_in begin fun () ->
+    let modl, _mod_shape = type_module env m in
+    let scope = Ctype.create_scope () in
+    modl, scope
+  end in
   let fl', env =
     match fl with
     | [] -> [], env

typing/typetexp.ml

@@ -98,20 +98,13 @@ let reset_type_variables () =
   Ctype.reset_reified_var_counter ();
   type_variables := TyVarMap.empty
 
-include (struct
-    let type_variable_stack = Stack.create ()
-
-    let narrow () =
-      Stack.push (increase_global_level (), !type_variables) type_variable_stack
-    let widen () =
-      let gl, tv = Stack.pop type_variable_stack in
-      restore_global_level gl;
-      type_variables := tv
-  end : sig
-    val narrow : unit -> unit
-    val widen : unit -> unit
-  end
-)
+let narrow_in f =
+  let old_gl = increase_global_level () in
+  let old_tv = !type_variables in
+  let result = f () in
+  restore_global_level old_gl;
+  type_variables := old_tv;
+  result
 
 let strict_ident c = (c = '_' || c >= 'a' && c <= 'z' || c >= 'A' && c <= 'Z')
 
@@ -557,9 +550,7 @@ and transl_type_aux env policy mode styp =
       ctyp (Ttyp_poly (vars, cty)) ty'
   | Ptyp_package (p, l) ->
       let l, mty = create_package_mty true styp.ptyp_loc env (p, l) in
-      narrow ();
-      let mty = !transl_modtype env mty in
-      widen ();
+      let mty = narrow_in (fun () -> !transl_modtype env mty) in
       let ptys = List.map (fun (s, pty) ->
                              s, transl_type env policy Alloc_mode.Global pty
                           ) l in

typing/typetexp.mli

@@ -53,8 +53,8 @@ val transl_type_param:
 
 val get_alloc_mode : Parsetree.core_type -> alloc_mode_const
 
-val narrow: unit -> unit
-val widen: unit -> unit
+val narrow_in: (unit -> 'a) -> 'a
+  (* Evaluate in a narrowed type-variable scope *)
 
 exception Already_bound