Skip to content

Commit a3f60ab

Browse files
goldfireregoldfirere
committed
Encapsulate functions that work with tyvars
See new module at top of Typetexp.
1 parent 43d83a6 commit a3f60ab

6 files changed

Lines changed: 259 additions & 195 deletions

File tree

‎typing/typeclass.ml‎

Lines changed: 14 additions & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -259,9 +259,9 @@ let unify_delayed_method_type loc env label ty expected_ty=
259259
raise(Error(loc, env, Field_type_mismatch ("method", label, trace)))
260260

261261
let type_constraint val_env sty sty' loc =
262-
let cty = transl_simple_type val_env false Global sty in
262+
let cty = transl_simple_type val_env ~fixed:false Global sty in
263263
let ty = cty.ctyp_type in
264-
let cty' = transl_simple_type val_env false Global sty' in
264+
let cty' = transl_simple_type val_env ~fixed:false Global sty' in
265265
let ty' = cty'.ctyp_type in
266266
begin
267267
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 =
301301
| Pctf_val ({txt=lab}, mut, virt, sty) ->
302302
mkctf_with_attrs
303303
(fun () ->
304-
let cty = transl_simple_type env false Global sty in
304+
let cty = transl_simple_type env ~fixed:false Global sty in
305305
let ty = cty.ctyp_type in
306306
add_instance_variable ~strict:false loc env lab mut virt ty sign;
307307
Tctf_val (lab, mut, virt, cty))
@@ -325,7 +325,7 @@ let rec class_type_field env sign self_scope ctf =
325325
) :: !delayed_meth_specs;
326326
Tctf_method (lab, priv, virt, returned_cty)
327327
| _ ->
328-
let cty = transl_simple_type env false Global sty in
328+
let cty = transl_simple_type env ~fixed:false Global sty in
329329
let ty = cty.ctyp_type in
330330
add_method loc env lab priv virt ty sign;
331331
Tctf_method (lab, priv, virt, cty))
@@ -349,7 +349,7 @@ and class_signature virt env pcsig self_scope loc =
349349
(* Introduce a dummy method preventing self type from being closed. *)
350350
Ctype.add_dummy_method env ~scope:self_scope sign;
351351

352-
let self_cty = transl_simple_type env false Global sty in
352+
let self_cty = transl_simple_type env ~fixed:false Global sty in
353353
let self_type = self_cty.ctyp_type in
354354
begin try
355355
Ctype.unify env self_type sign.csig_self
@@ -399,7 +399,7 @@ and class_type_aux env virt self_scope scty =
399399
List.length styl)));
400400
let ctys = List.map2
401401
(fun sty ty ->
402-
let cty' = transl_simple_type env false Global sty in
402+
let cty' = transl_simple_type env ~fixed:false Global sty in
403403
let ty' = cty'.ctyp_type in
404404
begin
405405
try Ctype.unify env ty' ty with Ctype.Unify err ->
@@ -419,7 +419,7 @@ and class_type_aux env virt self_scope scty =
419419
cltyp (Tcty_signature clsig) typ
420420

421421
| Pcty_arrow (l, sty, scty) ->
422-
let cty = transl_simple_type env false Global sty in
422+
let cty = transl_simple_type env ~fixed:false Global sty in
423423
let ty = cty.ctyp_type in
424424
let ty =
425425
if Btype.is_optional l
@@ -651,7 +651,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf =
651651
with_attrs
652652
(fun () ->
653653
if !Clflags.principal then Ctype.begin_def ();
654-
let cty = Typetexp.transl_simple_type val_env false Global styp in
654+
let cty = Typetexp.transl_simple_type val_env ~fixed:false Global styp in
655655
let ty = cty.ctyp_type in
656656
if !Clflags.principal then begin
657657
Ctype.end_def ();
@@ -725,7 +725,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf =
725725
with_attrs
726726
(fun () ->
727727
let sty = Ast_helper.Typ.force_poly sty in
728-
let cty = transl_simple_type val_env false Global sty in
728+
let cty = transl_simple_type val_env ~fixed:false Global sty in
729729
let ty = cty.ctyp_type in
730730
add_method loc val_env label.txt priv Virtual ty sign;
731731
let field =
@@ -765,7 +765,7 @@ let rec class_field_first_pass self_loc cl_num sign self_scope acc cf =
765765
| Some sty ->
766766
let sty = Ast_helper.Typ.force_poly sty in
767767
let cty' =
768-
Typetexp.transl_simple_type val_env false Global sty
768+
Typetexp.transl_simple_type val_env ~fixed:false Global sty
769769
in
770770
cty'.ctyp_type
771771
in
@@ -1073,7 +1073,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
10731073
if Path.same decl.cty_path unbound_class then
10741074
raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt));
10751075
let tyl = List.map
1076-
(fun sty -> transl_simple_type val_env false Global sty)
1076+
(fun sty -> transl_simple_type val_env ~fixed:false Global sty)
10771077
styl
10781078
in
10791079
let (params, clty) =
@@ -1376,11 +1376,11 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
13761376
}
13771377
| Pcl_constraint (scl', scty) ->
13781378
Ctype.begin_class_def ();
1379-
let cl = Typetexp.narrow_in (fun () ->
1379+
let cl = Typetexp.TyVarEnv.narrow_in (fun () ->
13801380
let cl = class_expr cl_num val_env met_env virt self_scope scl' in
13811381
complete_class_type cl.cl_loc val_env virt Class_type cl.cl_type;
13821382
cl) in
1383-
let clty = Typetexp.narrow_in (fun () ->
1383+
let clty = Typetexp.TyVarEnv.narrow_in (fun () ->
13841384
let clty = class_type val_env virt self_scope scty in
13851385
complete_class_type clty.cltyp_loc val_env virt Class clty.cltyp_type;
13861386
clty) in
@@ -1549,7 +1549,7 @@ let class_infos define_class kind
15491549
constr_type, dummy_class)
15501550
(res, env) =
15511551

1552-
reset_type_variables ();
1552+
TyVarEnv.reset ();
15531553
Ctype.begin_class_def ();
15541554

15551555
(* Introduce class parameters *)

‎typing/typecore.ml‎

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -3147,7 +3147,7 @@ let rec approx_type env sty =
31473147
(* Polymorphic types will only unify with types that match all of their
31483148
polymorphic parts, so we need to fully translate the type here
31493149
unlike in the monomorphic case *)
3150-
Typetexp.transl_simple_type env false arg_mode arg_sty
3150+
Typetexp.transl_simple_type env ~fixed:false arg_mode arg_sty
31513151
in
31523152
let ret = approx_type env sty in
31533153
let marg = Alloc_mode.of_const arg_mode in
@@ -3182,7 +3182,7 @@ let type_pattern_approx env spat ty_expected =
31823182
else Alloc_mode.Global
31833183
in
31843184
let ty_pat =
3185-
Typetexp.transl_simple_type env false arg_type_mode sty
3185+
Typetexp.transl_simple_type env ~fixed:false arg_type_mode sty
31863186
in
31873187
begin try unify env ty_pat.ctyp_type ty_expected with Unify trace ->
31883188
raise(Error(spat.ppat_loc, env, Pattern_type_clash(trace, None)))
@@ -4379,7 +4379,7 @@ and type_expect_
43794379
if has_local_attr_exp sexp then Alloc_mode.Local
43804380
else Alloc_mode.Global
43814381
in
4382-
let cty = Typetexp.transl_simple_type env false type_mode sty in
4382+
let cty = Typetexp.transl_simple_type env ~fixed:false type_mode sty in
43834383
let ty = cty.ctyp_type in
43844384
end_def ();
43854385
generalize_structure ty;
@@ -4674,7 +4674,7 @@ and type_expect_
46744674
let ty = newvar() in
46754675
(* remember original level *)
46764676
begin_def ();
4677-
let modl, pres, id, new_env = Typetexp.narrow_in begin fun () ->
4677+
let modl, pres, id, new_env = Typetexp.TyVarEnv.narrow_in begin fun () ->
46784678
let modl, md_shape = !type_module env smodl in
46794679
Mtype.lower_nongen (get_level ty) modl.mod_type;
46804680
let pres =
@@ -4779,7 +4779,7 @@ and type_expect_
47794779
match sty with None -> ty_expected, None
47804780
| Some sty ->
47814781
let sty = Ast_helper.Typ.force_poly sty in
4782-
let cty = Typetexp.transl_simple_type env false Global sty in
4782+
let cty = Typetexp.transl_simple_type env ~fixed:false Global sty in
47834783
cty.ctyp_type, Some cty
47844784
in
47854785
if !Clflags.principal then begin
@@ -6076,7 +6076,7 @@ and type_unpacks ?(in_function : (Location.t * type_expr * bool) option)
60766076
let extended_env, tunpacks =
60776077
List.fold_left (fun (env, tunpacks) unpack ->
60786078
begin_def ();
6079-
Typetexp.narrow_in begin fun () ->
6079+
Typetexp.TyVarEnv.narrow_in begin fun () ->
60806080
let modl, md_shape =
60816081
!type_module env
60826082
Ast_helper.(
@@ -6814,7 +6814,7 @@ and type_andops env sarg sands expected_ty =
68146814
(* Typing of toplevel bindings *)
68156815
68166816
let type_binding env rec_flag spat_sexp_list =
6817-
Typetexp.reset_type_variables();
6817+
Typetexp.TyVarEnv.reset ();
68186818
let (pat_exp_list, new_env, _unpacks) =
68196819
type_let
68206820
~check:(fun s -> Warnings.Unused_value_declaration s)
@@ -6832,7 +6832,7 @@ let type_let existential_ctx env rec_flag spat_sexp_list =
68326832
(* Typing of toplevel expressions *)
68336833
68346834
let type_expression env sexp =
6835-
Typetexp.reset_type_variables();
6835+
Typetexp.TyVarEnv.reset ();
68366836
begin_def();
68376837
let exp = type_exp env mode_global sexp in
68386838
end_def();

‎typing/typedecl.ml‎

Lines changed: 17 additions & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -237,7 +237,7 @@ let transl_labels env univars closed lbls =
237237
Builtin_attributes.warning_scope attrs
238238
(fun () ->
239239
let arg = Ast_helper.Typ.force_poly arg in
240-
let cty = transl_simple_type env ?univars closed Global arg in
240+
let cty = transl_simple_type env ?univars ~fixed:closed Global arg in
241241
let gbl =
242242
match mut with
243243
| Mutable -> Types.Global
@@ -268,7 +268,7 @@ let transl_labels env univars closed lbls =
268268

269269
let transl_types_gf env univars closed tyl =
270270
let mk arg =
271-
let cty = transl_simple_type env ?univars closed Global arg in
271+
let cty = transl_simple_type env ?univars ~fixed:closed Global arg in
272272
let gf = transl_global_flags arg.ptyp_loc arg.ptyp_attributes in
273273
(cty, gf)
274274
in
@@ -293,21 +293,21 @@ let make_constructor env loc type_path type_params svars sargs sret_type =
293293
transl_constructor_arguments env None true sargs
294294
in
295295
targs, None, args, None
296-
| Some sret_type -> narrow_in begin fun () ->
296+
| Some sret_type -> TyVarEnv.narrow_in begin fun () ->
297297
(* if it's a generalized constructor we must work in a narrowed
298298
context so as to not introduce any new constraints *)
299-
reset_type_variables ();
299+
TyVarEnv.reset ();
300300
let univars, closed =
301301
match svars with
302302
| [] -> None, false
303303
| vs ->
304304
Ctype.begin_def();
305-
Some (make_poly_univars (List.map (fun v -> v.txt) vs)), true
305+
Some (TyVarEnv.make_poly_univars (List.map (fun v -> v.txt) vs)), true
306306
in
307307
let args, targs =
308308
transl_constructor_arguments env univars closed sargs
309309
in
310-
let tret_type = transl_simple_type env ?univars closed Global sret_type in
310+
let tret_type = transl_simple_type env ?univars ~fixed:closed Global sret_type in
311311
let ret_type = tret_type.ctyp_type in
312312
(* TODO add back type_path as a parameter ? *)
313313
begin match get_desc ret_type with
@@ -341,14 +341,14 @@ let make_constructor env loc type_path type_params svars sargs sret_type =
341341

342342
let transl_declaration env sdecl (id, uid) =
343343
(* Bind type parameters *)
344-
reset_type_variables();
344+
TyVarEnv.reset ();
345345
Ctype.begin_def ();
346346
let tparams = make_params env sdecl.ptype_params in
347347
let params = List.map (fun (cty, _) -> cty.ctyp_type) tparams in
348348
let cstrs = List.map
349349
(fun (sty, sty', loc) ->
350-
transl_simple_type env false Global sty,
351-
transl_simple_type env false Global sty', loc)
350+
transl_simple_type env ~fixed:false Global sty,
351+
transl_simple_type env ~fixed:false Global sty', loc)
352352
sdecl.ptype_cstrs
353353
in
354354
let unboxed_attr = get_unboxed_from_attributes sdecl in
@@ -463,7 +463,7 @@ let transl_declaration env sdecl (id, uid) =
463463
None -> None, None
464464
| Some sty ->
465465
let no_row = not (is_fixed_type sdecl) in
466-
let cty = transl_simple_type env no_row Global sty in
466+
let cty = transl_simple_type env ~fixed:no_row Global sty in
467467
Some cty, Some cty.ctyp_type
468468
in
469469
let arity = List.length params in
@@ -1144,9 +1144,9 @@ let is_rebind ext =
11441144

11451145
let transl_type_extension extend env loc styext =
11461146
(* Note: it would be incorrect to call [create_scope] *after*
1147-
[reset_type_variables] or after [begin_def] (see #10010). *)
1147+
[TyVarEnv.reset] or after [begin_def] (see #10010). *)
11481148
let scope = Ctype.create_scope () in
1149-
reset_type_variables();
1149+
TyVarEnv.reset ();
11501150
Ctype.begin_def();
11511151
let type_path, type_decl =
11521152
let lid = styext.ptyext_path in
@@ -1255,7 +1255,7 @@ let transl_type_extension extend env loc styext =
12551255

12561256
let transl_exception env sext =
12571257
let scope = Ctype.create_scope () in
1258-
reset_type_variables();
1258+
TyVarEnv.reset ();
12591259
Ctype.begin_def();
12601260
let ext =
12611261
transl_extension_constructor ~scope env
@@ -1488,7 +1488,7 @@ let transl_value_decl env loc valdecl =
14881488
let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env
14891489
sdecl =
14901490
Env.mark_type_used sig_decl.type_uid;
1491-
reset_type_variables();
1491+
TyVarEnv.reset ();
14921492
Ctype.begin_def();
14931493
(* In the first part of this function, we typecheck the syntactic
14941494
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
14991499
let arity = List.length params in
15001500
let constraints =
15011501
List.map (fun (ty, ty', loc) ->
1502-
let cty = transl_simple_type env false Global ty in
1503-
let cty' = transl_simple_type env false Global ty' in
1502+
let cty = transl_simple_type env ~fixed:false Global ty in
1503+
let cty' = transl_simple_type env ~fixed:false Global ty' in
15041504
(* Note: We delay the unification of those constraints
15051505
after the unification of parameters, so that clashing
15061506
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
15121512
let (tman, man) = match sdecl.ptype_manifest with
15131513
None -> None, None
15141514
| Some sty ->
1515-
let cty = transl_simple_type env no_row Global sty in
1515+
let cty = transl_simple_type env ~fixed:no_row Global sty in
15161516
Some cty, Some cty.ctyp_type
15171517
in
15181518
(* In the second part, we check the consistency between the two

‎typing/typemod.ml‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -3037,7 +3037,7 @@ let type_package env m p fl =
30373037
(* Same as Pexp_letmodule *)
30383038
(* remember original level *)
30393039
Ctype.begin_def ();
3040-
let modl, scope = Typetexp.narrow_in begin fun () ->
3040+
let modl, scope = Typetexp.TyVarEnv.narrow_in begin fun () ->
30413041
let modl, _mod_shape = type_module env m in
30423042
let scope = Ctype.create_scope () in
30433043
modl, scope
@@ -3534,4 +3534,4 @@ let () =
35343534
let reset ~preserve_persistent_env =
35353535
Env.reset_cache ~preserve_persistent_env;
35363536
Envaux.reset_cache ~preserve_persistent_env;
3537-
Typetexp.reset_type_variables ()
3537+
Typetexp.TyVarEnv.reset ()

0 commit comments

Comments
 (0)