summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--testsuite/tests/typing-modules-bugs/pr6899_second_bad.compilers.reference2
-rw-r--r--testsuite/tests/typing-objects/Exemples.ml2
-rw-r--r--testsuite/tests/typing-objects/Tests.ml2
-rw-r--r--testsuite/tests/typing-objects/dummy.ml2
-rw-r--r--testsuite/tests/typing-objects/errors.ml2
-rw-r--r--testsuite/tests/typing-polyvariants-bugs/pr10664a.ml2
-rw-r--r--testsuite/tests/typing-polyvariants-bugs/pr7817_bad.ml13
-rw-r--r--typing/oprint.ml20
-rw-r--r--typing/outcometree.mli2
-rw-r--r--typing/printtyp.ml57
10 files changed, 67 insertions, 37 deletions
diff --git a/testsuite/tests/typing-modules-bugs/pr6899_second_bad.compilers.reference b/testsuite/tests/typing-modules-bugs/pr6899_second_bad.compilers.reference
index 66950a172c..7646edba86 100644
--- a/testsuite/tests/typing-modules-bugs/pr6899_second_bad.compilers.reference
+++ b/testsuite/tests/typing-modules-bugs/pr6899_second_bad.compilers.reference
@@ -1,5 +1,5 @@
File "pr6899_second_bad.ml", line 12, characters 6-9:
12 | let bar = wrap ()
^^^
-Error: The type of this expression, _[< `Test ] -> unit,
+Error: The type of this expression, ([< `Test ] as '_weak1) -> unit,
contains type variables that cannot be generalized
diff --git a/testsuite/tests/typing-objects/Exemples.ml b/testsuite/tests/typing-objects/Exemples.ml
index 067b8f8f0b..3ab4072c14 100644
--- a/testsuite/tests/typing-objects/Exemples.ml
+++ b/testsuite/tests/typing-objects/Exemples.ml
@@ -517,7 +517,7 @@ class ['a] sorted_list :
let l = new sorted_list ();;
[%%expect{|
-val l : _#comparable sorted_list = <obj>
+val l : (#comparable as '_weak1) sorted_list = <obj>
|}];;
let c = new int_comparable 10;;
[%%expect{|
diff --git a/testsuite/tests/typing-objects/Tests.ml b/testsuite/tests/typing-objects/Tests.ml
index cc7ae24aad..5ca2804f44 100644
--- a/testsuite/tests/typing-objects/Tests.ml
+++ b/testsuite/tests/typing-objects/Tests.ml
@@ -950,7 +950,7 @@ end;;
Line 2, characters 13-58:
2 | method o = object(_ : 'self) method o = assert false end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Error: Cannot close type of object literal: < o : '_weak3; _.. >
+Error: Cannot close type of object literal: < o : '_weak4; .. > as '_weak3
it has been unified with the self type of a class that is not yet
completely defined.
|}];;
diff --git a/testsuite/tests/typing-objects/dummy.ml b/testsuite/tests/typing-objects/dummy.ml
index f2b797d25b..de8b18822a 100644
--- a/testsuite/tests/typing-objects/dummy.ml
+++ b/testsuite/tests/typing-objects/dummy.ml
@@ -169,7 +169,7 @@ Lines 4-10, characters 4-7:
9 | method child = assert false
10 | end
Error: Cannot close type of object literal:
- < child : '_weak1; previous : 'a option; _.. > as 'a
+ < child : '_weak2; previous : '_weak1 option; .. > as '_weak1
it has been unified with the self type of a class that is not yet
completely defined.
|}]
diff --git a/testsuite/tests/typing-objects/errors.ml b/testsuite/tests/typing-objects/errors.ml
index 7b13b58882..236f7e1d5b 100644
--- a/testsuite/tests/typing-objects/errors.ml
+++ b/testsuite/tests/typing-objects/errors.ml
@@ -9,7 +9,7 @@ Line 1, characters 0-75:
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: The type of this class,
class virtual ['a] c :
- object constraint 'a = _[< `A of int & float ] end,
+ object constraint '_a = [< `A of int & float ] as '_weak1 end,
contains non-collapsible conjunctive types in constraints.
Type int is not compatible with type float
|}]
diff --git a/testsuite/tests/typing-polyvariants-bugs/pr10664a.ml b/testsuite/tests/typing-polyvariants-bugs/pr10664a.ml
index 27ab01f00c..7993e10a40 100644
--- a/testsuite/tests/typing-polyvariants-bugs/pr10664a.ml
+++ b/testsuite/tests/typing-polyvariants-bugs/pr10664a.ml
@@ -110,7 +110,7 @@ let y = g o;;
[%%expect{|
val o : < m : 'a 'c. < n : ([< `A of 'a ] as 'c) -> 'b > > as 'b = <obj>
val y :
- < n : _[< `A of '_weak2 ] ->
+ < n : ([< `A of '_weak3 ] as '_weak2) ->
(< m : 'a 'c. < n : ([< `A of 'a ] as 'c) -> 'b > > as 'b) > =
<obj>
|}]
diff --git a/testsuite/tests/typing-polyvariants-bugs/pr7817_bad.ml b/testsuite/tests/typing-polyvariants-bugs/pr7817_bad.ml
index fc9cf7fbda..999420fd2b 100644
--- a/testsuite/tests/typing-polyvariants-bugs/pr7817_bad.ml
+++ b/testsuite/tests/typing-polyvariants-bugs/pr7817_bad.ml
@@ -19,15 +19,18 @@ Lines 5-8, characters 6-3:
8 | end
Error: Signature mismatch:
Modules do not match:
- sig val write : _[< `A of '_weak2 | `B of '_weak3 ] -> unit end
+ sig
+ val write :
+ ([< `A of '_weak3 | `B of '_weak4 ] as '_weak2) -> unit
+ end
is not included in
sig val write : [< `A of string | `B of int ] -> unit end
Values do not match:
- val write : _[< `A of '_weak2 | `B of '_weak3 ] -> unit
+ val write : ([< `A of '_weak3 | `B of '_weak4 ] as '_weak2) -> unit
is not included in
val write : [< `A of string | `B of int ] -> unit
- The type _[< `A of '_weak2 | `B of '_weak3 ] -> unit
+ The type ([< `A of '_weak3 | `B of '_weak4 ] as '_weak2) -> unit
is not compatible with the type [< `A of string | `B of int ] -> unit
- Type _[< `A of '_weak2 | `B of '_weak3 ] is not compatible with type
- [< `A of string | `B of int ]
+ Type [< `A of '_weak3 | `B of '_weak4 ] as '_weak2
+ is not compatible with type [< `A of string | `B of int ]
|}]
diff --git a/typing/oprint.ml b/typing/oprint.ml
index c31da7d944..a12e058597 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -255,14 +255,28 @@ let pr_present =
print_list (fun ppf s -> fprintf ppf "`%s" s) (fun ppf -> fprintf ppf "@ ")
let pr_var = Pprintast.tyvar
+let ty_var ~non_gen ppf s =
+ pr_var ppf (if non_gen then "_" ^ s else s)
let pr_vars =
print_list pr_var (fun ppf -> fprintf ppf "@ ")
let rec print_out_type ppf =
function
- | Otyp_alias (ty, s) ->
- fprintf ppf "@[%a@ as %a@]" print_out_type ty pr_var s
+ (* If we have an alias to carry the information that a row variable is weakly
+ polymorphic, we don't need to add "_" prefix to the variant, open class,
+ or object types *)
+ | Otyp_alias {non_gen=true; aliased=Otyp_variant(true,x,y,z); alias} ->
+ let ty = Otyp_variant(false,x,y,z) in
+ fprintf ppf "@[%a@ as %a@]" print_out_type ty (ty_var ~non_gen:true) alias
+ | Otyp_alias {non_gen=true; aliased=Otyp_object(fields,Some true); alias} ->
+ let ty = Otyp_object(fields,Some false) in
+ fprintf ppf "@[%a@ as %a@]" print_out_type ty (ty_var ~non_gen:true) alias
+ | Otyp_alias {non_gen=true; aliased=Otyp_class(true, ty, params); alias} ->
+ let ty = Otyp_class(false,ty, params) in
+ fprintf ppf "@[%a@ as %a@]" print_out_type ty (ty_var ~non_gen:true) alias
+ | Otyp_alias {non_gen; aliased; alias } ->
+ fprintf ppf "@[%a@ as %a@]" print_out_type aliased (ty_var ~non_gen) alias
| Otyp_poly (sl, ty) ->
fprintf ppf "@[<hov 2>%a.@ %a@]"
pr_vars sl
@@ -299,7 +313,7 @@ and print_simple_out_type ppf =
| Otyp_object (fields, rest) ->
fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
| Otyp_stuff s -> pp_print_string ppf s
- | Otyp_var (ng, s) -> pr_var ppf (if ng then "_" ^ s else s)
+ | Otyp_var (non_gen, s) -> ty_var ~non_gen ppf s
| Otyp_variant (non_gen, row_fields, closed, tags) ->
let print_present ppf =
function
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index 8e8dfcac3e..60fb15fcc1 100644
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -61,7 +61,7 @@ type out_type_param = string * (Asttypes.variance * Asttypes.injectivity)
type out_type =
| Otyp_abstract
| Otyp_open
- | Otyp_alias of out_type * string
+ | Otyp_alias of {non_gen:bool; aliased:out_type; alias:string}
| Otyp_arrow of string * out_type * out_type
| Otyp_class of bool * out_ident * out_type list
| Otyp_constr of out_ident * out_type list
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 7b72e39edb..1b086609e4 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -836,10 +836,10 @@ module Names : sig
val add_subst : (type_expr * type_expr) list -> unit
val new_name : unit -> string
- val new_weak_name : type_expr -> unit -> string
+ val new_var_name : non_gen:bool -> type_expr -> unit -> string
val name_of_type : (unit -> string) -> transient_expr -> string
- val check_name_of_type : transient_expr -> unit
+ val check_name_of_type : non_gen:bool -> transient_expr -> unit
val remove_names : transient_expr list -> unit
@@ -924,6 +924,10 @@ end = struct
name
end
+ let new_var_name ~non_gen ty () =
+ if non_gen then new_weak_name ty ()
+ else new_name ()
+
let name_of_type name_generator t =
(* We've already been through repr at this stage, so t is our representative
of the union-find class. *)
@@ -954,7 +958,9 @@ end = struct
if name <> "_" then names := (t, name) :: !names;
name
- let check_name_of_type t = ignore(name_of_type new_name t)
+ let check_name_of_type ~non_gen px =
+ let name_gen = new_var_name ~non_gen (Transient_expr.type_expr px) in
+ ignore(name_of_type name_gen px)
let remove_names tyl =
let tyl = List.map substitute tyl in
@@ -1009,8 +1015,8 @@ let add_alias_proxy px =
let add_alias ty = add_alias_proxy (proxy ty)
-let add_printed_alias_proxy px =
- Names.check_name_of_type px;
+let add_printed_alias_proxy ~non_gen px =
+ Names.check_name_of_type ~non_gen px;
printed_aliases := px :: !printed_aliases
let add_printed_alias ty = add_printed_alias_proxy (proxy ty)
@@ -1072,24 +1078,26 @@ let add_type_to_preparation = prepare_type
(* Disabled in classic mode when printing an unification error *)
let print_labels = ref true
+let alias_nongen_row mode px ty =
+ match get_desc ty with
+ | Tvariant _ | Tobject _ ->
+ if is_non_gen mode (Transient_expr.type_expr px) then
+ add_alias_proxy px
+ | _ -> ()
+
let rec tree_of_typexp mode ty =
let px = proxy ty in
if List.memq px !printed_aliases && not (List.memq px !delayed) then
- let mark = is_non_gen mode ty in
- let name = Names.name_of_type
- (if mark then Names.new_weak_name ty else Names.new_name)
- px
- in
- Otyp_var (mark, name) else
+ let non_gen = is_non_gen mode (Transient_expr.type_expr px) in
+ let name = Names.name_of_type (Names.new_var_name ~non_gen ty) px in
+ Otyp_var (non_gen, name) else
let pr_typ () =
let tty = Transient_expr.repr ty in
match tty.desc with
| Tvar _ ->
let non_gen = is_non_gen mode ty in
- let name_gen =
- if non_gen then Names.new_weak_name ty else Names.new_name
- in
+ let name_gen = Names.new_var_name ~non_gen ty in
Otyp_var (non_gen, Names.name_of_type name_gen tty)
| Tarrow(l, ty1, ty2, _) ->
let lab =
@@ -1191,9 +1199,14 @@ let rec tree_of_typexp mode ty =
Otyp_module (tree_of_path (Some Module_type) p, fl)
in
if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed;
+ alias_nongen_row mode px ty;
if is_aliased_proxy px && aliasable ty then begin
- add_printed_alias_proxy px;
- Otyp_alias (pr_typ (), Names.name_of_type Names.new_name px) end
+ let non_gen = is_non_gen mode (Transient_expr.type_expr px) in
+ add_printed_alias_proxy ~non_gen px;
+ (* add_printed_alias chose a name, thus the name generator
+ doesn't matter.*)
+ let alias = Names.name_of_type (Names.new_var_name ~non_gen ty) px in
+ Otyp_alias {non_gen; aliased = pr_typ (); alias } end
else pr_typ ()
and tree_of_row_field mode (l, f) =
@@ -1362,7 +1375,7 @@ let prepare_decl id decl =
end;
List.iter add_alias params;
List.iter prepare_type params;
- List.iter add_printed_alias params;
+ List.iter (add_printed_alias ~non_gen:false) params;
let ty_manifest =
match decl.type_manifest with
| None -> None
@@ -1578,7 +1591,7 @@ let prepared_tree_of_extension_constructor
let ty_params =
param_scope
(fun () ->
- List.iter add_printed_alias ty_params;
+ List.iter (add_printed_alias ~non_gen:false) ty_params;
List.map (fun ty -> type_param (tree_of_typexp Type ty)) ty_params
)
in
@@ -1783,8 +1796,8 @@ let tree_of_class_declaration id cl rs =
let px = proxy (Btype.self_type_row cl.cty_type) in
List.iter prepare_type params;
- List.iter add_printed_alias params;
- if is_aliased_proxy px then add_printed_alias_proxy px;
+ List.iter (add_printed_alias ~non_gen:false) params;
+ if is_aliased_proxy px then add_printed_alias_proxy ~non_gen:false px;
let vir_flag = cl.cty_new = None in
Osig_class
@@ -1805,8 +1818,8 @@ let tree_of_cltype_declaration id cl rs =
let px = proxy (Btype.self_type_row cl.clty_type) in
List.iter prepare_type params;
- List.iter add_printed_alias params;
- if is_aliased_proxy px then add_printed_alias_proxy px;
+ List.iter (add_printed_alias ~non_gen:false) params;
+ if is_aliased_proxy px then (add_printed_alias_proxy ~non_gen:false) px;
let sign = Btype.signature_of_class_type cl.clty_type in
let has_virtual_vars =
View Lorry Controller Status