summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--typing/btype.ml17
-rw-r--r--typing/btype.mli4
-rw-r--r--typing/ctype.ml114
-rw-r--r--typing/ctype.mli4
-rw-r--r--typing/env.ml4
-rw-r--r--typing/includecore.ml3
-rw-r--r--typing/mtype.ml4
-rw-r--r--typing/parmatch.ml2
-rw-r--r--typing/predef.ml26
-rw-r--r--typing/printtyp.ml41
-rw-r--r--typing/subst.ml8
-rw-r--r--typing/typeclass.ml16
-rw-r--r--typing/typecore.ml17
-rw-r--r--typing/typedecl.ml107
-rw-r--r--typing/types.ml4
-rw-r--r--typing/types.mli4
-rw-r--r--typing/typetexp.ml23
17 files changed, 259 insertions, 139 deletions
diff --git a/typing/btype.ml b/typing/btype.ml
index e7de2a5e29..a6ea4dc48e 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -33,6 +33,8 @@ let newty2 level desc =
incr new_id; { desc = desc; level = level; id = !new_id }
let newgenty desc = newty2 generic_level desc
let newgenvar () = newgenty Tvar
+let newgenconstr path args arity =
+ newgenty (Tconstr(path, args, arity, ref Mnil))
(*
let newmarkedvar level =
incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id }
@@ -99,6 +101,15 @@ let hash_variant s =
(* make it signed for 64 bits architectures *)
if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
+let filter_bound l =
+ let rec filter bound = function
+ [] -> bound
+ | ty :: rem ->
+ let ty = repr ty in
+ if List.memq ty bound then filter bound rem
+ else filter (ty::bound) rem
+ in filter [] l
+
(**********************************)
(* Utilities for type traversal *)
@@ -124,9 +135,9 @@ let iter_type_expr f ty =
Tvar -> ()
| Tarrow (_, ty1, ty2, _) -> f ty1; f ty2
| Ttuple l -> List.iter f l
- | Tconstr (_, l, _) -> List.iter f l
- | Tobject(ty, {contents = Some (_, p)})
- -> f ty; List.iter f p
+ | Tconstr (_, l, _, _)-> List.iter f l
+ | Tobject(ty, {contents = Some (_, tl, _)})
+ -> f ty; List.iter f tl
| Tobject (ty, _) -> f ty
| Tvariant row -> iter_row f row; f (row_more row)
| Tfield (_, _, ty1, ty2) -> f ty1; f ty2
diff --git a/typing/btype.mli b/typing/btype.mli
index f831b39906..565d57694a 100644
--- a/typing/btype.mli
+++ b/typing/btype.mli
@@ -25,6 +25,8 @@ val newgenty: type_desc -> type_expr
(* Create a generic type *)
val newgenvar: unit -> type_expr
(* Return a fresh generic variable *)
+val newgenconstr: Path.t -> type_expr list -> int -> type_expr
+ (* Return a generic constructor *)
(* Use Tsubst instead
val newmarkedvar: int -> type_expr
@@ -53,6 +55,8 @@ val static_row: row_desc -> bool
(* Return whether the row is static or not *)
val hash_variant: label -> int
(* Hash function for variant tags *)
+val filter_bound: type_expr list -> type_expr list
+ (* Filter out (some) useless extra bound variables *)
(**** Utilities for type traversal ****)
diff --git a/typing/ctype.ml b/typing/ctype.ml
index fc4472febc..6f18814063 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -143,7 +143,8 @@ let new_global_var () = newty2 !global_level Tvar
let newobj fields = newty (Tobject (fields, ref None))
-let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil))
+let newconstr path tyl arity =
+ newty (Tconstr (path, tyl, arity, ref Mnil))
let none = newty (Ttuple []) (* Clearly ill-formed type *)
@@ -246,11 +247,11 @@ let row_variable ty =
(**** Object name manipulation ****)
(* +++ Bientot obsolete *)
-let set_object_name id rv params ty =
+let set_object_name id rv params ar ty =
match (repr ty).desc with
Tobject (fi, nm) ->
begin try
- nm := Some (Path.Pident id, rv::params)
+ nm := Some (Path.Pident id, rv::params, ar)
with Not_found ->
()
end
@@ -260,7 +261,7 @@ let set_object_name id rv params ty =
let remove_object_name ty =
match (repr ty).desc with
Tobject (_, nm) -> nm := None
- | Tconstr (_, _, _) -> ()
+ | Tconstr _ -> ()
| _ -> fatal_error "Ctype.remove_object_name"
(**** Hiding of private methods ****)
@@ -496,7 +497,7 @@ let rec iter_generalize tyl ty =
if (ty.level > !current_level) && (ty.level <> generic_level) then begin
ty.level <- generic_level;
begin match ty.desc with
- Tconstr (_, _, abbrev) ->
+ Tconstr (_, _, _, abbrev) ->
generalize_expans tyl !abbrev
| _ -> ()
end;
@@ -541,7 +542,7 @@ let rec update_level env level ty =
let ty = repr ty in
if ty.level > level then begin
begin match ty.desc with
- Tconstr(p, tl, abbrev) when level < Path.binding_time p ->
+ Tconstr(p, tl, _, abbrev) when level < Path.binding_time p ->
(* Try first to replace an abbreviation by its expansion. *)
begin try
ty.desc <- Tlink (!try_expand_head' env ty);
@@ -669,7 +670,7 @@ let rec copy ty =
Tarrow (l, copy t1, copy t2, c)
| Ttuple tl ->
Ttuple (List.map copy tl)
- | Tconstr (p, tl, _) ->
+ | Tconstr (p, tl, ar, _) ->
begin match find_repr p !(!abbreviations) with
Some ty when repr ty != t -> (* XXX Commentaire... *)
Tlink ty
@@ -683,7 +684,7 @@ let rec copy ty =
ation can be released by changing the content of just
one reference.
*)
- Tconstr (p, List.map copy tl,
+ Tconstr (p, List.map copy tl, ar,
ref (match !(!abbreviations) with
Mcons _ -> Mlink !abbreviations
| abbrev -> abbrev))
@@ -693,8 +694,8 @@ let rec copy ty =
match name with
None ->
None
- | Some (p, tl) ->
- Some (p, List.map copy tl)
+ | Some (p, tl, ar) ->
+ Some (p, List.map copy tl, ar)
in
Tobject (copy t1, ref name')
| Tvariant row0 ->
@@ -817,7 +818,7 @@ let rec subst env level abbrev ty params args body =
let body0 = newvar () in (* Stub *)
begin match ty with
None -> ()
- | Some ({desc = Tconstr (path, _, _)} as ty) ->
+ | Some ({desc = Tconstr (path, _, _, _)} as ty) ->
memorize_abbrev abbrev path ty body0
| _ ->
assert false
@@ -829,7 +830,7 @@ let rec subst env level abbrev ty params args body =
List.iter2 (!unify' env) params' args;
current_level := old_level;
body'
- with Unify _ as exn ->
+ with exn ->
current_level := old_level;
raise exn
@@ -901,7 +902,7 @@ let expand_abbrev env ty =
previous_env := env
end;
match ty with
- {desc = Tconstr (path, args, abbrev); level = level} ->
+ {desc = Tconstr (path, args, ar, abbrev); level = level} ->
begin match find_expans path !abbrev with
Some ty ->
if level <> generic_level then
@@ -956,7 +957,7 @@ let rec expand_head env ty =
respect the type constraints *)
let enforce_constraints env ty =
match ty with
- {desc = Tconstr (path, args, abbrev); level = level} ->
+ {desc = Tconstr (path, args, ar, abbrev); level = level} ->
let decl = Env.find_type path env in
ignore
(subst env level (ref Mnil) None decl.type_params args (newvar2 level))
@@ -968,7 +969,7 @@ let enforce_constraints env ty =
let rec full_expand env ty =
let ty = repr (expand_head env ty) in
match ty.desc with
- Tobject (fi, {contents = Some (_, v::_)}) when (repr v).desc = Tvar ->
+ Tobject (fi, {contents = Some (_, v::_, _)}) when (repr v).desc = Tvar ->
newty2 ty.level (Tobject (fi, ref None))
| _ ->
ty
@@ -1004,7 +1005,7 @@ let rec non_recursive_abbrev env ty0 ty =
let level = ty.level in
visited := ty :: !visited;
match ty.desc with
- Tconstr(p, args, abbrev) ->
+ Tconstr(p, args, ar, abbrev) ->
begin try
non_recursive_abbrev env ty0 (try_expand_head env ty)
with Cannot_expand ->
@@ -1030,7 +1031,7 @@ let correct_abbrev env ident params ty =
let rec occur_rec env visited ty0 ty =
if ty == ty0 then raise Occur;
match ty.desc with
- Tconstr(p, tl, abbrev) ->
+ Tconstr(p, tl, ar, abbrev) ->
begin try
if List.memq ty visited then raise Occur;
iter_type_expr (occur_rec env (ty::visited) ty0) ty
@@ -1138,8 +1139,7 @@ let rec unify env t1 t2 =
occur env t2 t1;
update_level env t2.level t1;
t2.desc <- Tlink t1
- | (Tconstr (p1, [], a1), Tconstr (p2, [], a2))
- when Path.same p1 p2
+ | (Tconstr (p1, [], _, a1), Tconstr (p2, [], _, a2)) when Path.same p1 p2
(* This optimization assumes that t1 does not expand to t2
(and conversely), so we fall back to the general case
when any of the types has a cached expansion. *)
@@ -1204,14 +1204,15 @@ and unify3 env t1 t1' t2 t2' =
end
| (Ttuple tl1, Ttuple tl2) ->
unify_list env tl1 tl2
- | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 ->
+ | (Tconstr (p1, tl1, _, _), Tconstr (p2, tl2, _, _))
+ when Path.same p1 p2 ->
unify_list env tl1 tl2
| (Tobject (fi1, nm1), Tobject (fi2, _)) ->
unify_fields env fi1 fi2;
(* Type [t2'] may have been instantiated by [unify_fields] *)
(* XXX One should do some kind of unification... *)
begin match (repr t2').desc with
- Tobject (_, {contents = Some (_, va::_)})
+ Tobject (_, {contents = Some (_, va::_, _)})
when (repr va).desc = Tvar ->
()
| Tobject (_, nm2) ->
@@ -1232,7 +1233,7 @@ and unify3 env t1 t1' t2 t2' =
(* XXX Commentaires + changer "create_recursion" *)
if create_recursion then begin
match t2.desc with
- Tconstr (p, tl, abbrev) ->
+ Tconstr (p, tl, ar, abbrev) ->
forget_abbrev abbrev p;
let t2'' = expand_head env t2 in
if not (closed_parameterized_type tl t2'') then
@@ -1248,13 +1249,13 @@ and unify3 env t1 t1' t2 t2' =
*)
if t1 != t1' (* && t2 != t2' *) then begin
match (t1.desc, t2.desc) with
- (Tconstr (p, ty::_, _), _)
+ (Tconstr (p, ty::_, _, _), _)
when ((repr ty).desc <> Tvar)
&& weak_abbrev p
&& not (deep_occur t1 t2) ->
update_level env t1.level t2;
t1.desc <- Tlink t2
- | (_, Tconstr (p, ty::_, _))
+ | (_, Tconstr (p, ty::_, _, _))
when ((repr ty).desc <> Tvar)
&& weak_abbrev p
&& not (deep_occur t2 t1) ->
@@ -1330,7 +1331,7 @@ and unify_row env row1 row2 =
then row2.row_name
else None
in
- let bound = row1.row_bound @ row2.row_bound in
+ let bound = filter_bound (row1.row_bound @ row2.row_bound) in
let row0 = {row_fields = []; row_more = more; row_bound = bound;
row_closed = closed; row_name = name} in
let more row rest =
@@ -1519,7 +1520,7 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
moregen_occur env t1.level t2;
occur env t1 t2;
t1.desc <- Tlink t2
- | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+ | (Tconstr (p1, [], _, _), Tconstr (p2, [], _, _)) when Path.same p1 p2 ->
()
| _ ->
let t1' = expand_head env t1 in
@@ -1542,8 +1543,8 @@ let rec moregen inst_nongen type_pairs env t1 t2 =
moregen inst_nongen type_pairs env u1 u2
| (Ttuple tl1, Ttuple tl2) ->
moregen_list inst_nongen type_pairs env tl1 tl2
- | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
- when Path.same p1 p2 ->
+ | (Tconstr (p1, tl1, _, _), Tconstr (p2, tl2, _, _))
+ when Path.same p1 p2 ->
moregen_list inst_nongen type_pairs env tl1 tl2
| (Tvariant row1, Tvariant row2) ->
moregen_row inst_nongen type_pairs env row1 row2
@@ -1687,7 +1688,7 @@ let rec eqtype rename type_pairs subst env t1 t2 =
with Not_found ->
subst := (t1, t2) :: !subst
end
- | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 ->
+ | (Tconstr (p1, [], _, _), Tconstr (p2, [], _, _)) when Path.same p1 p2 ->
()
| _ ->
let t1' = expand_head env t1 in
@@ -1712,8 +1713,8 @@ let rec eqtype rename type_pairs subst env t1 t2 =
eqtype rename type_pairs subst env u1 u2;
| (Ttuple tl1, Ttuple tl2) ->
eqtype_list rename type_pairs subst env tl1 tl2
- | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _))
- when Path.same p1 p2 ->
+ | (Tconstr (p1, tl1, _, _), Tconstr (p2, tl2, _, _))
+ when Path.same p1 p2 ->
eqtype_list rename type_pairs subst env tl1 tl2
| (Tvariant row1, Tvariant row2) ->
eqtype_row rename type_pairs subst env row1 row2
@@ -2107,7 +2108,7 @@ let rec build_subtype env visited posi t =
if List.exists snd tlist' then
(newty (Ttuple (List.map fst tlist')), true)
else (t, false)
- | Tconstr(p, tl, abbrev) when generic_abbrev env p ->
+ | Tconstr(p, tl, ar, abbrev) when generic_abbrev env p ->
let t' = repr (expand_abbrev env t) in
let (t'', c) =
try match t'.desc with
@@ -2133,7 +2134,7 @@ let rec build_subtype env visited posi t =
let ty = repr ty in
let ty1 =
match ty.desc with
- Tobject(ty1,{contents=Some(p',_)}) ->
+ Tobject(ty1,{contents=Some(p',_,_)}) ->
if Path.same p p' then ty1 else raise Not_found
| _ -> assert false in
ty.desc <- Tvar;
@@ -2149,7 +2150,7 @@ let rec build_subtype env visited posi t =
with Not_found -> build_subtype env visited posi t'
in
if c then (t'', true) else (t, false)
- | Tconstr(p, tl, abbrev) ->
+ | Tconstr(p, tl, ar, abbrev) ->
let decl = Env.find_type p env in
let tl' =
List.map2
@@ -2163,7 +2164,9 @@ let rec build_subtype env visited posi t =
decl.type_variance tl
in
if List.exists snd tl' then
- (newconstr p (List.map fst tl'), true)
+ let t' = newconstr p (List.map fst tl') ar in
+ enforce_constraints env t';
+ (t', true)
else
(t, false)
| Tvariant row ->
@@ -2274,13 +2277,13 @@ let rec subtype_rec env trace t1 t2 cstrs =
subtype_rec env ((u1, u2)::trace) u1 u2 cstrs
| (Ttuple tl1, Ttuple tl2) ->
subtype_list env trace tl1 tl2 cstrs
- | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 ->
+ | (Tconstr(p1, [], _, _), Tconstr(p2, [], _, _)) when Path.same p1 p2 ->
cstrs
- | (Tconstr(p1, tl1, abbrev1), _) when generic_abbrev env p1 ->
+ | (Tconstr(p1, tl1, _, abbrev1), _) when generic_abbrev env p1 ->
subtype_rec env trace (expand_abbrev env t1) t2 cstrs
- | (_, Tconstr(p2, tl2, abbrev2)) when generic_abbrev env p2 ->
+ | (_, Tconstr(p2, tl2, _, abbrev2)) when generic_abbrev env p2 ->
subtype_rec env trace t1 (expand_abbrev env t2) cstrs
- | (Tconstr(p1, tl1, _), Tconstr(p2, tl2, _)) when Path.same p1 p2 ->
+ | (Tconstr(p1, tl1, _, _), Tconstr(p2, tl2, _, _)) when Path.same p1 p2 ->
let decl = Env.find_type p1 env in
List.fold_left2
(fun cstrs (co, cn) (t1, t2) ->
@@ -2382,14 +2385,14 @@ let unalias ty =
| _ ->
newty2 ty.level ty.desc
-let unroll_abbrev id tl ty =
+let unroll_abbrev id tl ar ty =
let ty = repr ty in
if (ty.desc = Tvar) || (List.exists (deep_occur ty) tl) then
ty
else
let ty' = newty2 ty.level ty.desc in
ty.desc <- Tlink (newty2 ty.level
- (Tconstr (Path.Pident id, tl, ref Mnil)));
+ (Tconstr (Path.Pident id, tl, ar, ref Mnil)));
ty'
(* Return the arity (as for curried functions) of the given type. *)
@@ -2402,9 +2405,9 @@ let rec arity ty =
let rec cyclic_abbrev env id ty =
let ty = repr ty in
match ty.desc with
- Tconstr (Path.Pident id', _, _) when Ident.same id id' ->
+ Tconstr (Path.Pident id', _, _, _) when Ident.same id id' ->
true
- | Tconstr (p, tl, abbrev) ->
+ | Tconstr (p, tl, _, abbrev) ->
begin try
cyclic_abbrev env id (try_expand_head env ty)
with Cannot_expand ->
@@ -2440,18 +2443,16 @@ let rec normalize_type_rec env ty =
else f
| _ -> f)
row.row_fields
- and bound = List.fold_left
- (fun tyl ty -> if List.memq ty tyl then tyl else ty :: tyl)
- [] (List.map repr row.row_bound)
- in ty.desc <- Tvariant {row with row_fields = fields; row_bound = bound}
+ and bound = filter_bound row.row_bound in
+ ty.desc <- Tvariant {row with row_fields = fields; row_bound = bound}
| Tobject (_, nm) ->
begin match !nm with
| None -> ()
- | Some (n, v :: l) ->
+ | Some (n, v :: l, ar) ->
let v' = repr v in
begin match v'.desc with
- | Tvar -> if v' != v then nm := Some (n, v' :: l)
- | Tnil -> ty.desc <- Tconstr (n, l, ref Mnil)
+ | Tvar -> if v' != v then nm := Some (n, v' :: l, ar)
+ | Tnil -> ty.desc <- Tconstr (n, l, ar, ref Mnil)
| _ -> nm := None
end
| _ ->
@@ -2502,7 +2503,7 @@ let rec nondep_type_rec env id ty =
Tarrow(l, nondep_type_rec env id t1, nondep_type_rec env id t2, c)
| Ttuple tl ->
Ttuple(List.map (nondep_type_rec env id) tl)
- | Tconstr(p, tl, abbrev) ->
+ | Tconstr(p, tl, ar, abbrev) ->
if Path.isfree id p then
begin try
Tlink (nondep_type_rec env id
@@ -2517,14 +2518,14 @@ let rec nondep_type_rec env id ty =
raise Not_found
end
else
- Tconstr(p, List.map (nondep_type_rec env id) tl, ref Mnil)
+ Tconstr(p, List.map (nondep_type_rec env id) tl, ar, ref Mnil)
| Tobject (t1, name) ->
Tobject (nondep_type_rec env id t1,
ref (match !name with
None -> None
- | Some (p, tl) ->
- if Path.isfree id p then None
- else Some (p, List.map (nondep_type_rec env id) tl)))
+ | Some (p, tl, ar) ->
+ if Path.isfree id p then None else
+ Some (p, List.map (nondep_type_rec env id) tl, ar)))
| Tvariant row ->
let row = row_repr row in
let more = repr row.row_more in
@@ -2625,7 +2626,8 @@ let nondep_type_decl env mid id is_covariant decl =
match decl.type_manifest with
None -> None
| Some ty ->
- Some (unroll_abbrev id params (nondep_type_rec env mid ty))
+ Some (unroll_abbrev id params decl.type_arity
+ (nondep_type_rec env mid ty))
with Not_found when is_covariant ->
None
end;
diff --git a/typing/ctype.mli b/typing/ctype.mli
index 4510dfafc8..2de13d65be 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -44,7 +44,7 @@ val new_global_var: unit -> type_expr
(* Return a fresh variable, bound at toplevel
(as type variables ['a] in type constraints). *)
val newobj: type_expr -> type_expr
-val newconstr: Path.t -> type_expr list -> type_expr
+val newconstr: Path.t -> type_expr list -> int -> type_expr
val none: type_expr
(* A dummy type expression *)
@@ -67,7 +67,7 @@ val close_object: type_expr -> unit
val row_variable: type_expr -> type_expr
(* Return the row variable of an open object type *)
val set_object_name:
- Ident.t -> type_expr -> type_expr list -> type_expr -> unit
+ Ident.t -> type_expr -> type_expr list -> int -> type_expr -> unit
val remove_object_name: type_expr -> unit
val hide_private_methods: type_expr -> unit
diff --git a/typing/env.ml b/typing/env.ml
index fd2bf67eef..6fd2f2f11f 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -362,7 +362,7 @@ let constructors_of_type ty_path decl =
match decl.type_kind with
Type_variant cstrs ->
Datarepr.constructor_descrs
- (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
+ (Btype.newgenconstr ty_path decl.type_params decl.type_arity)
cstrs
| _ -> []
@@ -372,7 +372,7 @@ let labels_of_type ty_path decl =
match decl.type_kind with
Type_record(labels, rep) ->
Datarepr.label_descrs
- (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
+ (Btype.newgenconstr ty_path decl.type_params decl.type_arity)
labels rep
| _ -> []
diff --git a/typing/includecore.ml b/typing/includecore.ml
index 9a8c941473..a59d566013 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -68,8 +68,7 @@ let type_declarations env id decl1 decl2 =
(ty2::decl2.type_params)
| (None, Some ty2) ->
let ty1 =
- Btype.newgenty (Tconstr(Pident id, decl2.type_params, ref Mnil))
- in
+ Btype.newgenconstr (Pident id) decl2.type_params decl2.type_arity in
Ctype.equal env true decl1.type_params decl2.type_params &&
Ctype.equal env false [ty1] [ty2]
end &&
diff --git a/typing/mtype.ml b/typing/mtype.ml
index d984a32a36..26d52da326 100644
--- a/typing/mtype.ml
+++ b/typing/mtype.ml
@@ -47,8 +47,8 @@ and strengthen_sig env sg p =
match decl.type_manifest with
None ->
{ decl with type_manifest =
- Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos),
- decl.type_params, ref Mnil))) }
+ Some(Btype.newgenconstr (Pdot(p, Ident.name id, nopos))
+ decl.type_params decl.type_arity) }
| _ -> decl in
Tsig_type(id, newdecl) :: strengthen_sig env rem p
| (Tsig_exception(id, d) as sigelt) :: rem ->
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index 7310e579ad..fa23730a07 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -29,7 +29,7 @@ exception Empty (* Empty pattern *)
let get_type_descr ty tenv =
let ty = Ctype.repr (Ctype.expand_head tenv ty) in
match ty.desc with
- | Tconstr (path,_,_) -> Env.find_type path tenv
+ | Tconstr (path,_,_,_) -> Env.find_type path tenv
| _ -> fatal_error "Parmatch.get_type_descr"
let get_constr tag ty tenv =
diff --git a/typing/predef.ml b/typing/predef.ml
index b2d1bf22a5..9a54b93325 100644
--- a/typing/predef.ml
+++ b/typing/predef.ml
@@ -48,19 +48,19 @@ and path_nativeint = Pident ident_nativeint
and path_int32 = Pident ident_int32
and path_int64 = Pident ident_int64
-let type_int = newgenty (Tconstr(path_int, [], ref Mnil))
-and type_char = newgenty (Tconstr(path_char, [], ref Mnil))
-and type_string = newgenty (Tconstr(path_string, [], ref Mnil))
-and type_float = newgenty (Tconstr(path_float, [], ref Mnil))
-and type_bool = newgenty (Tconstr(path_bool, [], ref Mnil))
-and type_unit = newgenty (Tconstr(path_unit, [], ref Mnil))
-and type_exn = newgenty (Tconstr(path_exn, [], ref Mnil))
-and type_array t = newgenty (Tconstr(path_array, [t], ref Mnil))
-and type_list t = newgenty (Tconstr(path_list, [t], ref Mnil))
-and type_option t = newgenty (Tconstr(path_option, [t], ref Mnil))
-and type_nativeint = newgenty (Tconstr(path_nativeint, [], ref Mnil))
-and type_int32 = newgenty (Tconstr(path_int32, [], ref Mnil))
-and type_int64 = newgenty (Tconstr(path_int64, [], ref Mnil))
+let type_int = newgenconstr path_int [] 0
+and type_char = newgenconstr path_char [] 0
+and type_string = newgenconstr path_string [] 0
+and type_float = newgenconstr path_float [] 0
+and type_bool = newgenconstr path_bool [] 0
+and type_unit = newgenconstr path_unit [] 0
+and type_exn = newgenconstr path_exn [] 0
+and type_array t = newgenconstr path_array [t] 1
+and type_list t = newgenconstr path_list [t] 1
+and type_option t = newgenconstr path_option [t] 1
+and type_nativeint = newgenconstr path_nativeint [] 0
+and type_int32 = newgenconstr path_int32 [] 0
+and type_int64 = newgenconstr path_int64 [] 0
let ident_match_failure = Ident.create "Match_failure"
and ident_out_of_memory = Ident.create "Out_of_memory"
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index e396585893..a88423ca9d 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -23,6 +23,13 @@ open Asttypes
open Types
open Btype
+(* Misc *)
+let rec firsts n l =
+ if n = 0 then [] else
+ match l with
+ [] -> invalid_arg "Typetexp.firsts"
+ | a :: l -> a :: firsts (n-1) l
+
(* Print a long identifier *)
let rec longident ppf = function
@@ -106,8 +113,8 @@ let rec mark_loops_rec visited ty =
| Tarrow(_, ty1, ty2, _) ->
mark_loops_rec visited ty1; mark_loops_rec visited ty2
| Ttuple tyl -> List.iter (mark_loops_rec visited) tyl
- | Tconstr(_, tyl, _) ->
- List.iter (mark_loops_rec visited) tyl
+ | Tconstr(_, tyl, ar, _) ->
+ List.iter (mark_loops_rec visited) (firsts ar tyl)
| Tvariant row ->
let row = row_repr row in
if List.memq px !visited_objects then add_alias px else
@@ -128,8 +135,8 @@ let rec mark_loops_rec visited ty =
begin match !nm with
| None ->
mark_loops_rec visited fi
- | Some (_, l) ->
- List.iter (mark_loops_rec visited) l
+ | Some (_, l, ar) ->
+ List.iter (mark_loops_rec visited) (firsts ar (List.tl l))
end
end
| Tfield(_, kind, ty1, ty2) when field_kind_repr kind = Fpresent ->
@@ -186,7 +193,8 @@ let rec typexp sch prio0 ppf ty =
print_label ppf l;
if is_optional l then
match (repr ty1).desc with
- | Tconstr(path, [ty], _) when Path.same path Predef.path_option ->
+ | Tconstr(path, [ty], _, _)
+ when Path.same path Predef.path_option ->
typexp sch 2 ppf ty
| _ -> fprintf ppf "<hidden>"
else typexp sch 2 ppf ty1;
@@ -198,8 +206,8 @@ let rec typexp sch prio0 ppf ty =
if prio >= 3
then fprintf ppf "@[<1>(%a)@]" (typlist sch 3 " *") tyl
else fprintf ppf "@[<0>%a@]" (typlist sch 3 " *") tyl
- | Tconstr(p, tyl, abbrev) ->
- fprintf ppf "@[%a%a@]" (typargs sch) tyl path p
+ | Tconstr(p, tyl, ar, abbrev) ->
+ fprintf ppf "@[%a%a@]" (typargs sch) (firsts ar tyl) path p
| Tvariant row ->
let row = row_repr row in
let fields =
@@ -307,8 +315,9 @@ and typobject sch ty fi ppf nm =
Sort.list (fun (n, _) (n', _) -> n <= n') present_fields in
typfields sch rest ppf sorted_fields in
fprintf ppf "@[<2>< %a >@]" pr_fields fi
- | Some (p, {desc = Tvar} :: tyl) ->
- fprintf ppf "@[%a%s#%a@]" (typargs sch) tyl (non_gen_mark sch ty) path p
+ | Some (p, {desc = Tvar} :: tyl, ar) ->
+ fprintf ppf "@[%a%s#%a@]" (typargs sch) (firsts ar tyl)
+ (non_gen_mark sch ty) path p
| _ ->
fatal_error "Printtyp.typobject"
end
@@ -361,7 +370,7 @@ let rec type_decl kwd id ppf decl =
reset();
- let params = filter_params decl.type_params in
+ let params = filter_params (firsts decl.type_arity decl.type_params) in
aliased := params @ !aliased;
List.iter mark_loops params;
@@ -395,7 +404,8 @@ let rec type_decl kwd id ppf decl =
(List.combine params decl.type_variance)
ident id
else
- type_expr ppf (Btype.newgenty (Tconstr(Pident id, params, ref Mnil)))
+ type_expr ppf
+ (Btype.newgenconstr (Pident id) decl.type_params decl.type_arity)
in
let print_manifest ppf decl =
match decl.type_manifest with
@@ -534,8 +544,9 @@ let rec perform_class_type sch params ppf = function
let ty =
if is_optional l then
match (repr ty).desc with
- | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty
- | _ -> newconstr (Path.Pident(Ident.create "<hidden>")) []
+ | Tconstr(path, [ty], _, _) when Path.same path Predef.path_option ->
+ ty
+ | _ -> newconstr (Path.Pident(Ident.create "<hidden>")) [] 0
else ty in
fprintf ppf "@[%a%a ->@ %a@]"
print_label l (typexp sch 2) ty (perform_class_type sch params) cty
@@ -706,12 +717,12 @@ let unification_error unif tr txt1 ppf txt2 =
match t3.desc, t4.desc with
| Tfield _, Tvar | Tvar, Tfield _ ->
fprintf ppf "@,Self type cannot escape its class"
- | Tconstr (p, _, _), Tvar
+ | Tconstr (p, _, _, _), Tvar
when unif && t4.level < Path.binding_time p ->
fprintf ppf
"@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
path p
- | Tvar, Tconstr (p, _, _)
+ | Tvar, Tconstr (p, _, _, _)
when unif && t3.level < Path.binding_time p ->
fprintf ppf
"@,@[The type constructor@;<1 2>%a@ would escape its scope@]"
diff --git a/typing/subst.ml b/typing/subst.ml
index 7fd90c4a35..67d8c41701 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -81,14 +81,14 @@ let rec typexp s ty =
Tarrow(l, typexp s t1, typexp s t2, c)
| Ttuple tl ->
Ttuple(List.map (typexp s) tl)
- | Tconstr(p, tl, abbrev) ->
- Tconstr(type_path s p, List.map (typexp s) tl, ref Mnil)
+ | Tconstr(p, tl, arity, abbrev) ->
+ Tconstr(type_path s p, List.map (typexp s) tl, arity, ref Mnil)
| Tobject (t1, name) ->
Tobject (typexp s t1,
ref (match !name with
None -> None
- | Some (p, tl) ->
- Some (type_path s p, List.map (typexp s) tl)))
+ | Some (p, tl, ar) ->
+ Some (type_path s p, List.map (typexp s) tl, ar)))
| Tvariant row ->
let row = row_repr row in
let more = repr row.row_more in
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 836fd17039..0ab57b4ce8 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -862,7 +862,8 @@ let class_infos define_class kind
(* Check the abbreviation for the object type *)
let (obj_params', obj_type) = Ctype.instance_class params typ in
- let constr = Ctype.newconstr (Path.Pident obj_id) obj_params in
+ let arity = List.length obj_params' in
+ let constr = Ctype.newconstr (Path.Pident obj_id) obj_params arity in
begin
let ty = Ctype.self_type obj_type in
Ctype.hide_private_methods ty;
@@ -873,7 +874,7 @@ let class_infos define_class kind
raise(Error(cl.pci_loc,
Bad_parameters (obj_id, constr,
Ctype.newconstr (Path.Pident obj_id)
- obj_params')))
+ obj_params' arity)))
end;
begin try
Ctype.unify env ty constr
@@ -888,21 +889,21 @@ let class_infos define_class kind
let (cl_params', cl_type) = Ctype.instance_class params typ in
let ty = Ctype.self_type cl_type in
Ctype.hide_private_methods ty;
- Ctype.set_object_name obj_id (Ctype.row_variable ty) cl_params ty;
+ Ctype.set_object_name obj_id (Ctype.row_variable ty) cl_params arity ty;
begin try
List.iter2 (Ctype.unify env) cl_params cl_params'
with Ctype.Unify _ ->
raise(Error(cl.pci_loc,
Bad_parameters (cl_id,
Ctype.newconstr (Path.Pident cl_id)
- cl_params,
+ cl_params arity,
Ctype.newconstr (Path.Pident cl_id)
- cl_params')))
+ cl_params' arity )))
end;
begin try
Ctype.unify env ty cl_ty
with Ctype.Unify _ ->
- let constr = Ctype.newconstr (Path.Pident cl_id) params in
+ let constr = Ctype.newconstr (Path.Pident cl_id) params arity in
raise(Error(cl.pci_loc, Abbrev_type_clash (constr, ty, cl_ty)))
end
end;
@@ -972,7 +973,8 @@ let class_infos define_class kind
Ctype.instance_parameterized_type params (Ctype.self_type typ)
in
Ctype.hide_private_methods cl_ty;
- Ctype.set_object_name obj_id (Ctype.row_variable cl_ty) cl_params cl_ty;
+ Ctype.set_object_name obj_id (Ctype.row_variable cl_ty)
+ cl_params arity cl_ty;
let cl_abbr =
{type_params = cl_params;
type_arity = List.length cl_params;
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 1ac29ee479..4f94eba621 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -74,8 +74,7 @@ let type_constant = function
(* Specific version of type_option, using newty rather than newgenty *)
-let type_option ty =
- newty (Tconstr(Predef.path_option,[ty], ref Mnil))
+let type_option ty = newconstr Predef.path_option [ty] 1
let option_none ty loc =
let cnone = Env.lookup_constructor (Longident.Lident "None") Env.initial in
@@ -88,14 +87,14 @@ let option_some texp =
exp_type = type_option texp.exp_type; exp_env = texp.exp_env }
let extract_option_type env ty =
- match expand_head env ty with {desc = Tconstr(path, [ty], _)}
+ match expand_head env ty with {desc = Tconstr(path, [ty], _, _)}
when Path.same path Predef.path_option -> ty
| _ -> assert false
let rec extract_label_names env ty =
let ty = repr ty in
match ty.desc with
- | Tconstr (path, _, _) ->
+ | Tconstr (path, _, _, _) ->
let td = Env.find_type path env in
begin match td.type_kind with
| Type_record (fields, _) -> List.map (fun (name, _, _) -> name) fields
@@ -205,7 +204,7 @@ let build_or_pat env loc lid =
in
let tyl = List.map (fun _ -> newvar()) decl.type_params in
let fields =
- let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in
+ let ty = expand_head env (newconstr path tyl decl.type_arity) in
match ty.desc with
Tvariant row when static_row row ->
(row_repr row).row_fields
@@ -559,9 +558,7 @@ let type_format loc fmt =
raise(Error(loc, Bad_format(String.sub fmt i (j-i+1))))
end
| _ -> scan_format (i+1) in
- newty
- (Tconstr(Predef.path_format, [scan_format 0; ty_input; ty_result],
- ref Mnil))
+ newconstr Predef.path_format [scan_format 0; ty_input; ty_result] 3
(* Approximate the type of an expression, for better recursion *)
@@ -1278,7 +1275,7 @@ and type_expect env sexp ty_expected =
exp_type =
(* Terrible hack for format strings *)
begin match (repr ty_expected).desc with
- Tconstr(path, _, _) when Path.same path Predef.path_format ->
+ Tconstr(path, _, _, _) when Path.same path Predef.path_format ->
type_format sexp.pexp_loc s
| _ -> instance Predef.type_string
end;
@@ -1366,7 +1363,7 @@ and type_statement env sexp =
| Tarrow _ ->
Location.prerr_warning sexp.pexp_loc Warnings.Partial_application;
exp
- | Tconstr (p, _, _) when Path.same p Predef.path_unit -> exp
+ | Tconstr (p, _, _, _) when Path.same p Predef.path_unit -> exp
| Tvar -> exp
| _ ->
Location.prerr_warning sexp.pexp_loc Warnings.Statement_type;
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index 920951b63e..c35839a2b2 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -22,6 +22,15 @@ open Types
open Typedtree
open Typetexp
+(* Misc *)
+let rec skip n l =
+ if n = 0 then l else
+ match l with [] -> invalid_arg "Typedecl.skip"
+ | _ :: l -> skip (n-1) l
+
+let rec build_list n f =
+ if n = 0 then [] else f () :: build_list (n-1) f
+
type error =
Repeated_parameter
| Duplicate_constructor of string
@@ -64,7 +73,7 @@ let update_type temp_env env id loc =
match decl.type_manifest with None -> ()
| Some ty ->
let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in
- try Ctype.unify env (Ctype.newconstr path params) ty
+ try Ctype.unify env (Ctype.newconstr path params decl.type_arity) ty
with Ctype.Unify trace ->
raise (Error(loc, Type_clash trace))
@@ -72,7 +81,7 @@ let update_type temp_env env id loc =
let is_float env ty =
match Ctype.repr (Ctype.expand_head env ty) with
- {desc = Tconstr(p, _, _)} -> Path.same p Predef.path_float
+ {desc = Tconstr(p, _, _, _)} -> Path.same p Predef.path_float
| _ -> false
(* Translate one type declaration *)
@@ -187,10 +196,10 @@ let rec check_constraints_rec env loc visited ty =
if TypeSet.mem ty !visited then () else begin
visited := TypeSet.add ty !visited;
match ty.desc with
- | Tconstr (path, args, _) ->
+ | Tconstr (path, args, ar, _) ->
Ctype.begin_def ();
let args' = List.map (fun _ -> Ctype.newvar ()) args in
- let ty' = Ctype.newconstr path args' in
+ let ty' = Ctype.newconstr path args' ar in
begin try Ctype.enforce_constraints env ty'
with Ctype.Unify _ -> assert false
end;
@@ -250,7 +259,7 @@ let check_abbrev env (_, sdecl) (id, decl) =
match decl with
{type_kind = (Type_variant _ | Type_record _); type_manifest = Some ty} ->
begin match (Ctype.repr ty).desc with
- Tconstr(path, args, _) ->
+ Tconstr(path, args, _, _) ->
begin try
let decl' = Env.find_type path env in
if List.length args = List.length decl.type_params
@@ -288,10 +297,10 @@ let rec check_expansion_rec env id args loc id_check_list visited ty =
if List.memq ty visited then () else
let visited = ty :: visited in
begin match ty.desc with
- | Tconstr(Path.Pident id' as path, args', _) ->
+ | Tconstr(Path.Pident id' as path, args', ar, _) ->
if Ident.same id id' then begin
if not (Ctype.equal env false args args') then
- raise (Error(loc, Parameters_differ(ty, Ctype.newconstr path args)))
+ raise(Error(loc,Parameters_differ(ty, Ctype.newconstr path args ar)))
end else begin try
let (loc, checked) = List.assoc id' id_check_list in
if List.exists (Ctype.equal env false args') !checked then () else
@@ -343,7 +352,7 @@ let compute_variance env tvl nega posi ty =
compute_variance_rec posi nega ty2
| Ttuple tl ->
List.iter (compute_variance_rec posi nega) tl
- | Tconstr (path, tl, _) ->
+ | Tconstr (path, tl, _, _) ->
if tl = [] then () else
let decl = Env.find_type path env in
List.iter2
@@ -436,6 +445,78 @@ let compute_variance_decls env decls =
List.map (fun (l,_) -> List.map (fun _ -> false, false) l) required in
fst (compute_variance_fixpoint env decls required variances)
+(* Hidden arguments *)
+let rec hidden_params env decls visited hidden others ty =
+ let ty = Btype.repr ty in
+ if TypeSet.mem ty !visited then () else begin
+ visited := TypeSet.add ty !visited;
+ begin match ty.desc with
+ Tconstr (Path.Pident id, tyl, _, _) when List.mem_assoc id decls ->
+ others := TypeSet.add ty !others
+ | Tconstr (path, tyl, _, _) ->
+ let decl = Env.find_type path env in
+ let h = skip decl.type_arity tyl in
+ hidden := List.fold_right TypeSet.add h !hidden
+ | Tvariant row ->
+ hidden := TypeSet.add (Btype.row_more row) !hidden
+ | _ -> ()
+ end;
+ Btype.iter_type_expr (hidden_params env decls visited hidden others) ty
+ end
+
+let hidden_params_decl env decls (id, decl) =
+ let hidden = ref TypeSet.empty
+ and visited = ref TypeSet.empty
+ and others = ref TypeSet.empty in
+ begin match decl.type_kind, decl.type_manifest with
+ | Type_variant l, _ ->
+ List.iter
+ (fun (_, tyl) ->
+ List.iter (hidden_params env decls visited hidden others) tyl)
+ l
+ | Type_record (l, _), _ ->
+ List.iter
+ (fun (_, _, ty) -> hidden_params env decls visited hidden others ty)
+ l
+ | Type_abstract, Some ty ->
+ hidden_params env decls visited hidden others ty
+ | _ -> ()
+ end;
+ !hidden, !others
+
+let more_hidden_params hiddens others n =
+ TypeSet.fold
+ (function {desc=Tconstr (Path.Pident id, tyl, _, _)} ->
+ (+) (List.assoc id hiddens)
+ | _ -> assert false)
+ others n
+
+let insert_hidden_params hiddens (id, decl) (hidden, others) =
+ let params = ref (List.rev decl.type_params) in
+ TypeSet.iter (fun ty -> params := ty :: !params) hidden;
+ TypeSet.iter
+ (function {desc=Tconstr (Path.Pident id as p, tyl, ar, r)} as ty ->
+ let n = List.assoc id hiddens in
+ let args = build_list n Btype.newgenvar in
+ ty.desc <- Tconstr (p, tyl @ args, ar, r);
+ params := List.rev_append args !params
+ | _ -> assert false)
+ others;
+ (id, {decl with type_params = List.rev !params})
+
+let compute_hidden_params env decls =
+ let hidden_others = List.map (hidden_params_decl env decls) decls in
+ let hidden, others = List.split hidden_others in
+ let ids = List.map fst decls in
+ let rec fix hiddens =
+ let ids_hiddens = List.combine ids hiddens in
+ let hiddens' = List.map2 (more_hidden_params ids_hiddens) others hiddens in
+ if hiddens' <> hiddens then fix hiddens' else hiddens
+ in
+ let hiddens = fix (List.map TypeSet.cardinal hidden) in
+ let ids_hiddens = List.combine ids hiddens in
+ List.map2 (insert_hidden_params ids_hiddens) decls hidden_others
+
(* Translate a set of mutually recursive type declarations *)
let transl_type_decl env name_sdecl_list =
(* Create identifiers. *)
@@ -490,10 +571,16 @@ let transl_type_decl env name_sdecl_list =
id_list name_sdecl_list
in
List.iter (check_expansion newenv (List.flatten id_loc_list)) decls;
+ (* extra parameters *)
+ let decls = compute_hidden_params newenv decls in
(* Add variances to the environment *)
let required =
- List.map (fun (_, sdecl) -> sdecl.ptype_variance, sdecl.ptype_loc)
- name_sdecl_list
+ List.map2
+ (fun (_, sdecl) (_, decl) ->
+ sdecl.ptype_variance @ replicate_list (false,false)
+ (List.length decl.type_params - decl.type_arity),
+ sdecl.ptype_loc)
+ name_sdecl_list decls
in
let final_decls, final_env =
compute_variance_fixpoint env decls required
diff --git a/typing/types.ml b/typing/types.ml
index f1ed0cf01e..230cf8b142 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -28,8 +28,8 @@ and type_desc =
Tvar
| Tarrow of label * type_expr * type_expr * commutable
| Ttuple of type_expr list
- | Tconstr of Path.t * type_expr list * abbrev_memo ref
- | Tobject of type_expr * (Path.t * type_expr list) option ref
+ | Tconstr of Path.t * type_expr list * int * abbrev_memo ref
+ | Tobject of type_expr * (Path.t * type_expr list * int) option ref
| Tfield of string * field_kind * type_expr * type_expr
| Tnil
| Tlink of type_expr
diff --git a/typing/types.mli b/typing/types.mli
index 95ac8c887e..561a1d082d 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -27,8 +27,8 @@ and type_desc =
Tvar
| Tarrow of label * type_expr * type_expr * commutable
| Ttuple of type_expr list
- | Tconstr of Path.t * type_expr list * abbrev_memo ref
- | Tobject of type_expr * (Path.t * type_expr list) option ref
+ | Tconstr of Path.t * type_expr list * int * abbrev_memo ref
+ | Tobject of type_expr * (Path.t * type_expr list * int) option ref
| Tfield of string * field_kind * type_expr * type_expr
| Tnil
| Tlink of type_expr
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index b30e8d5a4f..94a573d2c9 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -19,6 +19,13 @@ open Parsetree
open Types
open Ctype
+(* Misc *)
+let rec firsts n l =
+ if n = 0 then [] else
+ match l with
+ [] -> invalid_arg "Typetexp.firsts"
+ | a :: l -> a :: firsts (n-1) l
+
exception Already_bound
type error =
@@ -131,8 +138,8 @@ let rec transl_type env policy styp =
raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
List.length stl)));
let args = List.map (transl_type env policy) stl in
- let params = List.map (fun _ -> Ctype.newvar ()) args in
- let cstr = newty (Tconstr(path, params, ref Mnil)) in
+ let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in
+ let cstr = newconstr path params decl.type_arity in
begin try
Ctype.enforce_constraints env cstr
with Unify trace ->
@@ -142,7 +149,7 @@ let rec transl_type env policy styp =
(fun (sty, ty) ty' ->
try unify env ty ty' with Unify trace ->
raise (Error(sty.ptyp_loc, Type_mismatch trace)))
- (List.combine stl args) params;
+ (List.combine stl args) (firsts decl.type_arity params);
cstr
| Ptyp_object fields ->
newobj (transl_fields env policy fields)
@@ -175,18 +182,18 @@ let rec transl_type env policy styp =
raise(Error(styp.ptyp_loc, Type_arity_mismatch(lid, decl.type_arity,
List.length stl)));
let args = List.map (transl_type env policy) stl in
- let cstr = newty (Tconstr(path, args, ref Mnil)) in
+ let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in
+ let cstr = newconstr path params decl.type_arity in
let ty =
try Ctype.expand_head env cstr
with Unify trace ->
raise (Error(styp.ptyp_loc, Type_mismatch trace))
in
- let params = Ctype.instance_list decl.type_params in
List.iter2
- (fun (sty, ty') ty ->
- try unify env ty' ty with Unify trace ->
+ (fun (sty, ty) ty' ->
+ try unify env ty ty' with Unify trace ->
raise (Error(sty.ptyp_loc, Type_mismatch trace)))
- (List.combine stl args) params;
+ (List.combine stl args) (firsts decl.type_arity params);
begin match ty.desc with
Tvariant row ->
let row = Btype.row_repr row in
View Lorry Controller Status