Encapsulate functions that work with tyvars

See new module at top of Typetexp.

typing/typeclass.ml

@@ -259,9 +259,9 @@ let unify_delayed_method_type loc env label ty expected_ty=
       raise(Error(loc, env, Field_type_mismatch ("method", label, trace)))
 
 let type_constraint val_env sty sty' loc =
-  let cty  = transl_simple_type val_env false Global sty in
+  let cty  = transl_simple_type val_env ~fixed:false Global sty in
   let ty = cty.ctyp_type in
-  let cty' = transl_simple_type val_env false Global sty' in
+  let cty' = transl_simple_type val_env ~fixed:false Global sty' in
   let ty' = cty'.ctyp_type in
   begin
     try Ctype.unify val_env ty ty' with Ctype.Unify err ->
@@ -301,7 +301,7 @@ let rec class_type_field env sign self_scope ctf =
   | Pctf_val ({txt=lab}, mut, virt, sty) ->
       mkctf_with_attrs
         (fun () ->
-          let cty = transl_simple_type env false Global sty in
+          let cty = transl_simple_type env ~fixed:false Global sty in
           let ty = cty.ctyp_type in
           add_instance_variable ~strict:false loc env lab mut virt ty sign;
           Tctf_val (lab, mut, virt, cty))
@@ -325,7 +325,7 @@ let rec class_type_field env sign self_scope ctf =
                  ) :: !delayed_meth_specs;
                Tctf_method (lab, priv, virt, returned_cty)
            | _ ->
-               let cty = transl_simple_type env false Global sty in
+               let cty = transl_simple_type env ~fixed:false Global sty in
                let ty = cty.ctyp_type in
                add_method loc env lab priv virt ty sign;
                Tctf_method (lab, priv, virt, cty))
@@ -349,7 +349,7 @@ and class_signature virt env pcsig self_scope loc =
   (* Introduce a dummy method preventing self type from being closed. *)
   Ctype.add_dummy_method env ~scope:self_scope sign;
 
-  let self_cty = transl_simple_type env false Global sty in
+  let self_cty = transl_simple_type env ~fixed:false Global sty in
   let self_type = self_cty.ctyp_type in
   begin try
     Ctype.unify env self_type sign.csig_self
@@ -399,7 +399,7 @@ and class_type_aux env virt self_scope scty =
                                                    List.length styl)));
       let ctys = List.map2
         (fun sty ty ->
-          let cty' = transl_simple_type env false Global sty in
+          let cty' = transl_simple_type env ~fixed:false Global sty in
           let ty' = cty'.ctyp_type in
           begin
            try Ctype.unify env ty' ty with Ctype.Unify err ->
@@ -419,7 +419,7 @@ and class_type_aux env virt self_scope scty =
       cltyp (Tcty_signature clsig) typ
 
   | Pcty_arrow (l, sty, scty) ->
-      let cty = transl_simple_type env false Global sty in
+      let cty = transl_simple_type env ~fixed:false Global sty in
       let ty = cty.ctyp_type in
       let ty =
         if Btype.is_optional l
@@ -651,7 +651,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf =
       with_attrs
         (fun () ->
            if !Clflags.principal then Ctype.begin_def ();
-           let cty = Typetexp.transl_simple_type val_env false Global styp in
+           let cty = Typetexp.transl_simple_type val_env ~fixed:false Global styp in
            let ty = cty.ctyp_type in
            if !Clflags.principal then begin
              Ctype.end_def ();
@@ -725,7 +725,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf =
       with_attrs
         (fun () ->
            let sty = Ast_helper.Typ.force_poly sty in
-           let cty = transl_simple_type val_env false Global sty in
+           let cty = transl_simple_type val_env ~fixed:false Global sty in
            let ty = cty.ctyp_type in
            add_method loc val_env label.txt priv Virtual ty sign;
            let field =
@@ -765,7 +765,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf =
              | Some sty ->
                  let sty = Ast_helper.Typ.force_poly sty in
                  let cty' =
-                   Typetexp.transl_simple_type val_env false Global sty
+                   Typetexp.transl_simple_type val_env ~fixed:false Global sty
                  in
                  cty'.ctyp_type
            in
@@ -1073,7 +1073,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
       if Path.same decl.cty_path unbound_class then
         raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt));
       let tyl = List.map
-          (fun sty -> transl_simple_type val_env false Global sty)
+          (fun sty -> transl_simple_type val_env ~fixed:false Global sty)
           styl
       in
       let (params, clty) =
@@ -1376,11 +1376,11 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
          }
   | Pcl_constraint (scl', scty) ->
       Ctype.begin_class_def ();
-      let cl = Typetexp.narrow_in (fun () ->
+      let cl = Typetexp.TyVarEnv.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 = Typetexp.TyVarEnv.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
@@ -1549,7 +1549,7 @@ let class_infos define_class kind
      constr_type, dummy_class)
     (res, env) =
 
-  reset_type_variables ();
+  TyVarEnv.reset ();
   Ctype.begin_class_def ();
 
   (* Introduce class parameters *)

typing/typecore.ml

@@ -3147,7 +3147,7 @@ let rec approx_type env sty =
           (* Polymorphic types will only unify with types that match all of their
            polymorphic parts, so we need to fully translate the type here
            unlike in the monomorphic case *)
-          Typetexp.transl_simple_type env false arg_mode arg_sty
+          Typetexp.transl_simple_type env ~fixed:false arg_mode arg_sty
         in
         let ret = approx_type env sty in
         let marg = Alloc_mode.of_const arg_mode in
@@ -3182,7 +3182,7 @@ let type_pattern_approx env spat ty_expected =
         else Alloc_mode.Global
       in
       let ty_pat =
-        Typetexp.transl_simple_type env false arg_type_mode sty
+        Typetexp.transl_simple_type env ~fixed:false arg_type_mode sty
       in
       begin try unify env ty_pat.ctyp_type ty_expected with Unify trace ->
         raise(Error(spat.ppat_loc, env, Pattern_type_clash(trace, None)))
@@ -4379,7 +4379,7 @@ and type_expect_
         if has_local_attr_exp sexp then Alloc_mode.Local
         else Alloc_mode.Global
       in
-      let cty = Typetexp.transl_simple_type env false type_mode sty in
+      let cty = Typetexp.transl_simple_type env ~fixed:false type_mode sty in
       let ty = cty.ctyp_type in
       end_def ();
       generalize_structure ty;
@@ -4674,7 +4674,7 @@ and type_expect_
       let ty = newvar() in
       (* remember original level *)
       begin_def ();
-      let modl, pres, id, new_env = Typetexp.narrow_in begin fun () ->
+      let modl, pres, id, new_env = Typetexp.TyVarEnv.narrow_in begin fun () ->
         let modl, md_shape = !type_module env smodl in
         Mtype.lower_nongen (get_level ty) modl.mod_type;
         let pres =
@@ -4779,7 +4779,7 @@ and type_expect_
         match sty with None -> ty_expected, None
         | Some sty ->
             let sty = Ast_helper.Typ.force_poly sty in
-            let cty = Typetexp.transl_simple_type env false Global sty in
+            let cty = Typetexp.transl_simple_type env ~fixed:false Global sty in
             cty.ctyp_type, Some cty
       in
       if !Clflags.principal then begin
@@ -6076,7 +6076,7 @@ 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_in begin fun () ->
+      Typetexp.TyVarEnv.narrow_in begin fun () ->
         let modl, md_shape =
           !type_module env
             Ast_helper.(
@@ -6814,7 +6814,7 @@ and type_andops env sarg sands expected_ty =
 (* Typing of toplevel bindings *)
 
 let type_binding env rec_flag spat_sexp_list =
-  Typetexp.reset_type_variables();
+  Typetexp.TyVarEnv.reset ();
   let (pat_exp_list, new_env, _unpacks) =
     type_let
       ~check:(fun s -> Warnings.Unused_value_declaration s)
@@ -6832,7 +6832,7 @@ let type_let existential_ctx env rec_flag spat_sexp_list =
 (* Typing of toplevel expressions *)
 
 let type_expression env sexp =
-  Typetexp.reset_type_variables();
+  Typetexp.TyVarEnv.reset ();
   begin_def();
   let exp = type_exp env mode_global sexp in
   end_def();

typing/typedecl.ml

@@ -237,7 +237,7 @@ let transl_labels env univars closed lbls =
     Builtin_attributes.warning_scope attrs
       (fun () ->
          let arg = Ast_helper.Typ.force_poly arg in
-         let cty = transl_simple_type env ?univars closed Global arg in
+         let cty = transl_simple_type env ?univars ~fixed:closed Global arg in
          let gbl =
            match mut with
            | Mutable -> Types.Global
@@ -268,7 +268,7 @@ let transl_labels env univars closed lbls =
 
 let transl_types_gf env univars closed tyl =
   let mk arg =
-    let cty = transl_simple_type env ?univars closed Global arg in
+    let cty = transl_simple_type env ?univars ~fixed:closed Global arg in
     let gf = transl_global_flags arg.ptyp_loc arg.ptyp_attributes in
     (cty, gf)
   in
@@ -293,21 +293,21 @@ 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 -> narrow_in begin fun () ->
+  | Some sret_type -> TyVarEnv.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 ();
+      TyVarEnv.reset ();
       let univars, closed =
         match svars with
         | [] -> None, false
         | vs ->
            Ctype.begin_def();
-           Some (make_poly_univars (List.map (fun v -> v.txt) vs)), true
+           Some (TyVarEnv.make_poly_univars (List.map (fun v -> v.txt) vs)), true
       in
       let args, targs =
         transl_constructor_arguments env univars closed sargs
       in
-      let tret_type = transl_simple_type env ?univars closed Global sret_type in
+      let tret_type = transl_simple_type env ?univars ~fixed:closed Global sret_type in
       let ret_type = tret_type.ctyp_type in
       (* TODO add back type_path as a parameter ? *)
       begin match get_desc ret_type with
@@ -341,14 +341,14 @@ let make_constructor env loc type_path type_params svars sargs sret_type =
 
 let transl_declaration env sdecl (id, uid) =
   (* Bind type parameters *)
-  reset_type_variables();
+  TyVarEnv.reset ();
   Ctype.begin_def ();
   let tparams = make_params env sdecl.ptype_params in
   let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
   let cstrs = List.map
     (fun (sty, sty', loc) ->
-      transl_simple_type env false Global sty,
-      transl_simple_type env false Global sty', loc)
+      transl_simple_type env ~fixed:false Global sty,
+      transl_simple_type env ~fixed:false Global sty', loc)
     sdecl.ptype_cstrs
   in
   let unboxed_attr = get_unboxed_from_attributes sdecl in
@@ -463,7 +463,7 @@ let transl_declaration env sdecl (id, uid) =
         None -> None, None
       | Some sty ->
         let no_row = not (is_fixed_type sdecl) in
-        let cty = transl_simple_type env no_row Global sty in
+        let cty = transl_simple_type env ~fixed:no_row Global sty in
         Some cty, Some cty.ctyp_type
     in
     let arity = List.length params in
@@ -1144,9 +1144,9 @@ let is_rebind ext =
 
 let transl_type_extension extend env loc styext =
   (* Note: it would be incorrect to call [create_scope] *after*
-     [reset_type_variables] or after [begin_def] (see #10010). *)
+     [TyVarEnv.reset] or after [begin_def] (see #10010). *)
   let scope = Ctype.create_scope () in
-  reset_type_variables();
+  TyVarEnv.reset ();
   Ctype.begin_def();
   let type_path, type_decl =
     let lid = styext.ptyext_path in
@@ -1255,7 +1255,7 @@ let transl_type_extension extend env loc styext =
 
 let transl_exception env sext =
   let scope = Ctype.create_scope () in
-  reset_type_variables();
+  TyVarEnv.reset ();
   Ctype.begin_def();
   let ext =
     transl_extension_constructor ~scope env
@@ -1488,7 +1488,7 @@ let transl_value_decl env loc valdecl =
 let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env
     sdecl =
   Env.mark_type_used sig_decl.type_uid;
-  reset_type_variables();
+  TyVarEnv.reset ();
   Ctype.begin_def();
   (* In the first part of this function, we typecheck the syntactic
      declaration [sdecl] in the outer environment [outer_env]. *)
@@ -1499,8 +1499,8 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env
   let arity = List.length params in
   let constraints =
     List.map (fun (ty, ty', loc) ->
-      let cty = transl_simple_type env false Global ty in
-      let cty' = transl_simple_type env false Global ty' in
+      let cty = transl_simple_type env ~fixed:false Global ty in
+      let cty' = transl_simple_type env ~fixed:false Global ty' in
       (* Note: We delay the unification of those constraints
          after the unification of parameters, so that clashing
          constraints report an error on the constraint location
@@ -1512,7 +1512,7 @@ let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env
   let (tman, man) =  match sdecl.ptype_manifest with
       None -> None, None
     | Some sty ->
-        let cty = transl_simple_type env no_row Global sty in
+        let cty = transl_simple_type env ~fixed:no_row Global sty in
         Some cty, Some cty.ctyp_type
   in
   (* In the second part, we check the consistency between the two

typing/typemod.ml

@@ -3037,7 +3037,7 @@ let type_package env m p fl =
   (* Same as Pexp_letmodule *)
   (* remember original level *)
   Ctype.begin_def ();
-  let modl, scope = Typetexp.narrow_in begin fun () ->
+  let modl, scope = Typetexp.TyVarEnv.narrow_in begin fun () ->
     let modl, _mod_shape = type_module env m in
     let scope = Ctype.create_scope () in
     modl, scope
@@ -3534,4 +3534,4 @@ let () =
 let reset ~preserve_persistent_env =
   Env.reset_cache ~preserve_persistent_env;
   Envaux.reset_cache ~preserve_persistent_env;
-  Typetexp.reset_type_variables ()
+  Typetexp.TyVarEnv.reset ()