Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

#8702: fix some polymorphic variant error messages (#8777) 

improved error messages for fixed row polymorphic variants: keep track of the motivation behind a fixed row (e.g it was bound to an universal or existential type variable, or private) in the types themselves and use this explanation in error messages.
master
Florian Angeletti 2019-07-12 17:47:25 +02:00 committed by GitHub
parent e579129133
commit 6582335689
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
16 changed files with 264 additions and 78 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
Changes
View File

@ -86,6 +86,11 @@ Working version
(Stephen Dolan, review by Gabriel Scherer, Sébastien Hinderer and
Thomas Refis)
### Compiler user-interface and warnings:
- #8702, #8777: improved error messages for fixed row polymorphic variants
(Florian Angeletti, report by Leo White, review by Thomas Refis)
### Bug fixes:
- #8622: Don't generate #! headers over 127 characters.

3
testsuite/tests/typing-gadts/pr5689.ml
View File

@ -107,5 +107,6 @@ Error: This expression has type ([< inkind > `Nonlink ] as 'a) inline_t
but an expression was expected of type a inline_t
Type 'a = [< `Link | `Nonlink > `Nonlink ] is not compatible with type
a = [< `Link | `Nonlink ]
Types for tag `Nonlink are incompatible
The second variant type is bound to $'a,
it may not allow the tag(s) `Nonlink
|}];;

3
testsuite/tests/typing-gadts/pr6980.ml
View File

@ -26,5 +26,6 @@ Line 11, characters 27-29:
^^
Error: This expression has type [< `Bar | `Foo > `Bar ]
but an expression was expected of type [< `Bar | `Foo ]
Types for tag `Bar are incompatible
The second variant type is bound to $Aux,
it may not allow the tag(s) `Bar
|}];;

12
testsuite/tests/typing-misc/polyvars.ml
View File

@ -164,3 +164,15 @@ Error: This alias is bound to type [ `B ] but is used as an instance of type
[ `A ]
These two variant types have no intersection
|}]
type t = private [< `A]
let f: t -> [ `A ] = fun x -> x
[%%expect {|
type t = private [< `A ]
Line 2, characters 30-31:
2 | let f: t -> [ `A ] = fun x -> x
^
Error: This expression has type t but an expression was expected of type
[ `A ]
The first variant type is private, it may not allow the tag(s) `A
|}]

48
testsuite/tests/typing-poly/error_messages.ml
View File

@ -83,3 +83,51 @@ Error: This expression has type 'a v but an expression was expected of type
'a0. 'a0 -> int
The universal variable 'a0 would escape its scope
|}]
(* Issue #8702: row types unified with universally quantified types*)
let f: 'a. ([> `A ] as 'a) -> [ `A ] = fun x -> x
[%%expect {|
Line 1, characters 48-49:
1 | let f: 'a. ([> `A ] as 'a) -> [ `A ] = fun x -> x
^
Error: This expression has type [> `A ]
but an expression was expected of type [ `A ]
The first variant type is bound to the universal type variable 'a,
it cannot be closed
|}]
let f: 'a. [ `A ] -> ([> `A ] as 'a) = fun x -> x
[%%expect {|
Line 1, characters 48-49:
1 | let f: 'a. [ `A ] -> ([> `A ] as 'a) = fun x -> x
^
Error: This expression has type [ `A ] but an expression was expected of type
[> `A ]
The second variant type is bound to the universal type variable 'a,
it cannot be closed
|}]
let f: 'a. [ `A | `B ] -> ([> `A ] as 'a) = fun x -> x
[%%expect {|
Line 1, characters 53-54:
1 | let f: 'a. [ `A | `B ] -> ([> `A ] as 'a) = fun x -> x
^
Error: This expression has type [ `A | `B ]
but an expression was expected of type [> `A ]
The second variant type is bound to the universal type variable 'a,
it cannot be closed
|}]
let f: 'a. [> `A | `B | `C ] -> ([> `A ] as 'a) = fun x -> x
[%%expect {|
Line 1, characters 59-60:
1 | let f: 'a. [> `A | `B | `C ] -> ([> `A ] as 'a) = fun x -> x
^
Error: This expression has type [> `A | `B | `C ]
but an expression was expected of type [> `A ]
The second variant type is bound to the universal type variable 'a,
it may not allow the tag(s) `B, `C
|}]

3
testsuite/tests/typing-poly/poly.ml
View File

@ -1357,7 +1357,8 @@ Line 4, characters 16-22:
^^^^^^
Error: This expression has type [> `Int of int ]
but an expression was expected of type [< `Int of int ]
Types for tag `Int are incompatible
The second variant type is bound to the universal type variable 'a,
it may not allow the tag(s) `Int
|}];;
(* Yet another example *)

40
typing/btype.ml
View File

@ -167,13 +167,33 @@ let rec row_more row =
| {desc=Tvariant row'} -> row_more row'
| ty -> ty
let row_fixed row =
let merge_fixed_explanation fixed1 fixed2 =
match fixed1, fixed2 with
| Some Univar _ as x, _ | _, (Some Univar _ as x) -> x
| Some Fixed_private as x, _ | _, (Some Fixed_private as x) -> x
| Some Reified _ as x, _ | _, (Some Reified _ as x) -> x
| Some Rigid as x, _ | _, (Some Rigid as x) -> x
| None, None -> None
let fixed_explanation row =
let row = row_repr row in
row.row_fixed ||
match (repr row.row_more).desc with
Tvar _ | Tnil -> false
| Tunivar _ | Tconstr _ -> true
| _ -> assert false
match row.row_fixed with
| Some _ as x -> x
| None ->
let more = repr row.row_more in
match more.desc with
| Tvar _ | Tnil -> None
| Tunivar _ -> Some (Univar more)
| Tconstr (p,_,_) -> Some (Reified p)
| _ -> assert false
let is_fixed row = match row.row_fixed with
| None -> false
| Some _ -> true
let row_fixed row = fixed_explanation row <> None
let static_row row =
let row = row_repr row in
@ -427,16 +447,18 @@ let copy_row f fixed row keep more =
| Rpresent(Some ty) -> Rpresent(Some(f ty))
| Reither(c, tl, m, e) ->
let e = if keep then e else ref None in
let m = if row.row_fixed then fixed else m in
let m = if is_fixed row then fixed else m in
let tl = List.map f tl in
Reither(c, tl, m, e)
| _ -> fi)
row.row_fields in
let name =
match row.row_name with None -> None
match row.row_name with
| None -> None
| Some (path, tl) -> Some (path, List.map f tl) in
let row_fixed = if fixed then row.row_fixed else None in
{ row_fields = fields; row_more = more;
row_bound = (); row_fixed = row.row_fixed && fixed;
row_bound = (); row_fixed;
row_closed = row.row_closed; row_name = name; }
let rec copy_kind = function

17
typing/btype.mli
View File

@ -69,8 +69,23 @@ val row_field: label -> row_desc -> row_field
(* Return the canonical representative of a row field *)
val row_more: row_desc -> type_expr
(* Return the extension variable of the row *)
val is_fixed: row_desc -> bool
(* Return whether the row is directly marked as fixed or not *)
val row_fixed: row_desc -> bool
(* Return whether the row should be treated as fixed or not *)
(* Return whether the row should be treated as fixed or not.
In particular, [is_fixed row] implies [row_fixed row].
*)
val fixed_explanation: row_desc -> fixed_explanation option
(* Return the potential explanation for the fixed row *)
val merge_fixed_explanation:
fixed_explanation option -> fixed_explanation option
-> fixed_explanation option
(* Merge two explanations for a fixed row *)
val static_row: row_desc -> bool
(* Return whether the row is static or not *)
val hash_variant: label -> int

115
typing/ctype.ml
View File

@ -73,10 +73,16 @@ module Unification_trace = struct
| Module_type of Path.t
| Equation of 'a
type fixed_row_case =
| Cannot_be_closed
| Cannot_add_tags of string list
type variant =
| No_intersection
| No_tags of position * (Asttypes.label * row_field) list
| Incompatible_types_for of string
| Fixed_row of position * fixed_row_case * fixed_explanation
type obj =
| Missing_field of position * string
@ -124,6 +130,8 @@ module Unification_trace = struct
Incompatible_fields { name; diff = swap_diff diff}
| Obj (Missing_field(pos,s)) -> Obj(Missing_field(swap_position pos,s))
| Obj (Abstract_row pos) -> Obj(Abstract_row (swap_position pos))
| Variant (Fixed_row(pos,k,f)) -> Variant (Fixed_row(swap_position pos,k,f))
| Variant (No_tags(pos,f)) -> Variant (No_tags(swap_position pos,f))
| x -> x
let swap x = List.map swap_elt x
@ -1122,8 +1130,8 @@ let rec copy ?partial ?keep_names scope ty =
in
let row =
match repr more' with (* PR#6163 *)
{desc=Tconstr _} when not row.row_fixed ->
{row with row_fixed = true}
{desc=Tconstr (x,_,_)} when not (is_fixed row) ->
{row with row_fixed = Some (Reified x)}
| _ -> row
in
(* Open row if partial for pattern and contains Reither *)
@ -1140,13 +1148,13 @@ let rec copy ?partial ?keep_names scope ty =
Reither _ -> false
| _ -> true
in
if row.row_closed && not row.row_fixed
if row.row_closed && not (is_fixed row)
&& TypeSet.is_empty (free_univars ty)
&& not (List.for_all not_reither row.row_fields) then
(more',
{row_fields = List.filter not_reither row.row_fields;
row_more = more'; row_bound = ();
row_closed = false; row_fixed = false; row_name = None})
row_closed = false; row_fixed = None; row_name = None})
else (more', row)
| _ -> (more', row)
in
@ -2077,13 +2085,14 @@ let reify env t =
| Tvariant r ->
let r = row_repr r in
if not (static_row r) then begin
if r.row_fixed then iterator (row_more r) else
if is_fixed r then iterator (row_more r) else
let m = r.row_more in
match m.desc with
Tvar o ->
let path, t = create_fresh_constr m.level o in
let row =
{r with row_fields=[]; row_fixed=true; row_more = t} in
let row_fixed = Some (Reified path) in
{r with row_fields=[]; row_fixed; row_more = t} in
link_type m (newty2 m.level (Tvariant row));
if m.level < fresh_constr_scope then
raise Trace.(Unify [escape (Constructor path)])
@ -2806,12 +2815,13 @@ and unify_row env row1 row2 =
with Not_found -> ())
r2
end;
let fixed1 = row_fixed row1 and fixed2 = row_fixed row2 in
let more =
if fixed1 then rm1 else
if fixed2 then rm2 else
newty2 (min rm1.level rm2.level) (Tvar None) in
let fixed = fixed1 || fixed2
let fixed1 = fixed_explanation row1 and fixed2 = fixed_explanation row2 in
let more = match fixed1, fixed2 with
| Some _, _ -> rm1
| None, Some _ -> rm2
| None, None -> newty2 (min rm1.level rm2.level) (Tvar None)
in
let fixed = merge_fixed_explanation fixed1 fixed2
and closed = row1.row_closed || row2.row_closed in
let keep switch =
List.for_all
@ -2845,10 +2855,18 @@ and unify_row env row1 row2 =
if closed then
filter_row_fields row.row_closed rest
else rest in
if rest <> [] && (row.row_closed || row_fixed row)
|| closed && row_fixed row && not row.row_closed then begin
let pos = if row == row1 then Trace.First else Trace.Second in
raise Trace.(Unify [Variant (No_tags(pos,rest))])
begin match fixed_explanation row with
| None ->
if rest <> [] && row.row_closed then
let pos = if row == row1 then Trace.First else Trace.Second in
raise Trace.(Unify [Variant (No_tags(pos,rest))])
| Some fixed ->
let pos = if row == row1 then Trace.First else Trace.Second in
if closed && not row.row_closed then
raise Trace.(Unify [Variant(Fixed_row(pos,Cannot_be_closed,fixed))])
else if rest <> [] then
let case = Trace.Cannot_add_tags (List.map fst rest) in
raise Trace.(Unify [Variant(Fixed_row(pos,case,fixed))])
end;
(* The following test is not principal... should rather use Tnil *)
let rm = row_more row in
@ -2885,13 +2903,23 @@ and unify_row env row1 row2 =
and unify_row_field env fixed1 fixed2 more l f1 f2 =
let f1 = row_field_repr f1 and f2 = row_field_repr f2 in
let if_not_fixed (pos,fixed) f =
match fixed with
| None -> f ()
| Some fix ->
let tr = Trace.[ Variant (Fixed_row (pos,Cannot_add_tags [l],fix)) ] in
raise (Unify tr) in
let first = Trace.First, fixed1 and second = Trace.Second, fixed2 in
let either_fixed = match fixed1, fixed2 with
| None, None -> false
| _ -> true in
if f1 == f2 then () else
match f1, f2 with
Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2
| Rpresent None, Rpresent None -> ()
| Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) ->
if e1 == e2 then () else
if (fixed1 || fixed2) && not (c1 || c2)
if either_fixed && not (c1 || c2)
&& List.length tl1 = List.length tl2 then begin
(* PR#7496 *)
let f = Reither (c1 || c2, [], m1 || m2, ref None) in
@ -2900,7 +2928,7 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
end
else let redo =
not !passive_variants &&
(m1 || m2 || fixed1 || fixed2 ||
(m1 || m2 || either_fixed ||
!rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) &&
begin match tl1 @ tl2 with [] -> false
| t1 :: tl ->
@ -2939,27 +2967,33 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
let f1' = Reither(c1 || c2, tl1', m1 || m2, e)
and f2' = Reither(c1 || c2, tl2', m1 || m2, e) in
set_row_field e1 f1'; set_row_field e2 f2';
| Reither(_, _, false, e1), Rabsent when not fixed1 -> set_row_field e1 f2
| Rabsent, Reither(_, _, false, e2) when not fixed2 -> set_row_field e2 f1
| Reither(_, _, false, e1), Rabsent ->
if_not_fixed first (fun () -> set_row_field e1 f2)
| Rabsent, Reither(_, _, false, e2) ->
if_not_fixed second (fun () -> set_row_field e2 f1)
| Rabsent, Rabsent -> ()
| Reither(false, tl, _, e1), Rpresent(Some t2) when not fixed1 ->
set_row_field e1 f2;
let rm = repr more in
update_level !env rm.level t2;
update_scope rm.scope t2;
(try List.iter (fun t1 -> unify env t1 t2) tl
with exn -> e1 := None; raise exn)
| Rpresent(Some t1), Reither(false, tl, _, e2) when not fixed2 ->
set_row_field e2 f1;
let rm = repr more in
update_level !env rm.level t1;
update_scope rm.scope t1;
(try List.iter (unify env t1) tl
with exn -> e2 := None; raise exn)
| Reither(true, [], _, e1), Rpresent None when not fixed1 ->
set_row_field e1 f2
| Rpresent None, Reither(true, [], _, e2) when not fixed2 ->
set_row_field e2 f1
| Reither(false, tl, _, e1), Rpresent(Some t2) ->
if_not_fixed first (fun () ->
set_row_field e1 f2;
let rm = repr more in
update_level !env rm.level t2;
update_scope rm.scope t2;
(try List.iter (fun t1 -> unify env t1 t2) tl
with exn -> e1 := None; raise exn)
)
| Rpresent(Some t1), Reither(false, tl, _, e2) ->
if_not_fixed second (fun () ->
set_row_field e2 f1;
let rm = repr more in
update_level !env rm.level t1;
update_scope rm.scope t1;
(try List.iter (unify env t1) tl
with exn -> e2 := None; raise exn)
)
| Reither(true, [], _, e1), Rpresent None ->
if_not_fixed first (fun () -> set_row_field e1 f2)
| Rpresent None, Reither(true, [], _, e2) ->
if_not_fixed second (fun () -> set_row_field e2 f1)
| _ -> raise (Unify [])
@ -3348,7 +3382,8 @@ let rec rigidify_rec vars ty =
let more = repr row.row_more in
if is_Tvar more && not (row_fixed row) then begin
let more' = newty2 more.level more.desc in
let row' = {row with row_fixed=true; row_fields=[]; row_more=more'}
let row' =
{row with row_fixed=Some Rigid; row_fields=[]; row_more=more'}
in link_type more (newty2 ty.level (Tvariant row'))
end;
iter_row (rigidify_rec vars) row;
@ -4050,7 +4085,7 @@ let rec build_subtype env visited loops posi level t =
let c = collect fields in
let row =
{ row_fields = List.map fst fields; row_more = newvar();
row_bound = (); row_closed = posi; row_fixed = false;
row_bound = (); row_closed = posi; row_fixed = None;
row_name = if c > Unchanged then None else row.row_name }
in
(newty (Tvariant row), Changed)

7
typing/ctype.mli
View File

@ -37,10 +37,17 @@ module Unification_trace: sig
| Equation of 'a
(** Errors for polymorphic variants *)
type fixed_row_case =
| Cannot_be_closed
| Cannot_add_tags of string list
type variant =
| No_intersection
| No_tags of position * (Asttypes.label * row_field) list
| Incompatible_types_for of string
| Fixed_row of position * fixed_row_case * fixed_explanation
(** Fixed row types, e.g. ['a. [> `X] as 'a] *)
type obj =
| Missing_field of position * string

49
typing/printtyp.ml
View File

@ -472,14 +472,14 @@ and raw_type_desc ppf = function
raw_type_list tl
| Tvariant row ->
fprintf ppf
"@[<hov1>{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%B;@ @[<1>%s%t@]}@]"
"@[<hov1>{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%a;@ @[<1>%s%t@]}@]"
"row_fields="
(raw_list (fun ppf (l, f) ->
fprintf ppf "@[%s,@ %a@]" l raw_field f))
row.row_fields
"row_more=" raw_type row.row_more
"row_closed=" row.row_closed
"row_fixed=" row.row_fixed
"row_fixed=" raw_row_fixed row.row_fixed
"row_name="
(fun ppf ->
match row.row_name with None -> fprintf ppf "None"
@ -488,6 +488,12 @@ and raw_type_desc ppf = function
| Tpackage (p, _, tl) ->
fprintf ppf "@[<hov1>Tpackage(@,%a@,%a)@]" path p
raw_type_list tl
and raw_row_fixed ppf = function
| None -> fprintf ppf "None"
| Some Types.Fixed_private -> fprintf ppf "Some Fixed_private"
| Some Types.Rigid -> fprintf ppf "Some Rigid"
| Some Types.Univar t -> fprintf ppf "Some(Univar(%a))" raw_type t
| Some Types.Reified p -> fprintf ppf "Some(Reified(%a))" path p
and raw_field ppf = function
Rpresent None -> fprintf ppf "Rpresent None"
@ -1795,11 +1801,11 @@ let may_prepare_expansion compact (t, t') =
mark_loops t; (t, t)
| _ -> prepare_expansion (t, t')
let print_tags ppf fields =
match fields with [] -> ()
| (t, _) :: fields ->
fprintf ppf "`%s" t;
List.iter (fun (t, _) -> fprintf ppf ",@ `%s" t) fields
let print_tag ppf = fprintf ppf "`%s"
let print_tags =
let comma ppf () = Format.fprintf ppf ",@ " in
Format.pp_print_list ~pp_sep:comma print_tag
let is_unit env ty =
match (Ctype.expand_head env ty).desc with
@ -1835,6 +1841,24 @@ let print_pos ppf = function
| Trace.First -> fprintf ppf "first"
| Trace.Second -> fprintf ppf "second"
let explain_fixed_row_case ppf = function
| Trace.Cannot_be_closed -> Format.fprintf ppf "it cannot be closed"
| Trace.Cannot_add_tags tags ->
Format.fprintf ppf "it may not allow the tag(s) %a"
print_tags tags
let explain_fixed_row pos expl = match expl with
| Types.Fixed_private ->
dprintf "The %a variant type is private" print_pos pos
| Types.Univar x ->
dprintf "The %a variant type is bound to the universal type variable %a"
print_pos pos type_expr x
| Types.Reified p ->
let p = tree_of_path Type p in
dprintf "The %a variant type is bound to %a" print_pos pos
!Oprint.out_ident p
| Types.Rigid -> ignore
let explain_variant = function
| Trace.No_intersection ->
Some(dprintf "@,These two variant types have no intersection")
@ -1842,10 +1866,19 @@ let explain_variant = function
dprintf
"@,@[The %a variant type does not allow tag(s)@ @[<hov>%a@]@]"
print_pos pos
print_tags fields
print_tags (List.map fst fields)
)
| Trace.Incompatible_types_for s ->
Some(dprintf "@,Types for tag `%s are incompatible" s)
| Trace.Fixed_row (pos, k, (Univar _ | Reified _ | Fixed_private as e)) ->
Some (
dprintf "@,@[%t,@ %a@]" (explain_fixed_row pos e)
explain_fixed_row_case k
)
| Trace.Fixed_row (_,_, Rigid) ->
(* this case never happens *)
None
let explain_escape intro prev ctx e =
let pre = match ctx with

14
typing/typecore.ml
View File

@ -588,7 +588,7 @@ let rec build_as_type env p =
let ty = Option.map (build_as_type env) p' in
newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();
row_bound=(); row_name=None;
row_fixed=false; row_closed=false})
row_fixed=None; row_closed=false})
| Tpat_record (lpl,_) ->
let lbl = snd3 (List.hd lpl) in
if lbl.lbl_private = Private then p.pat_type else
@ -649,7 +649,7 @@ let build_or_pat env loc lid =
([],[]) (row_repr row0).row_fields in
let row =
{ row_fields = List.rev fields; row_more = newvar(); row_bound = ();
row_closed = false; row_fixed = false; row_name = Some (path, tyl) }
row_closed = false; row_fixed = None; row_name = Some (path, tyl) }
in
let ty = newty (Tvariant row) in
let gloc = {loc with Location.loc_ghost=true} in
@ -1385,7 +1385,7 @@ and type_pat_aux ~exception_allowed ~constrs ~labels ~no_existentials ~mode
row_bound = ();
row_closed = false;
row_more = newgenvar ();
row_fixed = false;
row_fixed = None;
row_name = None } in
begin_def ();
let expected_ty = instance expected_ty in
@ -2151,7 +2151,7 @@ let contains_variant_either ty =
match ty.desc with
Tvariant row ->
let row = row_repr row in
if not row.row_fixed then
if not (is_fixed row) then
List.iter
(fun (_,f) ->
match row_field_repr f with Reither _ -> raise Exit | _ -> ())
@ -2214,13 +2214,13 @@ let check_absent_variant env =
let row = row_repr !row in
if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent)
row.row_fields
|| not row.row_fixed && not (static_row row) (* same as Ctype.poly *)
|| not (is_fixed row) && not (static_row row) (* same as Ctype.poly *)
then () else
let ty_arg =
match arg with None -> [] | Some p -> [correct_levels p.pat_type] in
let row' = {row_fields = [s, Reither(arg=None,ty_arg,true,ref None)];
row_more = newvar (); row_bound = ();
row_closed = false; row_fixed = false; row_name = None} in
row_closed = false; row_fixed = None; row_name = None} in
(* Should fail *)
unify_pat env {pat with pat_type = newty (Tvariant row')}
(correct_levels pat.pat_type)
@ -2580,7 +2580,7 @@ and type_expect_
row_more = newvar ();
row_bound = ();
row_closed = false;
row_fixed = false;
row_fixed = None;
row_name = None});
exp_attributes = sexp.pexp_attributes;
exp_env = env }

2
typing/typedecl.ml
View File

@ -167,7 +167,7 @@ let set_fixed_row env loc p decl =
match tm.desc with
Tvariant row ->
let row = Btype.row_repr row in
tm.desc <- Tvariant {row with row_fixed = true};
tm.desc <- Tvariant {row with row_fixed = Some Fixed_private};
if Btype.static_row row then Btype.newgenty Tnil
else row.row_more
| Tobject (ty, _) ->

5
typing/types.ml
View File

@ -45,9 +45,10 @@ and row_desc =
row_more: type_expr;
row_bound: unit;
row_closed: bool;
row_fixed: bool;
row_fixed: fixed_explanation option;
row_name: (Path.t * type_expr list) option }
and fixed_explanation =
| Univar of type_expr | Fixed_private | Reified of Path.t | Rigid
and row_field =
Rpresent of type_expr option
| Reither of bool * type_expr list * bool * row_field option ref

8
typing/types.mli
View File

@ -160,9 +160,13 @@ and row_desc =
row_more: type_expr;
row_bound: unit; (* kept for compatibility *)
row_closed: bool;
row_fixed: bool;
row_fixed: fixed_explanation option;
row_name: (Path.t * type_expr list) option }
and fixed_explanation =
| Univar of type_expr (** The row type was bound to an univar *)
| Fixed_private (** The row type is private *)
| Reified of Path.t (** The row was reified *)
| Rigid (** The row type was made rigid during constraint verification *)
and row_field =
Rpresent of type_expr option
| Reither of bool * type_expr list * bool * row_field option ref

11
typing/typetexp.ml
View File

@ -478,7 +478,7 @@ and transl_type_aux env policy styp =
in
let row = { row_closed = true; row_fields = fields;
row_bound = (); row_name = Some (path, ty_args);
row_fixed = false; row_more = newvar () } in
row_fixed = None; row_more = newvar () } in
let static = Btype.static_row row in
let row =
if static then { row with row_more = newty Tnil }
@ -537,7 +537,7 @@ and transl_type_aux env policy styp =
let mkfield l f =
newty (Tvariant {row_fields=[l,f]; row_more=newvar();
row_bound=(); row_closed=true;
row_fixed=false; row_name=None}) in
row_fixed=None; row_name=None}) in
let hfields = Hashtbl.create 17 in
let add_typed_field loc l f =
let h = Btype.hash_variant l in
@ -634,7 +634,7 @@ and transl_type_aux env policy styp =
let row =
{ row_fields = List.rev fields; row_more = newvar ();
row_bound = (); row_closed = (closed = Closed);
row_fixed = false; row_name = !name } in
row_fixed = None; row_name = !name } in
let static = Btype.static_row row in
let row =
if static then { row with row_more = newty Tnil }
@ -767,9 +767,10 @@ let rec make_fixed_univars ty =
match ty.desc with
| Tvariant row ->
let row = Btype.row_repr row in
if Btype.is_Tunivar (Btype.row_more row) then
let more = Btype.row_more row in
if Btype.is_Tunivar more then
ty.desc <- Tvariant
{row with row_fixed=true;
{row with row_fixed=Some(Univar more);
row_fields = List.map
(fun (s,f as p) -> match Btype.row_field_repr f with
Reither (c, tl, _m, r) -> s, Reither (c, tl, true, r)