summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--bytecomp/bytepackager.ml19
-rw-r--r--bytecomp/typeopt.ml12
-rw-r--r--camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml4
-rw-r--r--camlp4/boot/Camlp4.ml4
-rw-r--r--driver/main.ml8
-rw-r--r--ocamldoc/odoc_sig.ml22
-rw-r--r--otherlibs/labltk/browser/searchid.ml2
-rw-r--r--otherlibs/labltk/browser/searchpos.ml2
-rw-r--r--parsing/parser.mly16
-rw-r--r--parsing/parsetree.mli4
-rw-r--r--parsing/printast.ml21
-rw-r--r--parsing/printast.mli2
-rw-r--r--stdlib/arg.ml1
-rw-r--r--tools/depend.ml4
-rw-r--r--toplevel/genprintval.ml23
-rw-r--r--typing/btype.ml12
-rw-r--r--typing/btype.mli1
-rw-r--r--typing/ctype.ml126
-rw-r--r--typing/ctype.mli4
-rw-r--r--typing/datarepr.ml33
-rw-r--r--typing/datarepr.mli6
-rw-r--r--typing/env.ml12
-rw-r--r--typing/env.mli4
-rw-r--r--typing/ident.ml7
-rw-r--r--typing/ident.mli1
-rw-r--r--typing/includecore.ml37
-rw-r--r--typing/oprint.ml24
-rw-r--r--typing/outcometree.mli2
-rw-r--r--typing/parmatch.ml21
-rw-r--r--typing/predef.ml4
-rw-r--r--typing/printtyp.ml26
-rw-r--r--typing/subst.ml22
-rw-r--r--typing/typecore.ml388
-rw-r--r--typing/typedecl.ml80
-rw-r--r--typing/types.ml2
-rw-r--r--typing/types.mli2
36 files changed, 668 insertions, 290 deletions
diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml
index 6649aa3d5..0181ca12b 100644
--- a/bytecomp/bytepackager.ml
+++ b/bytecomp/bytepackager.ml
@@ -222,18 +222,19 @@ let package_object_files files targetfile targetname coercion =
(* The entry point *)
let package_files files targetfile =
- let files =
+ let files =
List.map
- (fun f ->
+ (fun f ->
try find_in_path !Config.load_path f
with Not_found -> raise(Error(File_not_found f)))
- files in
- let prefix = chop_extensions targetfile in
- let targetcmi = prefix ^ ".cmi" in
- let targetname = String.capitalize(Filename.basename prefix) in
- try
- let coercion = Typemod.package_units files targetcmi targetname in
- package_object_files files targetfile targetname coercion
+ files in
+ let prefix = chop_extensions targetfile in
+ let targetcmi = prefix ^ ".cmi" in
+ let targetname = String.capitalize(Filename.basename prefix) in
+ try
+ let coercion = Typemod.package_units files targetcmi targetname in
+ let ret = package_object_files files targetfile targetname coercion in
+ ret
with x ->
remove_file targetfile; raise x
diff --git a/bytecomp/typeopt.ml b/bytecomp/typeopt.ml
index f8e43f0df..56c3a0075 100644
--- a/bytecomp/typeopt.ml
+++ b/bytecomp/typeopt.ml
@@ -37,9 +37,12 @@ let maybe_pointer exp =
not (Path.same p Predef.path_char) &&
begin try
match Env.find_type p exp.exp_env with
- {type_kind = Type_variant []} -> true (* type exn *)
+ | {type_kind = Type_variant []} -> true (* type exn *)
+ | {type_kind = Type_generalized_variant []} -> true (* type exn *)
| {type_kind = Type_variant cstrs} ->
- List.exists (fun (name, args) -> args <> []) cstrs
+ List.exists (fun (name, args) -> args <> []) cstrs (* GAH: dunno what's going on *)
+ | {type_kind = Type_generalized_variant cstrs} ->
+ List.exists (fun (name, args,_) -> args <> []) cstrs (* GAH: dunno what's going on *)
| _ -> true
with Not_found -> true
(* This can happen due to e.g. missing -I options,
@@ -69,7 +72,10 @@ let array_element_kind env ty =
{type_kind = Type_abstract} ->
Pgenarray
| {type_kind = Type_variant cstrs}
- when List.for_all (fun (name, args) -> args = []) cstrs ->
+ when List.for_all (fun (name, args) -> args = []) cstrs -> (* GAH: guess? *)
+ Pintarray
+ | {type_kind = Type_generalized_variant cstrs}
+ when List.for_all (fun (name, args,_) -> args = []) cstrs -> (* GAH: guess? *)
Pintarray
| {type_kind = _} ->
Paddrarray
diff --git a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
index 020a7e0c2..abb34cd53 100644
--- a/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
+++ b/camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
@@ -319,9 +319,9 @@ module Make (Ast : Sig.Camlp4Ast) = struct
| _ -> assert False (*FIXME*) ];
value mkvariant =
fun
- [ <:ctyp@loc< $uid:s$ >> -> (conv_con s, [], mkloc loc)
+ [ <:ctyp@loc< $uid:s$ >> -> (conv_con s, [], None, mkloc loc) (* GAH : pretty sure this is wrong *)
| <:ctyp@loc< $uid:s$ of $t$ >> ->
- (conv_con s, List.map ctyp (list_of_ctyp t []), mkloc loc)
+ (conv_con s, List.map ctyp (list_of_ctyp t []), None, mkloc loc) (* GAH: dunno what I'm doing *)
| _ -> assert False (*FIXME*) ];
value rec type_decl tl cl loc m pflag =
fun
diff --git a/camlp4/boot/Camlp4.ml b/camlp4/boot/Camlp4.ml
index 92daa282d..d7b882828 100644
--- a/camlp4/boot/Camlp4.ml
+++ b/camlp4/boot/Camlp4.ml
@@ -14520,9 +14520,9 @@ module Struct =
let mkvariant =
function
| Ast.TyId (loc, (Ast.IdUid (_, s))) ->
- ((conv_con s), [], (mkloc loc))
+ ((conv_con s), [], None,(mkloc loc)) (* GAH: probably wrong *)
| Ast.TyOf (loc, (Ast.TyId (_, (Ast.IdUid (_, s)))), t) ->
- ((conv_con s), (List.map ctyp (list_of_ctyp t [])),
+ ((conv_con s), (List.map ctyp (list_of_ctyp t [])),None, (* GAH: probably wrong *)
(mkloc loc))
| _ -> assert false
diff --git a/driver/main.ml b/driver/main.ml
index 09aa89655..832c26655 100644
--- a/driver/main.ml
+++ b/driver/main.ml
@@ -165,16 +165,18 @@ let main () =
fatal "Option -i is incompatible with -pack, -a, -output-obj"
else
fatal "Please specify at most one of -pack, -a, -c, -output-obj";
-
if !make_archive then begin
Compile.init_path();
+
Bytelibrarian.create_archive (List.rev !objfiles)
(extract_output !output_name)
end
else if !make_package then begin
Compile.init_path();
- Bytepackager.package_files (List.rev !objfiles)
- (extract_output !output_name)
+ let exctracted_output = extract_output !output_name in
+ let revd = List.rev !objfiles in
+ Bytepackager.package_files (revd)
+ (exctracted_output)
end
else if not !compile_only && !objfiles <> [] then begin
let target =
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml
index f8308d6c6..e55c80901 100644
--- a/ocamldoc/odoc_sig.ml
+++ b/ocamldoc/odoc_sig.ml
@@ -179,21 +179,21 @@ module Analyser =
match cons_core_type_list_list with
[] ->
(0, acc)
- | (name, core_type_list, loc) :: [] ->
+ | (name, (_ : Parsetree.core_type list),(_:Parsetree.core_type option), loc) :: [] ->
let s = get_string_of_file
loc.Location.loc_end.Lexing.pos_cnum
pos_limit
in
let (len, comment_opt) = My_ir.just_after_special !file_name s in
(len, acc @ [ (name, comment_opt) ])
- | (name, core_type_list, loc) :: (name2, core_type_list2, loc2)
+ | (name, core_type_list, _, loc) :: (name2, core_type_list2, (ret_type2:Parsetree.core_type option), loc2)
:: q ->
let pos_end_first = loc.Location.loc_end.Lexing.pos_cnum in
let pos_start_second = loc2.Location.loc_start.Lexing.pos_cnum in
let s = get_string_of_file pos_end_first pos_start_second in
let (_,comment_opt) = My_ir.just_after_special !file_name s in
f (acc @ [name, comment_opt])
- ((name2, core_type_list2, loc2) :: q)
+ ((name2, core_type_list2, ret_type2, loc2) :: q)
in
f [] cons_core_type_list_list
@@ -236,6 +236,22 @@ module Analyser =
}
in
Odoc_type.Type_variant (List.map f l)
+ | Types.Type_generalized_variant l ->
+ let f (constructor_name, type_expr_list,(_:Parsetree.core_type option)) =
+ let comment_opt =
+ try
+ match List.assoc constructor_name name_comment_list with
+ None -> None
+ | Some d -> d.Odoc_types.i_desc
+ with Not_found -> None
+ in
+ {
+ vc_name = constructor_name ;
+ vc_args = List.map (Odoc_env.subst_type env) type_expr_list ;
+ vc_text = comment_opt
+ }
+ in
+ Odoc_type.Type_variant (List.map f l)
| Types.Type_record (l, _) ->
let f (field_name, mutable_flag, type_expr) =
diff --git a/otherlibs/labltk/browser/searchid.ml b/otherlibs/labltk/browser/searchid.ml
index 284814390..3c09b90b6 100644
--- a/otherlibs/labltk/browser/searchid.ml
+++ b/otherlibs/labltk/browser/searchid.ml
@@ -230,6 +230,8 @@ let rec search_type_in_signature t ~sign ~prefix ~mode =
Type_abstract -> false
| Type_variant l ->
List.exists l ~f:(fun (_, l) -> List.exists l ~f:matches)
+ | Type_generalized_variant l -> (* pretty sure this is wrong *)
+ List.exists l ~f:(fun (_, l, r) -> List.exists l ~f:matches || (match r with None -> false | Some x -> matches x))
| Type_record(l, rep) ->
List.exists l ~f:(fun (_, _, t) -> matches t)
end
diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml
index 8cae99593..5b0fe71fd 100644
--- a/otherlibs/labltk/browser/searchpos.ml
+++ b/otherlibs/labltk/browser/searchpos.ml
@@ -170,7 +170,7 @@ let search_pos_type_decl td ~pos ~env =
Ptype_abstract -> ()
| Ptype_variant dl ->
List.iter dl
- ~f:(fun (_, tl, _) -> List.iter tl ~f:(search_pos_type ~pos ~env))
+ ~f:(fun (_, tl, _, _) -> List.iter tl ~f:(search_pos_type ~pos ~env)) (* might be false *)
| Ptype_record dl ->
List.iter dl ~f:(fun (_, _, t, _) -> search_pos_type t ~pos ~env) in
search_tkind td.ptype_kind;
diff --git a/parsing/parser.mly b/parsing/parser.mly
index 4f9bcc58b..87cb9ddec 100644
--- a/parsing/parser.mly
+++ b/parsing/parser.mly
@@ -1284,12 +1284,26 @@ constructor_declarations:
| constructor_declarations BAR constructor_declaration { $3 :: $1 }
;
constructor_declaration:
- constr_ident constructor_arguments { ($1, $2, symbol_rloc()) }
+ constr_ident constructor_arguments { ($1, $2, None, symbol_rloc()) }
;
+
+constructor_declaration:
+ constr_ident generalized_constructor_arguments
+ { let arg_types,ret_type = $2 in
+ ($1, arg_types,Some ret_type, symbol_rloc()) }
+;
+
constructor_arguments:
/*empty*/ { [] }
| OF core_type_list { List.rev $2 }
;
+
+generalized_constructor_arguments:
+ | COLON core_type_list MINUSGREATER simple_core_type
+ { (List.rev $2,$4) }
+;
+
+
label_declarations:
label_declaration { [$1] }
| label_declarations SEMI label_declaration { $3 :: $1 }
diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli
index 05f92bd03..53ba2e527 100644
--- a/parsing/parsetree.mli
+++ b/parsing/parsetree.mli
@@ -46,7 +46,7 @@ and core_field_desc =
| Pfield_var
and row_field =
- Rtag of label * bool * core_type list
+ Rtag of label * bool * core_type list
| Rinherit of core_type
(* Type expressions for the class language *)
@@ -138,7 +138,7 @@ and type_declaration =
and type_kind =
Ptype_abstract
- | Ptype_variant of (string * core_type list * Location.t) list
+ | Ptype_variant of (string * core_type list * core_type option * Location.t) list
| Ptype_record of
(string * mutable_flag * core_type * Location.t) list
diff --git a/parsing/printast.ml b/parsing/printast.ml
index f63e21b87..e173dcb50 100644
--- a/parsing/printast.ml
+++ b/parsing/printast.ml
@@ -347,7 +347,7 @@ and type_declaration i ppf x =
line i ppf "ptype_manifest =\n";
option (i+1) core_type ppf x.ptype_manifest;
-and type_kind i ppf x =
+and type_kind i ppf x = (* GAH: why doesn't this module use Format?? *)
match x with
| Ptype_abstract ->
line i ppf "Ptype_abstract\n"
@@ -663,9 +663,17 @@ and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
core_type (i+1) ppf ct1;
core_type (i+1) ppf ct2;
-and string_x_core_type_list_x_location i ppf (s, l, loc) =
- line i ppf "\"%s\" %a\n" s fmt_location loc;
- list (i+1) core_type ppf l;
+and string_x_core_type_list_x_location i ppf (s, l, r_opt, loc) =
+ match r_opt with
+ | None ->
+ line i ppf "\"%s\" %a\n" s fmt_location loc;
+ list (i+1) core_type ppf l;
+ | Some ret_type -> (* GAH: this is definately wrong *)
+ line i ppf "\"%s\" %a\n" s fmt_location loc;
+ list (i+1) core_type ppf l;
+ core_type i ppf ret_type
+
+
and string_x_mutable_flag_x_core_type_x_location i ppf (s, mf, ct, loc) =
line i ppf "\"%s\" %a %a\n" s fmt_mutable_flag mf fmt_location loc;
@@ -734,3 +742,8 @@ let interface ppf x = list 0 signature_item ppf x;;
let implementation ppf x = list 0 structure_item ppf x;;
let top_phrase ppf x = toplevel_phrase 0 ppf x;;
+
+let print_expression = expression 0 ;;
+
+let print_pattern = pattern 0 ;;
+
diff --git a/parsing/printast.mli b/parsing/printast.mli
index 7ea148678..4bf4635cc 100644
--- a/parsing/printast.mli
+++ b/parsing/printast.mli
@@ -18,3 +18,5 @@ open Format;;
val interface : formatter -> signature_item list -> unit;;
val implementation : formatter -> structure_item list -> unit;;
val top_phrase : formatter -> toplevel_phrase -> unit;;
+val print_expression : formatter -> expression -> unit;;
+val print_pattern : formatter -> pattern -> unit;;
diff --git a/stdlib/arg.ml b/stdlib/arg.ml
index 009e20375..716ae45e9 100644
--- a/stdlib/arg.ml
+++ b/stdlib/arg.ml
@@ -208,6 +208,7 @@ let parse_argv ?(current=current) argv speclist anonfun errmsg =
let parse l f msg =
try
+
parse_argv Sys.argv l f msg;
with
| Bad msg -> eprintf "%s" msg; exit 2;
diff --git a/tools/depend.ml b/tools/depend.ml
index 44e85702b..4117fe675 100644
--- a/tools/depend.ml
+++ b/tools/depend.ml
@@ -67,7 +67,7 @@ let add_opt add_fn bv = function
None -> ()
| Some x -> add_fn bv x
-let add_type_declaration bv td =
+let add_type_declaration bv td = (* GAH: no idea if this is correct *)
List.iter
(fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2)
td.ptype_cstrs;
@@ -75,7 +75,7 @@ let add_type_declaration bv td =
let rec add_tkind = function
Ptype_abstract -> ()
| Ptype_variant cstrs ->
- List.iter (fun (c, args, _) -> List.iter (add_type bv) args) cstrs
+ List.iter (fun (c, args, rty, _) -> List.iter (add_type bv) args; Misc.may (add_type bv) rty) cstrs
| Ptype_record lbls ->
List.iter (fun (l, mut, ty, _) -> add_type bv ty) lbls in
add_tkind td.ptype_kind
diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml
index 327700400..5ac0e03fd 100644
--- a/toplevel/genprintval.ml
+++ b/toplevel/genprintval.ml
@@ -235,19 +235,12 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
| Tconstr(path, ty_list, _) ->
begin try
let decl = Env.find_type path env in
- match decl with
- | {type_kind = Type_abstract; type_manifest = None} ->
- Oval_stuff "<abstr>"
- | {type_kind = Type_abstract; type_manifest = Some body} ->
- tree_of_val depth obj
- (try Ctype.apply env decl.type_params body ty_list with
- Ctype.Cannot_apply -> abstract_type)
- | {type_kind = Type_variant constr_list} ->
+ let process_variants constr_list =
let tag =
if O.is_block obj
then Cstr_block(O.tag obj)
else Cstr_constant(O.obj obj) in
- let (constr_name, constr_args) =
+ let (constr_name, constr_args,_) = (* GAH: this is definately wrong *)
Datarepr.find_constr_by_tag tag constr_list in
let ty_args =
List.map
@@ -257,6 +250,18 @@ module Make(O : OBJ)(EVP : EVALPATH with type value = O.t) = struct
constr_args in
tree_of_constr_with_args (tree_of_constr env path)
constr_name 0 depth obj ty_args
+ in
+ match decl with
+ | {type_kind = Type_abstract; type_manifest = None} ->
+ Oval_stuff "<abstr>"
+ | {type_kind = Type_abstract; type_manifest = Some body} ->
+ tree_of_val depth obj
+ (try Ctype.apply env decl.type_params body ty_list with
+ Ctype.Cannot_apply -> abstract_type)
+ | {type_kind = Type_variant constr_list} ->
+ process_variants (List.map (fun (a,b) -> (a,b,None)) constr_list)
+ | {type_kind = Type_generalized_variant constr_list} ->
+ process_variants constr_list
| {type_kind = Type_record(lbl_list, rep)} ->
begin match check_depth depth obj ty with
Some x -> x
diff --git a/typing/btype.ml b/typing/btype.ml
index 16254e622..759ed50f5 100644
--- a/typing/btype.ml
+++ b/typing/btype.ml
@@ -314,7 +314,16 @@ let unmark_type_decl decl =
begin match decl.type_kind with
Type_abstract -> ()
| Type_variant cstrs ->
- List.iter (fun (c, tl) -> List.iter unmark_type tl) cstrs
+ List.iter
+ (fun (c, tl) ->
+ List.iter unmark_type tl)
+ cstrs (* GAH: WHAT DOES UNMARK DO??? *)
+ | Type_generalized_variant cstrs ->
+ List.iter
+ (fun (c, tl,ret_type_opt) ->
+ List.iter unmark_type tl;
+ Misc.may unmark_type ret_type_opt)
+ cstrs (* GAH: WHAT DOES UNMARK DO??? *)
| Type_record(lbls, rep) ->
List.iter (fun (c, mut, t) -> unmark_type t) lbls
end;
@@ -514,5 +523,6 @@ let backtrack (changes, old) =
(**** Sets, maps and hashtables of types ****)
module TypeSet = Set.Make(TypeOps)
+module TypeSetPair = Set.Make(struct type t = TypeOps.t * TypeOps.t let compare (x1,x2) (y1,y2) = let r = TypeOps.compare x1 y1 in if r == 0 then TypeOps.compare x2 y2 else r end)
module TypeMap = Map.Make (TypeOps)
module TypeHash = Hashtbl.Make(TypeOps)
diff --git a/typing/btype.mli b/typing/btype.mli
index cd22e8fee..f230b2f2d 100644
--- a/typing/btype.mli
+++ b/typing/btype.mli
@@ -157,5 +157,6 @@ val log_type: type_expr -> unit
(**** Sets, maps and hashtables of types ****)
module TypeSet : Set.S with type elt = type_expr
+module TypeSetPair : Set.S with type elt = type_expr * type_expr
module TypeMap : Map.S with type key = type_expr
module TypeHash : Hashtbl.S with type key = type_expr
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 17549e853..bfc9b1243 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -457,8 +457,19 @@ let closed_type_decl decl =
begin match decl.type_kind with
Type_abstract ->
()
+ | Type_generalized_variant v ->
+ List.iter
+ (fun (_, tyl,ret_type_opt) ->
+ match ret_type_opt with
+ | Some _ -> ()
+ | None ->
+ List.iter closed_type tyl)
+ v (* GAH: is this correct ? *)
| Type_variant v ->
- List.iter (fun (_, tyl) -> List.iter closed_type tyl) v
+ List.iter
+ (fun (_, tyl) ->
+ List.iter closed_type tyl)
+ v (* GAH: is this correct ? *)
| Type_record(r, rep) ->
List.iter (fun (_, _, ty) -> closed_type ty) r
end;
@@ -1539,60 +1550,91 @@ let deep_occur t0 ty =
abbreviated. It would be possible to check whether some
information is indeed lost, but it probably does not worth it.
*)
+
+let pattern_unification = ref false
+let local_unifier = ref []
+
+
+let set_unification_type x =
+ match x with
+ | `Pattern ->
+ pattern_unification := true
+ | `Expression ->
+ pattern_unification := false
+
+let get_unification_type () =
+ match !pattern_unification with
+ | true -> `Pattern
+ | false -> `Expression
+
+let reset_local_unifier () =
+ local_unifier := []
+
+let get_local_unifier () = !local_unifier
+let uni_equalities = ref TypeSetPair.empty
+let uni_eq t1 t2 = t1 == t2 || TypeSetPair.mem (t1,t2) !uni_equalities || TypeSetPair.mem (t2,t1) !uni_equalities
+let add_equality t1 t2 =
+ uni_equalities := TypeSetPair.add (t1, t2) !uni_equalities
+
+
let rec unify env t1 t2 =
(* First step: special cases (optimizations) *)
- if t1 == t2 then () else
+ if uni_eq t1 t2 then () else
let t1 = repr t1 in
let t2 = repr t2 in
- if t1 == t2 then () else
-
+ if uni_eq t1 t2 then () else
try
type_changed := true;
match (t1.desc, t2.desc) with
- (Tvar, Tconstr _) when deep_occur t1 t2 ->
+ | (Tvar, Tconstr _) when deep_occur t1 t2 ->
unify2 env t1 t2
- | (Tconstr _, Tvar) when deep_occur t2 t1 ->
+ | (Tconstr _, Tvar) when deep_occur t2 t1 ->
unify2 env t1 t2
- | (Tvar, _) ->
+ | (Tvar, _) ->
occur env t1 t2; occur_univar env t2;
update_level env t1.level t2;
link_type t1 t2
- | (_, Tvar) ->
+ | (_, Tvar) ->
occur env t2 t1; occur_univar env t1;
update_level env t2.level t1;
link_type t2 t1
- | (Tunivar, Tunivar) ->
+ | (Tunivar, Tunivar) -> (* GAH : ask garrigue: when do we unify univars? *)
unify_univar t1 t2 !univar_pairs;
update_level env t1.level t2;
link_type t1 t2
+
| (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. *)
&& not (has_cached_expansion p1 !a1
- || has_cached_expansion p2 !a2) ->
+ || has_cached_expansion p2 !a2) ->
update_level env t1.level t2;
link_type t1 t2
- | _ ->
+
+
+ | _ ->
unify2 env t1 t2
with Unify trace ->
raise (Unify ((t1, t2)::trace))
and unify2 env t1 t2 =
+
+
+
(* Second step: expansion of abbreviations *)
let rec expand_both t1'' t2'' =
let t1' = expand_head_unif env t1 in
let t2' = expand_head_unif env t2 in
(* Expansion may have changed the representative of the types... *)
- if t1' == t1'' && t2' == t2'' then (t1',t2') else
+ if uni_eq t1' t1'' && uni_eq t2' t2'' then (t1',t2') else
expand_both t1' t2'
in
let t1', t2' = expand_both t1 t2 in
- if t1' == t2' then () else
-
+ if uni_eq t1' t2' then () else
let t1 = repr t1 and t2 = repr t2 in
- if (t1 == t1') || (t2 != t2') then
+ if (uni_eq t1 t1') || (not (uni_eq t2 t2')) then (* GAH: ask garrigue why this code seems so strange *)
unify3 env t1 t1' t2 t2'
else
try unify3 env t2 t2' t1 t1' with Unify trace ->
@@ -1606,16 +1648,22 @@ and unify3 env t1 t1' t2 t2' =
let create_recursion = (t2 != t2') && (deep_occur t1' t2) in
occur env t1' t2;
update_level env t1'.level t2;
- link_type t1' t2;
+ add_equality t1' t2;
+
+
+
try
begin match (d1, d2) with
(Tvar, _) ->
+ link_type t1' t2;
occur_univar env t2
| (_, Tvar) ->
- let td1 = newgenty d1 in
+ link_type t2' t1;
+ occur_univar env t1;
+(* let td1 = newgenty d1 in
occur env t2' td1;
- occur_univar env td1;
+
if t1 == t1' then begin
(* The variable must be instantiated... *)
let ty = newty2 t1'.level d1 in
@@ -1626,7 +1674,7 @@ and unify3 env t1 t1' t2 t2' =
t1'.desc <- d1;
update_level env t2'.level t1;
link_type t2' t1
- end
+ end*)
| (Tarrow (l1, t1, u1, c1), Tarrow (l2, t2, u2, c2)) when l1 = l2
|| !Clflags.classic && not (is_optional l1 || is_optional l2) ->
unify env t1 t2; unify env u1 u2;
@@ -1669,6 +1717,18 @@ and unify3 env t1 t1' t2 t2' =
enter_poly env univar_pairs t1 tl1 t2 tl2 (unify env)
| (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) when Path.same p1 p2 && n1 = n2 ->
unify_list env tl1 tl2
+ | (Tunivar,_) ->
+
+ if !pattern_unification then
+ local_unifier:= (t1,t2) :: !local_unifier
+ else
+ raise (Unify [])
+ | (_,Tunivar) ->
+
+ if !pattern_unification then
+ local_unifier:= (t2,t1) :: !local_unifier
+ else
+ ( raise (Unify []) )
| (_, _) ->
raise (Unify [])
end;
@@ -1887,13 +1947,19 @@ and unify_row_field env fixed1 fixed2 more l f1 f2 =
set_row_field e2 f1
| _ -> raise (Unify [])
+;;
+
let unify env ty1 ty2 =
try
- unify env ty1 ty2
+ uni_equalities := TypeSetPair.empty;
+ unify env ty1 ty2;
+ uni_equalities := TypeSetPair.empty;
with Unify trace ->
+ uni_equalities := TypeSetPair.empty;
raise (Unify (expand_trace env trace))
+
let unify_var env t1 t2 =
let t1 = repr t1 and t2 = repr t2 in
if t1 == t2 then () else
@@ -3371,7 +3437,17 @@ let nondep_type_decl env mid id is_covariant decl =
| Type_variant cstrs ->
Type_variant
(List.map
- (fun (c, tl) -> (c, List.map (nondep_type_rec env mid) tl))
+ (fun (c, tl) ->
+ (c, List.map (nondep_type_rec env mid) tl)) (* GAH: HERE TOO? *)
+ cstrs)
+ | Type_generalized_variant cstrs ->
+ Type_generalized_variant
+ (List.map
+ (fun (c, tl,ret_type_opt) ->
+ let ret_type_opt =
+ may_map (nondep_type_rec env mid) ret_type_opt
+ in
+ (c, List.map (nondep_type_rec env mid) tl,ret_type_opt)) (* GAH: HERE TOO? *)
cstrs)
| Type_record(lbls, rep) ->
Type_record
@@ -3478,3 +3554,11 @@ let rec collapse_conj env visited ty =
let collapse_conj_params env params =
List.iter (collapse_conj env []) params
+
+
+
+
+
+
+
+
diff --git a/typing/ctype.mli b/typing/ctype.mli
index 21a45fb82..108b251a1 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -250,3 +250,7 @@ val arity: type_expr -> int
val collapse_conj_params: Env.t -> type_expr list -> unit
(* Collapse conjunctive types in class parameters *)
+val reset_local_unifier: unit -> unit
+val get_local_unifier: unit -> (type_expr * type_expr) list
+val set_unification_type : [`Pattern | `Expression] -> unit
+val get_unification_type : unit -> [`Pattern | `Expression]
diff --git a/typing/datarepr.ml b/typing/datarepr.ml
index 80b94132d..2482059c5 100644
--- a/typing/datarepr.ml
+++ b/typing/datarepr.ml
@@ -22,20 +22,34 @@ open Types
let constructor_descrs ty_res cstrs priv =
let num_consts = ref 0 and num_nonconsts = ref 0 in
List.iter
- (function (name, []) -> incr num_consts
- | (name, _) -> incr num_nonconsts)
+ (function (name, [],_) -> incr num_consts
+ | (name, _,_) -> incr num_nonconsts)
cstrs;
let rec describe_constructors idx_const idx_nonconst = function
[] -> []
- | (name, ty_args) :: rem ->
+ | (name, ty_args, ty_res_opt) :: rem ->
+ let ty_res =
+ match ty_res_opt with
+ | Some ty_res -> ty_res
+ | None -> ty_res
+ in
let (tag, descr_rem) =
match ty_args with
[] -> (Cstr_constant idx_const,
describe_constructors (idx_const+1) idx_nonconst rem)
| _ -> (Cstr_block idx_nonconst,
describe_constructors idx_const (idx_nonconst+1) rem) in
+(* let existentials =
+ match ty_res_opt with
+ | None -> []
+ | Some type_ret ->
+ let res_vars = List.fold_right Btype.TypeSet.add (free_vars type_ret) Btype.TypeSet.empty in
+ let other_types
+*)
+
let cstr =
- { cstr_res = ty_res;
+ { cstr_res = ty_res;
+ cstr_existentials = [] ; (* GAH: HOW DO I GET THE EXISTENTIALS OF A TYPE?? *)
cstr_args = ty_args;
cstr_arity = List.length ty_args;
cstr_tag = tag;
@@ -47,6 +61,7 @@ let constructor_descrs ty_res cstrs priv =
let exception_descr path_exc decl =
{ cstr_res = Predef.type_exn;
+ cstr_existentials = [] ; (* GAH: is this correct? *)
cstr_args = decl;
cstr_arity = List.length decl;
cstr_tag = Cstr_exception path_exc;
@@ -81,16 +96,16 @@ let label_descrs ty_res lbls repres priv =
exception Constr_not_found
-let rec find_constr tag num_const num_nonconst = function
+let rec find_constr tag num_const num_nonconst = function (* GAH: is this correct? *)
[] ->
raise Constr_not_found
- | (name, [] as cstr) :: rem ->
+ | (name, ([] as cstr),(_ as ret_type_opt)) :: rem ->
if tag = Cstr_constant num_const
- then cstr
+ then (name,cstr,ret_type_opt)
else find_constr tag (num_const + 1) num_nonconst rem
- | (name, _ as cstr) :: rem ->
+ | (name, (_ as cstr),(_ as ret_type_opt)) :: rem ->
if tag = Cstr_block num_nonconst
- then cstr
+ then (name,cstr,ret_type_opt)
else find_constr tag num_const (num_nonconst + 1) rem
let find_constr_by_tag tag cstrlist =
diff --git a/typing/datarepr.mli b/typing/datarepr.mli
index 283dbd294..81b3a7e83 100644
--- a/typing/datarepr.mli
+++ b/typing/datarepr.mli
@@ -17,9 +17,9 @@
open Asttypes
open Types
-
+
val constructor_descrs:
- type_expr -> (string * type_expr list) list -> private_flag ->
+ type_expr -> (string * type_expr list * type_expr option) list -> private_flag ->
(string * constructor_description) list
val exception_descr:
Path.t -> type_expr list -> constructor_description
@@ -31,4 +31,4 @@ val label_descrs:
exception Constr_not_found
val find_constr_by_tag:
- constructor_tag -> (string * type_expr list) list -> string * type_expr list
+ constructor_tag -> (string * type_expr list * type_expr option) list -> string * type_expr list * type_expr option
diff --git a/typing/env.ml b/typing/env.ml
index 044247990..391a363f4 100644
--- a/typing/env.ml
+++ b/typing/env.ml
@@ -84,6 +84,8 @@ and functor_components = {
fcomp_cache: (Path.t, module_components) Hashtbl.t (* For memoization *)
}
+let map_values f t = {t with values = Ident.map_tbl f t.values}
+
let empty = {
values = Ident.empty; annotations = Ident.empty; constrs = Ident.empty;
labels = Ident.empty; types = Ident.empty;
@@ -451,11 +453,15 @@ let rec scrape_modtype mty env =
(* Compute constructor descriptions *)
let constructors_of_type ty_path decl =
- match decl.type_kind with
- Type_variant cstrs ->
+ let handle_variants cstrs =
Datarepr.constructor_descrs
(Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
cstrs decl.type_private
+ in
+ match decl.type_kind with
+ | Type_variant cstrs ->
+ handle_variants (List.map (fun (a,b) -> (a,b,None)) cstrs)
+ | Type_generalized_variant cstrs -> handle_variants cstrs
| Type_record _ | Type_abstract -> []
(* Compute label descriptions *)
@@ -466,7 +472,7 @@ let labels_of_type ty_path decl =
Datarepr.label_descrs
(Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
labels rep decl.type_private
- | Type_variant _ | Type_abstract -> []
+ | Type_variant _ | Type_generalized_variant _ | Type_abstract -> []
(* Given a signature and a root path, prefix all idents in the signature
by the root path and build the corresponding substitution. *)
diff --git a/typing/env.mli b/typing/env.mli
index 8f00972a6..857e4c07b 100644
--- a/typing/env.mli
+++ b/typing/env.mli
@@ -49,8 +49,12 @@ val lookup_modtype: Longident.t -> t -> Path.t * modtype_declaration
val lookup_class: Longident.t -> t -> Path.t * class_declaration
val lookup_cltype: Longident.t -> t -> Path.t * cltype_declaration
+val map_values: (Path.t * value_description -> Path.t * value_description) -> t -> t
+
(* Insertion by identifier *)
+
+
val add_value: Ident.t -> value_description -> t -> t
val add_annot: Ident.t -> Annot.ident -> t -> t
val add_type: Ident.t -> type_declaration -> t -> t
diff --git a/typing/ident.ml b/typing/ident.ml
index c5bc09f41..82603d7d5 100644
--- a/typing/ident.ml
+++ b/typing/ident.ml
@@ -95,6 +95,13 @@ and 'a data =
data: 'a;
previous: 'a data option }
+let rec map_tbl f = (* GAH: THIS IS PROBABLY TOTALLY WRONG *)
+ function
+ | Empty -> Empty
+ | Node (t,{ident=id;data=d;previous=p},t',i) ->
+ Node(map_tbl f t,{ident=id;data=f d;previous=p},map_tbl f t',i)
+
+
let empty = Empty
(* Inline expansion of height for better speed
diff --git a/typing/ident.mli b/typing/ident.mli
index 03e2eee48..aef331f31 100644
--- a/typing/ident.mli
+++ b/typing/ident.mli
@@ -57,3 +57,4 @@ val add: t -> 'a -> 'a tbl -> 'a tbl
val find_same: t -> 'a tbl -> 'a
val find_name: string -> 'a tbl -> 'a
val keys: 'a tbl -> t list
+val map_tbl: ('a -> 'a) -> 'a tbl -> 'a tbl
diff --git a/typing/includecore.ml b/typing/includecore.ml
index a08831924..2f8ba110e 100644
--- a/typing/includecore.ml
+++ b/typing/includecore.ml
@@ -161,21 +161,29 @@ let report_type_mismatch first second decl ppf =
Format.fprintf ppf "@ %a." (report_type_mismatch0 first second decl) err)
let rec compare_variants env decl1 decl2 n cstrs1 cstrs2 =
- match cstrs1, cstrs2 with
+ match cstrs1, cstrs2 with (* GAH: most likely wrong, but I don't know what this function does *)
[], [] -> []
- | [], (cstr2,_)::_ -> [Field_missing (true, cstr2)]
- | (cstr1,_)::_, [] -> [Field_missing (false, cstr1)]
- | (cstr1, arg1)::rem1, (cstr2, arg2)::rem2 ->
+ | [], (cstr2,_,_)::_ -> [Field_missing (true, cstr2)]
+ | (cstr1,_,_)::_, [] -> [Field_missing (false, cstr1)]
+ | (cstr1, arg1, ret1)::rem1, (cstr2, arg2,ret2)::rem2 ->
if cstr1 <> cstr2 then [Field_names (n, cstr1, cstr2)] else
if List.length arg1 <> List.length arg2 then [Field_arity cstr1] else
- if Misc.for_all2
- (fun ty1 ty2 ->
- Ctype.equal env true (ty1::decl1.type_params)
- (ty2::decl2.type_params))
- arg1 arg2
- then compare_variants env decl1 decl2 (n+1) rem1 rem2
- else [Field_type cstr1]
-
+ match ret1, ret2 with
+ | Some r1, Some r2 when not (Ctype.equal env true [r1] [r2]) ->
+ [Field_type cstr1]
+ | Some _, None | None, Some _ ->
+ [Field_type cstr1]
+ | _ ->
+ if Misc.for_all2
+ (fun ty1 ty2 ->
+ Ctype.equal env true (ty1::decl1.type_params)
+ (ty2::decl2.type_params))
+ (arg1) (arg2)
+ then
+ compare_variants env decl1 decl2 (n+1) rem1 rem2
+ else [Field_type cstr1]
+
+
let rec compare_records env decl1 decl2 n labels1 labels2 =
match labels1, labels2 with
[], [] -> []
@@ -195,6 +203,9 @@ let type_declarations env id decl1 decl2 =
let err = match (decl1.type_kind, decl2.type_kind) with
(_, Type_abstract) -> []
| (Type_variant cstrs1, Type_variant cstrs2) ->
+ let gen_variants lst = List.map (fun (a,b) -> (a,b,None)) lst in
+ compare_variants env decl1 decl2 1 (gen_variants cstrs1) (gen_variants cstrs2)
+ | (Type_generalized_variant cstrs1, Type_generalized_variant cstrs2) ->
compare_variants env decl1 decl2 1 cstrs1 cstrs2
| (Type_record(labels1,rep1), Type_record(labels2,rep2)) ->
let err = compare_records env decl1 decl2 1 labels1 labels2 in
@@ -222,7 +233,7 @@ let type_declarations env id decl1 decl2 =
in
if err <> [] then err else
if match decl2.type_kind with
- | Type_record (_,_) | Type_variant _ -> decl2.type_private = Private
+ | Type_record (_,_) | Type_generalized_variant _ | Type_variant _ -> decl2.type_private = Private
| Type_abstract ->
match decl2.type_manifest with
| None -> true
diff --git a/typing/oprint.ml b/typing/oprint.ml
index ca5db71a6..f7a0c869f 100644
--- a/typing/oprint.ml
+++ b/typing/oprint.ml
@@ -350,7 +350,7 @@ and print_out_sig_item ppf =
(if vir_flag then " virtual" else "") print_out_class_params params
name !out_class_type clt
| Osig_exception (id, tyl) ->
- fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl)
+ fprintf ppf "@[<2>exception %a@]" print_out_constr (id, tyl,None)
| Osig_modtype (name, Omty_abstract) ->
fprintf ppf "@[<2>module type %s@]" name
| Osig_modtype (name, mty) ->
@@ -428,12 +428,22 @@ and print_out_type_decl kwd ppf (name, args, ty, priv, constraints) =
print_name_args
print_out_tkind ty
print_constraints constraints
-and print_out_constr ppf (name, tyl) =
- match tyl with
- [] -> fprintf ppf "%s" name
- | _ ->
- fprintf ppf "@[<2>%s of@ %a@]" name
- (print_typlist print_simple_out_type " *") tyl
+and print_out_constr ppf (name, tyl,ret_type_opt) =
+ match ret_type_opt with
+ | None ->
+ begin match tyl with
+ | [] -> fprintf ppf "%s" name
+ | _ ->
+ fprintf ppf "@[<2>%s of@ %a@]" name
+ (print_typlist print_simple_out_type " *") tyl end
+ | Some ret_type ->
+ begin match tyl with
+ | [] -> fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type ret_type (* GAH: IS THIS CORRECT? *)
+ | _ ->
+ fprintf ppf "@[<2>%s :@ %a -> %a@]" name
+ (print_typlist print_simple_out_type " *") tyl print_simple_out_type ret_type end
+
+
and print_out_label ppf (name, mut, arg) =
fprintf ppf "@[<2>%s%s :@ %a@];" (if mut then "mutable " else "") name
!out_type arg
diff --git a/typing/outcometree.mli b/typing/outcometree.mli
index 80c28ea08..490c6e089 100644
--- a/typing/outcometree.mli
+++ b/typing/outcometree.mli
@@ -54,7 +54,7 @@ type out_type =
| Otyp_object of (string * out_type) list * bool option
| Otyp_record of (string * bool * out_type) list
| Otyp_stuff of string
- | Otyp_sum of (string * out_type list) list
+ | Otyp_sum of (string * out_type list * out_type option) list (* GAH: was right thing to do? *)
| Otyp_tuple of out_type list
| Otyp_var of bool * string
| Otyp_variant of
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index d73f79af6..266d42795 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -132,6 +132,9 @@ let rec get_type_descr ty tenv =
let rec get_constr tag ty tenv =
match get_type_descr ty tenv with
| {type_kind=Type_variant constr_list} ->
+ let gen_variants lst = List.map (fun (a,b) -> (a,b,None)) lst in
+ Datarepr.find_constr_by_tag tag (gen_variants constr_list)
+ | {type_kind=Type_generalized_variant constr_list} ->
Datarepr.find_constr_by_tag tag constr_list
| {type_manifest = Some _} ->
get_constr tag (Ctype.expand_head_once tenv (clean_copy ty)) tenv
@@ -162,7 +165,7 @@ let get_constr_name tag ty tenv = match tag with
| Cstr_exception path -> Path.name path
| _ ->
try
- let name,_ = get_constr tag ty tenv in name
+ let name,_,_ = get_constr tag ty tenv in name
with
| Datarepr.Constr_not_found -> "*Unknown constructor*"
@@ -715,13 +718,19 @@ let complete_constrs p all_tags = match p.pat_desc with
let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
List.map
(fun tag ->
- let _,targs = get_constr tag p.pat_type p.pat_env in
+ let _,targs,ret_type_opt = get_constr tag p.pat_type p.pat_env in (* GAH: is this correct? don't forget the existentials! *)
+ let ret_type =
+ match ret_type_opt with
+ | None -> c.cstr_res
+ | Some ret_type -> ret_type
+ in
{c with
- cstr_tag = tag ;
- cstr_args = targs ;
- cstr_arity = List.length targs})
+ cstr_res = ret_type ;
+ cstr_tag = tag ;
+ cstr_args = targs ;
+ cstr_arity = List.length targs})
not_tags
-with
+ with
| Datarepr.Constr_not_found ->
fatal_error "Parmatch.complete_constr: constr_not_found"
end
diff --git a/typing/predef.ml b/typing/predef.ml
index 728eb5729..4b722a40f 100644
--- a/typing/predef.ml
+++ b/typing/predef.ml
@@ -95,7 +95,7 @@ let build_initial_env add_type add_exception empty_env =
and decl_bool =
{type_params = [];
type_arity = 0;
- type_kind = Type_variant(["false", []; "true", []]);
+ type_kind = Type_variant(["false", []; "true", []]); (* GAH: HOW DO I DEFINE THE BASIC BOOL TYPE? *)
type_private = Public;
type_manifest = None;
type_variance = []}
@@ -126,7 +126,7 @@ let build_initial_env add_type add_exception empty_env =
{type_params = [tvar];
type_arity = 1;
type_kind =
- Type_variant(["[]", []; "::", [tvar; type_list tvar]]);
+ Type_variant(["[]", []; "::", [tvar; type_list tvar]]); (* GAH: IS THIS CORRECT? *)
type_private = Public;
type_manifest = None;
type_variance = [true, false, false]}
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index 76537b807..479ee0c31 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -534,8 +534,17 @@ let rec tree_of_type_decl id decl =
begin match decl.type_kind with
| Type_abstract -> ()
| Type_variant [] -> ()
+ | Type_generalized_variant cstrs ->
+ List.iter
+ (fun (_, args,ret_type_opt) ->
+ List.iter mark_loops args;
+ may mark_loops ret_type_opt)
+ cstrs
| Type_variant cstrs ->
- List.iter (fun (_, args) -> List.iter mark_loops args) cstrs
+ List.iter
+ (fun (_, args) ->
+ List.iter mark_loops args)
+ cstrs
| Type_record(l, rep) ->
List.iter (fun (_, _, ty) -> mark_loops ty) l
end;
@@ -550,7 +559,7 @@ let rec tree_of_type_decl id decl =
match decl.type_kind with
Type_abstract ->
decl.type_manifest = None || decl.type_private = Private
- | Type_variant _ | Type_record _ ->
+ | Type_variant _ | Type_generalized_variant _ | Type_record _ ->
decl.type_private = Private
in
let vari =
@@ -581,14 +590,25 @@ let rec tree_of_type_decl id decl =
| Type_variant cstrs ->
tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)),
decl.type_private
+ | Type_generalized_variant cstrs ->
+ tree_of_manifest (Otyp_sum (List.map tree_of_generalized_constructor cstrs)),
+ decl.type_private
| Type_record(lbls, rep) ->
tree_of_manifest (Otyp_record (List.map tree_of_label lbls)),
decl.type_private
in
(name, args, ty, priv, constraints)
+and tree_of_generalized_constructor (name, args,ret_type_opt) =
+ (name, tree_of_typlist false args,tree_of_constructor_ret ret_type_opt)
+
and tree_of_constructor (name, args) =
- (name, tree_of_typlist false args)
+ (name, tree_of_typlist false args,None)
+
+and tree_of_constructor_ret =
+ function
+ | None -> None
+ | Some ret_type -> Some (tree_of_typexp false ret_type) (* GAH: WHY FALSE?? *)
and tree_of_label (name, mut, arg) =
(name, mut = Mutable, tree_of_typexp false arg)
diff --git a/typing/subst.ml b/typing/subst.ml
index 6aa276606..48956f9fd 100644
--- a/typing/subst.ml
+++ b/typing/subst.ml
@@ -168,18 +168,30 @@ let type_declaration s decl =
Type_abstract -> Type_abstract
| Type_variant cstrs ->
Type_variant(
- List.map (fun (n, args) -> (n, List.map (typexp s) args))
- cstrs)
+ List.map (fun (n, args) ->
+ (n, List.map (typexp s) args)) (* GAH: WHAT DOES typexp DO? *)
+ cstrs)
+ | Type_generalized_variant cstrs ->
+ Type_generalized_variant(
+ List.map (fun (n, args,ret_type_opt) ->
+ let ret_type_opt =
+ Misc.may_map (typexp s) ret_type_opt
+ in
+ (n, List.map (typexp s) args,ret_type_opt)) (* GAH: WHAT DOES typexp DO? *)
+ cstrs)
| Type_record(lbls, rep) ->
Type_record(
List.map (fun (n, mut, arg) -> (n, mut, typexp s arg))
lbls,
rep)
end;
+
type_manifest =
- begin match decl.type_manifest with
- None -> None
- | Some ty -> Some(typexp s ty)
+
+ begin
+ match decl.type_manifest with
+ None -> None
+ | Some ty -> Some(typexp s ty)
end;
type_private = decl.type_private;
type_variance = decl.type_variance;
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 90c33f9b2..c41912043 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -70,6 +70,12 @@ let type_module =
let type_open =
ref (fun _ -> assert false)
+(*let print_local_unifier ?(s="") () =
+ Format.fprintf Format.std_formatter "%s local_unifier:\n[%a]\n%!" s
+ (fun ppf lst -> List.iter (fun (t,t') -> Format.fprintf ppf "%a = %a;" Printtyp.raw_type_expr t Printtyp.raw_type_expr t') lst)
+ (get_local_unifier ())
+;;
+*)
(* Forward declaration, to be filled in by Typeclass.class_structure *)
let type_object =
@@ -83,11 +89,11 @@ let type_object =
called each time we create a record of type [Typedtree.expression]
or [Typedtree.pattern] that will end up in the typed AST.
*)
-let re node =
+let re node =
Stypes.record (Stypes.Ti_expr node);
node
;;
-let rp node =
+let rp node =
Stypes.record (Stypes.Ti_pat node);
node
;;
@@ -106,25 +112,25 @@ let type_constant = function
(* Specific version of type_option, using newty rather than newgenty *)
-let type_option ty =
+let type_option ty =
newty (Tconstr(Predef.path_option,[ty], ref Mnil))
-let option_none ty loc =
+let option_none ty loc =
let cnone = Env.lookup_constructor (Longident.Lident "None") Env.initial in
{ exp_desc = Texp_construct(cnone, []);
exp_type = ty; exp_loc = loc; exp_env = Env.initial }
-let option_some texp =
+let option_some texp =
let csome = Env.lookup_constructor (Longident.Lident "Some") Env.initial in
{ exp_desc = Texp_construct(csome, [texp]); exp_loc = texp.exp_loc;
exp_type = type_option texp.exp_type; exp_env = texp.exp_env }
-let extract_option_type env ty =
+let extract_option_type env 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 sexp env ty =
+let rec extract_label_names sexp env ty =
let ty = repr ty in
match ty.desc with
| Tconstr (path, _, _) ->
@@ -142,7 +148,7 @@ let rec extract_label_names sexp env ty =
(* Typing of patterns *)
(* Creating new conjunctive types is not allowed when typing patterns *)
-let unify_pat env pat expected_ty =
+let unify_pat env pat expected_ty =
try
unify env pat.pat_type expected_ty
with
@@ -152,7 +158,7 @@ let unify_pat env pat expected_ty =
raise(Typetexp.Error(pat.pat_loc, Typetexp.Variant_tags (l1, l2)))
(* make all Reither present in open variants *)
-let finalize_variant pat =
+let finalize_variant pat =
match pat.pat_desc with
Tpat_variant(tag, opat, r) ->
let row =
@@ -179,11 +185,11 @@ let finalize_variant pat =
row_bound=(); row_fixed=false; row_name=None})); *)
| _ -> ()
-let rec iter_pattern f p =
+let rec iter_pattern f p =
f p;
iter_pattern_desc (iter_pattern f) p.pat_desc
-let has_variants p =
+let has_variants p =
try
iter_pattern (function {pat_desc=Tpat_variant _} -> raise Exit | _ -> ())
p;
@@ -196,13 +202,13 @@ let has_variants p =
let pattern_variables = ref ([]: (Ident.t * type_expr * Location.t) list)
let pattern_force = ref ([] : (unit -> unit) list)
let pattern_scope = ref (None : Annot.ident option);;
-let reset_pattern scope =
+let reset_pattern scope =
pattern_variables := [];
pattern_force := [];
pattern_scope := scope;
;;
-let enter_variable loc name ty =
+let enter_variable loc name ty =
if List.exists (fun (id, _, _) -> Ident.name id = name) !pattern_variables
then raise(Error(loc, Multiply_bound_variable name));
let id = Ident.create name in
@@ -213,18 +219,18 @@ let enter_variable loc name ty =
end;
id
-let sort_pattern_variables vs =
+let sort_pattern_variables vs =
List.sort
(fun (x,_,_) (y,_,_) -> Pervasives.compare (Ident.name x) (Ident.name y))
vs
-let enter_orpat_variables loc env p1_vs p2_vs =
+let enter_orpat_variables loc env p1_vs p2_vs =
(* unify_vars operate on sorted lists *)
let p1_vs = sort_pattern_variables p1_vs
and p2_vs = sort_pattern_variables p2_vs in
- let rec unify_vars p1_vs p2_vs = match p1_vs, p2_vs with
+ let rec unify_vars p1_vs p2_vs = match p1_vs, p2_vs with
| (x1,t1,l1)::rem1, (x2,t2,l2)::rem2 when Ident.equal x1 x2 ->
if x1==x2 then
unify_vars rem1 rem2
@@ -247,7 +253,7 @@ let enter_orpat_variables loc env p1_vs p2_vs =
raise (Error (loc, Orpat_vars min_var)) in
unify_vars p1_vs p2_vs
-let rec build_as_type env p =
+let rec build_as_type env p =
match p.pat_desc with
Tpat_alias(p1, _) -> build_as_type env p1
| Tpat_tuple pl ->
@@ -270,7 +276,7 @@ let rec build_as_type env p =
if lbl.lbl_private = Private then p.pat_type else
let ty = newvar () in
let ppl = List.map (fun (l,p) -> l.lbl_pos, p) lpl in
- let do_label lbl =
+ let do_label lbl =
let _, ty_arg, ty_res = instance_label false lbl in
unify_pat env {p with pat_type = ty} ty_res;
let refinable =
@@ -299,7 +305,7 @@ let rec build_as_type env p =
| Tpat_any | Tpat_var _ | Tpat_constant _
| Tpat_array _ | Tpat_lazy _ -> p.pat_type
-let build_or_pat env loc lid =
+let build_or_pat env loc lid =
let path, decl = Typetexp.find_type env loc lid
in
let tyl = List.map (fun _ -> newvar()) decl.type_params in
@@ -345,12 +351,12 @@ let build_or_pat env loc lid =
pat pats in
rp { r with pat_loc = loc }
-let rec find_record_qual = function
+let rec find_record_qual = function
| [] -> None
| (Longident.Ldot (modname, _), _) :: _ -> Some modname
| _ :: rest -> find_record_qual rest
-let type_label_a_list type_lid_a lid_a_list =
+let type_label_a_list type_lid_a lid_a_list =
match find_record_qual lid_a_list with
| None -> List.map type_lid_a lid_a_list
| Some modname ->
@@ -364,7 +370,7 @@ let type_label_a_list type_lid_a lid_a_list =
(* Checks over the labels mentioned in a record pattern:
no duplicate definitions (error); properly closed (warning) *)
-let check_recordpat_labels loc lbl_pat_list closed =
+let check_recordpat_labels loc lbl_pat_list closed =
match lbl_pat_list with
| [] -> () (* should not happen *)
| (label1, _) :: _ ->
@@ -391,18 +397,19 @@ let check_recordpat_labels loc lbl_pat_list closed =
(* Typing of patterns *)
-let rec type_pat env sp =
+let rec type_pat env sp expected_ty =
let loc = sp.ppat_loc in
match sp.ppat_desc with
- Ppat_any ->
+ |Ppat_any ->
rp {
pat_desc = Tpat_any;
pat_loc = loc;
- pat_type = newvar();
+ pat_type = expected_ty;
pat_env = env }
- | Ppat_var name ->
+ |Ppat_var name ->
let ty = newvar() in
- let id = enter_variable loc name ty in
+ let id = enter_variable loc name ty in (* GAH : what does this do? *)
+ unify env ty expected_ty;
rp {
pat_desc = Tpat_var id;
pat_loc = loc;
@@ -414,7 +421,7 @@ let rec type_pat env sp =
let ty, force = Typetexp.transl_simple_type_delayed env sty in
pattern_force := force :: !pattern_force;
begin match ty.desc with
- | Tpoly (body, tyl) ->
+ |Tpoly (body, tyl) ->
begin_def ();
let _, ty' = instance_poly false tyl body in
end_def ();
@@ -426,8 +433,8 @@ let rec type_pat env sp =
pat_env = env }
| _ -> assert false
end
- | Ppat_alias(sq, name) ->
- let q = type_pat env sq in
+ |Ppat_alias(sq, name) ->
+ let q = type_pat env sq expected_ty in (* GAH: no idea *)
begin_def ();
let ty_var = build_as_type env q in
end_def ();
@@ -438,20 +445,24 @@ let rec type_pat env sp =
pat_loc = loc;
pat_type = q.pat_type;
pat_env = env }
- | Ppat_constant cst ->
+ |Ppat_constant cst ->
+ (* GAH: dunno what to do here *)
+ unify env expected_ty (type_constant cst);
rp {
pat_desc = Tpat_constant cst;
pat_loc = loc;
- pat_type = type_constant cst;
+ pat_type = expected_ty; (*type_constant cst;*)
pat_env = env }
- | Ppat_tuple spl ->
- let pl = List.map (type_pat env) spl in
+ |Ppat_tuple spl ->
+ let spl_ann = List.map (fun p -> (p,newvar ())) spl in
+ let pl = List.map (fun (p,t) -> type_pat env p t) spl_ann in
+ unify env expected_ty (newty (Ttuple(List.map snd spl_ann)));
rp {
pat_desc = Tpat_tuple pl;
pat_loc = loc;
- pat_type = newty (Ttuple(List.map (fun p -> p.pat_type) pl));
+ pat_type = expected_ty;
pat_env = env }
- | Ppat_construct(lid, sarg, explicit_arity) ->
+ |Ppat_construct(lid, sarg, explicit_arity) ->
let constr = Typetexp.find_constructor env loc lid in
let sargs =
match sarg with
@@ -461,22 +472,22 @@ let rec type_pat env sp =
| Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 ->
if constr.cstr_arity = 0 then
Location.prerr_warning sp.ppat_loc
- Warnings.Wildcard_arg_to_constant_constr;
+ Warnings.Wildcard_arg_to_constant_constr; (* GAH : why is this a warning ? *)
replicate_list sp constr.cstr_arity
| Some sp -> [sp] in
if List.length sargs <> constr.cstr_arity then
raise(Error(loc, Constructor_arity_mismatch(lid,
constr.cstr_arity, List.length sargs)));
- let args = List.map (type_pat env) sargs in
let (ty_args, ty_res) = instance_constructor constr in
- List.iter2 (unify_pat env) args ty_args;
+ unify env expected_ty ty_res;
+ let args: Typedtree.pattern list = List.map2 (fun p t -> type_pat env p t) sargs ty_args in (* GAH : might be wrong *)
rp {
pat_desc = Tpat_construct(constr, args);
pat_loc = loc;
pat_type = ty_res;
pat_env = env }
- | Ppat_variant(l, sarg) ->
- let arg = may_map (type_pat env) sarg in
+ |Ppat_variant(l, sarg) ->
+ let arg = may_map (fun p -> type_pat env p (newvar())) sarg in (* GAH: this is certainly false *)
let arg_type = match arg with None -> [] | Some arg -> [arg.pat_type] in
let row = { row_fields =
[l, Reither(arg = None, arg_type, true, ref None)];
@@ -490,8 +501,8 @@ let rec type_pat env sp =
pat_loc = loc;
pat_type = newty (Tvariant row);
pat_env = env }
- | Ppat_record(lid_sp_list, closed) ->
- let ty = newvar() in
+ |Ppat_record(lid_sp_list, closed) ->
+ let ty = expected_ty in
let type_label_pat (lid, sarg) =
let label = Typetexp.find_label env loc lid in
begin_def ();
@@ -502,13 +513,12 @@ let rec type_pat env sp =
with Unify trace ->
raise(Error(loc, Label_mismatch(lid, trace)))
end;
- let arg = type_pat env sarg in
- unify_pat env arg ty_arg;
+ let arg = type_pat env sarg ty_arg in
if vars <> [] then begin
end_def ();
generalize ty_arg;
List.iter generalize vars;
- let instantiated tv =
+ let instantiated tv =
let tv = expand_head env tv in
tv.desc <> Tvar || tv.level <> generic_level in
if List.exists instantiated vars then
@@ -523,21 +533,23 @@ let rec type_pat env sp =
pat_loc = loc;
pat_type = ty;
pat_env = env }
- | Ppat_array spl ->
- let pl = List.map (type_pat env) spl in
+ |Ppat_array spl ->
let ty_elt = newvar() in
- List.iter (fun p -> unify_pat env p ty_elt) pl;
+ unify env expected_ty (instance (Predef.type_array ty_elt));
+ let spl_ann = List.map (fun p -> (p,newvar())) spl in
+ let pl = List.map (fun (p,t) -> type_pat env p ty_elt) spl_ann in
rp {
pat_desc = Tpat_array pl;
pat_loc = loc;
- pat_type = instance (Predef.type_array ty_elt);
+ pat_type = expected_ty;
pat_env = env }
- | Ppat_or(sp1, sp2) ->
+ |Ppat_or(sp1, sp2) ->
let initial_pattern_variables = !pattern_variables in
- let p1 = type_pat env sp1 in
+ let nv = newvar() in
+ let p1 = type_pat env sp1 nv in (* GAH: so wrong *)
let p1_variables = !pattern_variables in
pattern_variables := initial_pattern_variables ;
- let p2 = type_pat env sp2 in
+ let p2 = type_pat env sp2 nv in (* GAH: again, so wrong *)
let p2_variables = !pattern_variables in
unify_pat env p2 p1.pat_type;
let alpha_env =
@@ -548,26 +560,29 @@ let rec type_pat env sp =
pat_loc = loc;
pat_type = p1.pat_type;
pat_env = env }
- | Ppat_lazy sp1 ->
- let p1 = type_pat env sp1 in
+ |Ppat_lazy sp1 ->
+ let nv = newvar () in
+ unify env expected_ty (instance (Predef.type_lazy_t nv));
+ let p1 = type_pat env sp1 nv in
rp {
pat_desc = Tpat_lazy p1;
pat_loc = loc;
- pat_type = instance (Predef.type_lazy_t p1.pat_type);
+ pat_type = expected_ty;
pat_env = env }
- | Ppat_constraint(sp, sty) ->
- let p = type_pat env sp in
+ |Ppat_constraint(sp, sty) ->
+ let nv = newvar () in
+ let p = type_pat env sp nv in (* GAH: so wrong *)
let ty, force = Typetexp.transl_simple_type_delayed env sty in
unify_pat env p ty;
pattern_force := force :: !pattern_force;
p
- | Ppat_type lid ->
+ |Ppat_type lid ->
build_or_pat env loc lid
-let get_ref r =
+let get_ref r =
let v = !r in r := []; v
-let add_pattern_variables env =
+let add_pattern_variables env =
let pv = get_ref pattern_variables in
List.fold_right
(fun (id, ty, loc) env ->
@@ -576,21 +591,38 @@ let add_pattern_variables env =
)
pv env
-let type_pattern env spat scope =
+
+let type_pattern env spat scope expected_ty =
reset_pattern scope;
- let pat = type_pat env spat in
+
+ let pat = type_pat env spat expected_ty in
+
let new_env = add_pattern_variables env in
+
(pat, new_env, get_ref pattern_force)
-let type_pattern_list env spatl scope =
- reset_pattern scope;
- let patl = List.map (type_pat env) spatl in
- let new_env = add_pattern_variables env in
- (patl, new_env, get_ref pattern_force)
-let type_class_arg_pattern cl_num val_env met_env l spat =
+let type_pattern_list env spatl scope expected_tys =
+
+ reset_local_unifier ();
+ set_unification_type `Pattern;
+ try_finally
+ (fun () ->
+ reset_pattern scope;
+
+ let patl = List.map2 (fun p t -> type_pat env p t) spatl expected_tys in
+ let new_env = add_pattern_variables env in
+
+ (patl, new_env, get_ref pattern_force))
+ (fun () ->
+ set_unification_type `Expression)
+
+let type_class_arg_pattern cl_num val_env met_env l spat =
+
reset_pattern None;
- let pat = type_pat val_env spat in
+ let nv = newvar () in
+ let pat = type_pat val_env spat nv in
+
if has_variants pat then begin
Parmatch.pressure_variants val_env [pat];
iter_pattern finalize_variant pat
@@ -610,15 +642,17 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
let val_env = add_pattern_variables val_env in
(pat, pv, val_env, met_env)
-let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
+let mkpat d = { ppat_desc = d; ppat_loc = Location.none }
-let type_self_pattern cl_num privty val_env met_env par_env spat =
+let type_self_pattern cl_num privty val_env met_env par_env spat =
+
let spat =
mkpat (Ppat_alias (mkpat(Ppat_alias (spat, "selfpat-*")),
"selfpat-" ^ cl_num))
in
reset_pattern None;
- let pat = type_pat val_env spat in
+ let nv = newvar() in
+ let pat = type_pat val_env spat nv in (* GAH: so wrong *)
List.iter (fun f -> f()) (get_ref pattern_force);
let meths = ref Meths.empty in
let vars = ref Vars.empty in
@@ -640,7 +674,7 @@ let delayed_checks = ref []
let reset_delayed_checks () =
delayed_checks := [];
set_free_univars TypeSet.empty (* Hook this here. Better name? *)
-let add_delayed_check f = delayed_checks := f :: !delayed_checks
+let add_delayed_check f = delayed_checks := f :: !delayed_checks
let force_delayed_checks () =
(* checks may change type levels *)
let snap = Btype.snapshot () in
@@ -651,7 +685,7 @@ let force_delayed_checks () =
(* Generalization criterion for expressions *)
-let rec is_nonexpansive exp =
+let rec is_nonexpansive exp =
match exp.exp_desc with
Texp_ident(_,_) -> true
| Texp_constant _ -> true
@@ -696,7 +730,7 @@ let rec is_nonexpansive exp =
is_nonexpansive_mod mexp
| _ -> false
-and is_nonexpansive_mod mexp =
+and is_nonexpansive_mod mexp =
match mexp.mod_desc with
| Tmod_ident _ -> true
| Tmod_functor _ -> true
@@ -730,35 +764,35 @@ external string_to_format :
external format_to_string :
('a, 'b, 'c, 'd, 'e, 'f) format6 -> string = "%identity"
-let type_format loc fmt =
+let type_format loc fmt =
- let ty_arrow gty ty = newty (Tarrow ("", instance gty, ty, Cok)) in
+ let ty_arrow gty ty = newty (Tarrow ("", instance gty, ty, Cok)) in
- let bad_conversion fmt i c =
+ let bad_conversion fmt i c =
raise (Error (loc, Bad_conversion (fmt, i, c))) in
- let incomplete_format fmt =
+ let incomplete_format fmt =
raise (Error (loc, Incomplete_format fmt)) in
- let range_closing_index fmt i =
+ let range_closing_index fmt i =
let len = String.length fmt in
- let find_closing j =
+ let find_closing j =
if j >= len then incomplete_format fmt else
try String.index_from fmt j ']' with
| Not_found -> incomplete_format fmt in
- let skip_pos j =
+ let skip_pos j =
if j >= len then incomplete_format fmt else
match fmt.[j] with
| ']' -> find_closing (j + 1)
| c -> find_closing j in
- let rec skip_neg j =
+ let rec skip_neg j =
if j >= len then incomplete_format fmt else
match fmt.[j] with
| '^' -> skip_pos (j + 1)
| c -> skip_pos j in
find_closing (skip_neg (i + 1)) in
- let rec type_in_format fmt =
+ let rec type_in_format fmt =
let len = String.length fmt in
@@ -769,7 +803,7 @@ let type_format loc fmt =
let meta = ref 0 in
- let rec scan_format i =
+ let rec scan_format i =
if i >= len then
if !meta = 0
then ty_uresult, ty_result
@@ -777,24 +811,24 @@ let type_format loc fmt =
match fmt.[i] with
| '%' -> scan_opts i (i + 1)
| _ -> scan_format (i + 1)
- and scan_opts i j =
+ and scan_opts i j =
if j >= len then incomplete_format fmt else
match fmt.[j] with
| '_' -> scan_rest true i (j + 1)
| _ -> scan_rest false i j
- and scan_rest skip i j =
- let rec scan_flags i j =
+ and scan_rest skip i j =
+ let rec scan_flags i j =
if j >= len then incomplete_format fmt else
match fmt.[j] with
| '#' | '0' | '-' | ' ' | '+' -> scan_flags i (j + 1)
| _ -> scan_width i j
- and scan_width i j = scan_width_or_prec_value scan_precision i j
- and scan_decimal_string scan i j =
+ and scan_width i j = scan_width_or_prec_value scan_precision i j
+ and scan_decimal_string scan i j =
if j >= len then incomplete_format fmt else
match fmt.[j] with
| '0' .. '9' -> scan_decimal_string scan i (j + 1)
| _ -> scan i j
- and scan_width_or_prec_value scan i j =
+ and scan_width_or_prec_value scan i j =
if j >= len then incomplete_format fmt else
match fmt.[j] with
| '*' ->
@@ -802,28 +836,28 @@ let type_format loc fmt =
ty_uresult, ty_arrow Predef.type_int ty_result
| '-' | '+' -> scan_decimal_string scan i (j + 1)
| _ -> scan_decimal_string scan i j
- and scan_precision i j =
+ and scan_precision i j =
if j >= len then incomplete_format fmt else
match fmt.[j] with
| '.' -> scan_width_or_prec_value scan_conversion i (j + 1)
| _ -> scan_conversion i j
- and conversion j ty_arg =
+ and conversion j ty_arg =
let ty_uresult, ty_result = scan_format (j + 1) in
ty_uresult,
if skip then ty_result else ty_arrow ty_arg ty_result
- and conversion_a j ty_e ty_arg =
+ and conversion_a j ty_e ty_arg =
let ty_uresult, ty_result = conversion j ty_arg in
let ty_a = ty_arrow ty_input (ty_arrow ty_e ty_aresult) in
ty_uresult, ty_arrow ty_a ty_result
- and conversion_r j ty_e ty_arg =
+ and conversion_r j ty_e ty_arg =
let ty_uresult, ty_result = conversion j ty_arg in
let ty_r = ty_arrow ty_input ty_e in
ty_arrow ty_r ty_uresult, ty_result
- and scan_conversion i j =
+ and scan_conversion i j =
if j >= len then incomplete_format fmt else
match fmt.[j] with
| '%' | '!' | ',' -> scan_format (j + 1)
@@ -898,7 +932,7 @@ let type_format loc fmt =
(* Approximate the type of an expression, for better recursion *)
-let rec approx_type env sty =
+let rec approx_type env sty =
match sty.ptyp_desc with
Ptyp_arrow (p, _, sty) ->
let ty1 = if is_optional p then type_option (newvar ()) else newvar () in
@@ -917,7 +951,7 @@ let rec approx_type env sty =
approx_type env sty
| _ -> newvar ()
-let rec type_approx env sexp =
+let rec type_approx env sexp =
match sexp.pexp_desc with
Pexp_let (_, _, e) -> type_approx env e
| Pexp_function (p,_,(_,e)::_) when is_optional p ->
@@ -944,7 +978,7 @@ let rec type_approx env sexp =
| _ -> newvar ()
(* List labels in a function type, and whether return type is a variable *)
-let rec list_labels_aux env visited ls ty_fun =
+let rec list_labels_aux env visited ls ty_fun =
let ty = expand_head env ty_fun in
if List.memq ty visited then
List.rev ls, false
@@ -954,10 +988,10 @@ let rec list_labels_aux env visited ls ty_fun =
| _ ->
List.rev ls, ty.desc = Tvar
-let list_labels env ty = list_labels_aux env [] [] ty
+let list_labels env ty = list_labels_aux env [] [] ty
(* Check that all univars are safe in a type *)
-let check_univars env expans kind exp ty_expected vars =
+let check_univars env expans kind exp ty_expected vars =
if expans && not (is_nonexpansive exp) then
generalize_expansive env exp.exp_type;
(* need to expand twice? cf. Ctype.unify2 *)
@@ -976,8 +1010,9 @@ let check_univars env expans kind exp ty_expected vars =
raise (Error (exp.exp_loc,
Less_general(kind, [ty, ty; ty_expected, ty_expected])))
+
(* Check that a type is not a function *)
-let check_application_result env statement exp =
+let check_application_result env statement exp =
let loc = exp.exp_loc in
match (expand_head env exp.exp_type).desc with
| Tarrow _ ->
@@ -989,8 +1024,8 @@ let check_application_result env statement exp =
Location.prerr_warning loc Warnings.Statement_type
(* Check that a type is generalizable at some level *)
-let generalizable level ty =
- let rec check ty =
+let generalizable level ty =
+ let rec check ty =
let ty = repr ty in
if ty.level < lowest_level then () else
if ty.level <= level then raise Exit else
@@ -1003,7 +1038,7 @@ let generalizable level ty =
let self_coercion = ref ([] : (Path.t * Location.t list ref) list)
(* Helpers for packaged modules. *)
-let create_package_type loc env (p, l) =
+let create_package_type loc env (p, l) =
let s = !Typetexp.transl_modtype_longident loc env p in
newty (Tpackage (s,
List.map fst l,
@@ -1011,7 +1046,7 @@ let create_package_type loc env (p, l) =
(* Typing of expressions *)
-let unify_exp env exp expected_ty =
+let unify_exp env exp expected_ty =
(* Format.eprintf "@[%a@ %a@]@." Printtyp.raw_type_expr exp.exp_type
Printtyp.raw_type_expr expected_ty; *)
try
@@ -1022,14 +1057,14 @@ let unify_exp env exp expected_ty =
| Tags(l1,l2) ->
raise(Typetexp.Error(exp.exp_loc, Typetexp.Variant_tags (l1, l2)))
-let rec type_exp env sexp =
+let rec type_exp env sexp =
let loc = sexp.pexp_loc in
match sexp.pexp_desc with
| Pexp_ident lid ->
begin
if !Clflags.annotations then begin
try let (path, annot) = Env.lookup_annot lid env in
- let rec name_of_path = function
+ let rec name_of_path = function
| Path.Pident id -> Ident.name id
| Path.Pdot(p, s, pos) ->
if Oprint.parenthesized_ident s then
@@ -1078,7 +1113,7 @@ let rec type_exp env sexp =
| Default -> None
in
let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list scp in
- let body = type_exp new_env sbody in
+ let body = type_exp new_env sbody in
re {
exp_desc = Texp_let(rec_flag, pat_exp_list, body);
exp_loc = loc;
@@ -1094,7 +1129,7 @@ let rec type_exp env sexp =
end_def ();
generalize_structure funct.exp_type
end;
- let rec lower_args seen ty_fun =
+ let rec lower_args seen ty_fun =
let ty = expand_head env ty_fun in
if List.memq ty seen then () else
match ty.desc with
@@ -1118,9 +1153,12 @@ let rec type_exp env sexp =
| Pexp_match(sarg, caselist) ->
let arg = type_exp env sarg in
let ty_res = newvar() in
+ Format.fprintf Format.std_formatter " match type before type_cases_gadt : %a\n%! " Printtyp.raw_type_expr ty_res ;
let cases, partial =
- type_cases env arg.exp_type ty_res (Some loc) caselist
+ type_cases_gadt env arg.exp_type ty_res (Some loc) caselist
in
+
+ Format.fprintf Format.std_formatter " match type : %a\n%! " Printtyp.raw_type_expr ty_res ;
re {
exp_desc = Texp_match(arg, cases, partial);
exp_loc = loc;
@@ -1162,7 +1200,7 @@ let rec type_exp env sexp =
let ty = newvar () in
let lbl_exp_list =
type_label_a_list (type_label_exp true env loc ty) lid_sexp_list in
- let rec check_duplicates seen_pos lid_sexp lbl_exp =
+ let rec check_duplicates seen_pos lid_sexp lbl_exp =
match (lid_sexp, lbl_exp) with
((lid, _) :: rem1, (lbl, _) :: rem2) ->
if List.mem lbl.lbl_pos seen_pos
@@ -1175,7 +1213,7 @@ let rec type_exp env sexp =
None, _ -> None
| Some sexp, (lbl, _) :: _ ->
let ty_exp = newvar () in
- let unify_kept lbl =
+ let unify_kept lbl =
if List.for_all (fun (lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
lbl_exp_list
then begin
@@ -1196,7 +1234,7 @@ let rec type_exp env sexp =
let present_indices =
List.map (fun (lbl, _) -> lbl.lbl_pos) lbl_exp_list in
let label_names = extract_label_names sexp env ty in
- let rec missing_labels n = function
+ let rec missing_labels n = function
[] -> []
| lbl :: rem ->
if List.mem n present_indices then missing_labels (n + 1) rem
@@ -1611,7 +1649,7 @@ let rec type_exp env sexp =
let body = type_exp new_env sbody in
(* Replace every instance of this type constructor in the resulting type. *)
let seen = Hashtbl.create 8 in
- let rec replace t =
+ let rec replace t =
if Hashtbl.mem seen t.id then ()
else begin
Hashtbl.add seen t.id ();
@@ -1641,7 +1679,7 @@ let rec type_exp env sexp =
| Pexp_open (lid, e) ->
type_exp (!type_open env sexp.pexp_loc lid) e
-and type_label_exp create env loc ty (lid, sarg) =
+and type_label_exp create env loc ty (lid, sarg) =
let label = Typetexp.find_label env sarg.pexp_loc lid in
begin_def ();
if !Clflags.principal then begin_def ();
@@ -1683,9 +1721,9 @@ and type_label_exp create env loc ty (lid, sarg) =
in
(label, {arg with exp_type = instance arg.exp_type})
-and type_argument env sarg ty_expected' =
+and type_argument env sarg ty_expected' =
(* ty_expected' may be generic *)
- let no_labels ty =
+ let no_labels ty =
let ls, tvar = list_labels env ty in
not tvar && List.for_all ((=) "") ls
in
@@ -1702,7 +1740,7 @@ and type_argument env sarg ty_expected' =
end_def ();
generalize_structure texp.exp_type
end;
- let rec make_args args ty_fun =
+ let rec make_args args ty_fun =
match (expand_head env ty_fun).desc with
| Tarrow (l,ty_arg,ty_fun,_) when is_optional l ->
make_args
@@ -1726,7 +1764,7 @@ and type_argument env sarg ty_expected' =
unify_exp env {texp with exp_type = ty_fun} ty_expected;
if args = [] then texp else
(* eta-expand to avoid side effects *)
- let var_pair name ty =
+ let var_pair name ty =
let id = Ident.create name in
{pat_desc = Tpat_var id; pat_type = ty;
pat_loc = Location.none; pat_env = env},
@@ -1734,7 +1772,7 @@ and type_argument env sarg ty_expected' =
Texp_ident(Path.Pident id,{val_type = ty; val_kind = Val_reg})}
in
let eta_pat, eta_var = var_pair "eta" ty_arg in
- let func texp =
+ let func texp =
{ texp with exp_type = ty_fun; exp_desc =
Texp_function([eta_pat, {texp with exp_type = ty_res; exp_desc =
Texp_apply (texp, args@
@@ -1751,19 +1789,19 @@ and type_argument env sarg ty_expected' =
| _ ->
type_expect env sarg ty_expected
-and type_application env funct sargs =
+and type_application env funct sargs =
(* funct.exp_type may be generic *)
- let result_type omitted ty_fun =
+ let result_type omitted ty_fun =
List.fold_left
(fun ty_fun (l,ty,lv) -> newty2 lv (Tarrow(l,ty,ty_fun,Cok)))
ty_fun omitted
in
- let has_label l ty_fun =
+ let has_label l ty_fun =
let ls, tvar = list_labels env ty_fun in
tvar || List.mem l ls
in
let ignored = ref [] in
- let rec type_unknown_args args omitted ty_fun = function
+ let rec type_unknown_args args omitted ty_fun = function
[] ->
(List.map
(function None, x -> None, x | Some f, x -> Some (f ()), x)
@@ -1825,11 +1863,11 @@ and type_application env funct sargs =
end
in
let warned = ref false in
- let rec type_args args omitted ty_fun ty_old sargs more_sargs =
+ let rec type_args args omitted ty_fun ty_old sargs more_sargs =
match expand_head env ty_fun with
{desc=Tarrow (l, ty, ty_fun, com); level=lv} as ty_fun'
when (sargs <> [] || more_sargs <> []) && commu_repr com = Cok ->
- let may_warn loc w =
+ let may_warn loc w =
if not !warned && !Clflags.principal && lv <> generic_level
then begin
warned := true;
@@ -1924,7 +1962,7 @@ and type_application env funct sargs =
else
type_args [] [] ty ty sargs []
-and type_construct env loc lid sarg explicit_arity ty_expected =
+and type_construct env loc lid sarg explicit_arity ty_expected =
let constr = Typetexp.find_constructor env loc lid in
let sargs =
match sarg with
@@ -1979,7 +2017,7 @@ and type_expect ?in_function env sexp ty_expected =
type_construct env loc lid sarg explicit_arity ty_expected
| Pexp_let(rec_flag, spat_sexp_list, sbody) ->
let (pat_exp_list, new_env) = type_let env rec_flag spat_sexp_list None in
- let body = type_expect new_env sbody ty_expected in
+ let body = type_expect new_env sbody ty_expected in
re {
exp_desc = Texp_let(rec_flag, pat_exp_list, body);
exp_loc = loc;
@@ -2064,7 +2102,7 @@ and type_expect ?in_function env sexp ty_expected =
let cases, partial =
type_cases ~in_function:(loc_fun,ty_fun) env ty_arg ty_res
(Some loc) caselist in
- let not_function ty =
+ let not_function ty =
let ls, tvar = list_labels env ty in
ls = [] && not tvar
in
@@ -2091,7 +2129,7 @@ and type_expect ?in_function env sexp ty_expected =
let ty = Typetexp.transl_simple_type env false sty in
repr ty
in
- let set_type ty =
+ let set_type ty =
unify_exp env
{ exp_desc = Texp_tuple [];
exp_loc = loc;
@@ -2115,6 +2153,19 @@ and type_expect ?in_function env sexp ty_expected =
re { exp with exp_type = ty }
| _ -> assert false
end
+
+ | Pexp_match(sarg, caselist) -> (* GAH : check with garrigue that this is ok *)
+ let arg = type_exp env sarg in
+ let cases, partial =
+ type_cases_gadt env arg.exp_type ty_expected (Some loc) caselist
+ in
+ re {
+ exp_desc = Texp_match(arg, cases, partial);
+ exp_loc = loc;
+ exp_type = ty_expected;
+ exp_env = env }
+
+
| _ ->
let exp = type_exp env sexp in
unify_exp env exp ty_expected;
@@ -2122,7 +2173,7 @@ and type_expect ?in_function env sexp ty_expected =
(* Typing of statements (expressions whose values are discarded) *)
-and type_statement env sexp =
+and type_statement env sexp =
let loc = sexp.pexp_loc in
begin_def();
let exp = type_exp env sexp in
@@ -2148,16 +2199,30 @@ and type_statement env sexp =
(* Typing of match cases *)
-and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
- let ty_arg' = newvar () in
+and type_pattern_gadt env spat scope ty_arg =
+ reset_local_unifier ();
+ set_unification_type `Pattern;
+ try_finally
+ (fun () -> type_pattern env spat scope ty_arg )
+ (fun () -> set_unification_type `Expression)
+
+and type_cases ?in_function ?(gadt=false) env ty_arg ty_res partial_loc caselist =
+(* let ty_arg' = newvar () in *) (* GAH : must ask garrigue about this *)
let pattern_force = ref [] in
- let pat_env_list =
+ let pat_env_list =
List.map
(fun (spat, sexp) ->
let loc = sexp.pexp_loc in
if !Clflags.principal then begin_def ();
let scope = Some (Annot.Idef loc) in
- let (pat, ext_env, force) = type_pattern env spat scope in
+
+ let (pat, ext_env, force) =
+ if gadt then
+ type_pattern_gadt env spat scope ty_arg
+ else
+ type_pattern env spat scope ty_arg
+ in
+ let local_unifier = get_local_unifier () in
pattern_force := force @ !pattern_force;
let pat =
if !Clflags.principal then begin
@@ -2166,26 +2231,35 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
{ pat with pat_type = instance pat.pat_type }
end else pat
in
- unify_pat env pat ty_arg';
- (pat, ext_env))
+
+(* unify_pat env pat ty_arg'; (* GAH: probably wrong. what in the blazes does ty_arg' do?? *)*)
+ (pat, ext_env,local_unifier))
caselist in
(* Check for polymorphic variants to close *)
- let patl = List.map fst pat_env_list in
+
+ let fst3 (a,b,c) = a in
+ let patl = List.map fst3 pat_env_list in
+
if List.exists has_variants patl then begin
Parmatch.pressure_variants env patl;
List.iter (iter_pattern finalize_variant) patl
end;
(* `Contaminating' unifications start here *)
List.iter (fun f -> f()) !pattern_force;
- begin match pat_env_list with [] -> ()
- | (pat, _) :: _ -> unify_pat env pat ty_arg
- end;
+
+(* begin match pat_env_list with [] -> ()
+ | (pat, _) :: _ -> unify_pat env pat ty_arg (* GAH: probably incorrect; check with garrigue. if we readd this code then it doesn't work *)
+ end;*)
let in_function = if List.length caselist = 1 then in_function else None in
let cases =
List.map2
- (fun (pat, ext_env) (spat, sexp) ->
- let exp = type_expect ?in_function ext_env sexp ty_res in
- (pat, exp))
+ (fun (pat, ext_env,local_unifier) (spat, sexp) ->
+ List.iter (fun (t,t') -> t.desc <- Tlink t') local_unifier;
+ try_finally
+ (fun () ->
+ let exp = type_expect ?in_function ext_env sexp ty_res in
+ (pat, exp))
+ (fun () -> List.iter (fun (t,_) -> t.desc <- Tunivar) local_unifier))
pat_env_list caselist
in
let partial =
@@ -2196,13 +2270,18 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
add_delayed_check (fun () -> Parmatch.check_unused env cases);
cases, partial
+and type_cases_gadt ?in_function env ty_arg ty_res partial_loc caselist =
+ type_cases ?in_function ~gadt:true env ty_arg ty_res partial_loc caselist
+
(* Typing of let bindings *)
-and type_let env rec_flag spat_sexp_list scope =
+and type_let env rec_flag spat_sexp_list scope =
+
begin_def();
if !Clflags.principal then begin_def ();
let spatl = List.map (fun (spat, sexp) -> spat) spat_sexp_list in
- let (pat_list, new_env, force) = type_pattern_list env spatl scope in
+ let nvs = List.map (fun _ -> newvar ()) spatl in (* GAH: so wrong *)
+ let (pat_list, new_env, force) = type_pattern_list env spatl scope nvs in
if rec_flag = Recursive then
List.iter2
(fun pat (_, sexp) ->
@@ -2211,7 +2290,7 @@ and type_let env rec_flag spat_sexp_list scope =
| Tpoly (ty, tl) ->
{pat with pat_type = snd (instance_poly false tl ty)}
| _ -> pat
- in unify_pat env pat (type_approx env sexp))
+ in unify_pat env pat (type_approx env sexp))
pat_list spat_sexp_list;
let pat_list =
if !Clflags.principal then begin
@@ -2223,6 +2302,7 @@ and type_let env rec_flag spat_sexp_list scope =
pat_list
end else pat_list in
(* Polymoprhic variant processing *)
+
List.iter
(fun pat ->
if has_variants pat then begin
@@ -2265,13 +2345,13 @@ and type_let env rec_flag spat_sexp_list scope =
(* Typing of toplevel bindings *)
-let type_binding env rec_flag spat_sexp_list scope =
+let type_binding env rec_flag spat_sexp_list scope =
Typetexp.reset_type_variables();
type_let env rec_flag spat_sexp_list scope
(* Typing of toplevel expressions *)
-let type_expression env sexp =
+let type_expression env sexp =
Typetexp.reset_type_variables();
begin_def();
let exp = type_exp env sexp in
@@ -2285,7 +2365,7 @@ let type_expression env sexp =
open Format
open Printtyp
-let report_error ppf = function
+let report_error ppf = function
| Polymorphic_label lid ->
fprintf ppf "@[The record field label %a is polymorphic.@ %s@]"
longident lid "You cannot instantiate it in a pattern."
@@ -2328,7 +2408,7 @@ let report_error ppf = function
"This expression is not a function; it cannot be applied"
end
| Apply_wrong_label (l, ty) ->
- let print_label ppf = function
+ let print_label ppf = function
| "" -> fprintf ppf "without label"
| l ->
fprintf ppf "with label %s%s" (if is_optional l then "" else "~") l
@@ -2342,7 +2422,7 @@ let report_error ppf = function
fprintf ppf "The record field label %a is defined several times"
longident lid
| Label_missing labels ->
- let print_labels ppf = List.iter (fun lbl -> fprintf ppf "@ %s" lbl) in
+ let print_labels ppf = List.iter (fun lbl -> fprintf ppf "@ %s" lbl) in
fprintf ppf "@[<hov>Some record field labels are undefined:%a@]"
print_labels labels
| Label_not_mutable lid ->
diff --git a/typing/typedecl.ml b/typing/typedecl.ml
index bc2986c41..d2531299a 100644
--- a/typing/typedecl.ml
+++ b/typing/typedecl.ml
@@ -145,19 +145,26 @@ let transl_declaration env (name, sdecl) id =
| Ptype_variant cstrs ->
let all_constrs = ref StringSet.empty in
List.iter
- (fun (name, args, loc) ->
+ (fun (name, _, _, loc) ->
if StringSet.mem name !all_constrs then
raise(Error(sdecl.ptype_loc, Duplicate_constructor name));
all_constrs := StringSet.add name !all_constrs)
cstrs;
- if List.length (List.filter (fun (_, args, _) -> args <> []) cstrs)
+ if List.length (List.filter (fun (_, args, _, _) -> args <> []) cstrs) (* GAH: MIGHT BE WRONG *)
> (Config.max_tag + 1) then
raise(Error(sdecl.ptype_loc, Too_many_constructors));
+ if List.for_all (fun (_,_,x,_) -> match x with Some _ -> false | None -> true) cstrs then
Type_variant
(List.map
- (fun (name, args, loc) ->
+ (fun (name, args,_, loc) ->
(name, List.map (transl_simple_type env true) args))
cstrs)
+ else
+ Type_generalized_variant
+ (List.map
+ (fun (name, args,ret_type_opt, loc) ->
+ (name, List.map (transl_simple_type env true) args,may_map (transl_simple_type env true) ret_type_opt))
+ cstrs)
| Ptype_record lbls ->
let all_labels = ref StringSet.empty in
List.iter
@@ -219,7 +226,9 @@ let generalize_decl decl =
Type_abstract ->
()
| Type_variant v ->
- List.iter (fun (_, tyl) -> List.iter Ctype.generalize tyl) v
+ List.iter (fun (_, tyl) -> List.iter Ctype.generalize tyl) v (* GAH: almost sure this is wrong *)
+ | Type_generalized_variant v ->
+ List.iter (fun (_, tyl,ret_type_opt) -> List.iter Ctype.generalize tyl; may Ctype.generalize ret_type_opt) v (* GAH: almost sure this is wrong *)
| Type_record(r, rep) ->
List.iter (fun (_, _, ty) -> Ctype.generalize ty) r
end;
@@ -261,24 +270,36 @@ let rec check_constraints_rec env loc visited ty =
let check_constraints env (_, sdecl) (_, decl) =
let visited = ref TypeSet.empty in
- begin match decl.type_kind with
- | Type_abstract -> ()
- | Type_variant l ->
+ let process_variants l =
let rec find_pl = function
Ptype_variant pl -> pl
| Ptype_record _ | Ptype_abstract -> assert false
in
let pl = find_pl sdecl.ptype_kind in
List.iter
- (fun (name, tyl) ->
- let styl =
- try let (_,sty,_) = List.find (fun (n,_,_) -> n = name) pl in sty
+ (fun (name, tyl,ret_type_opt) -> (* GAH: again, no idea *)
+ let styl,sret_type_opt =
+ try let (_,sty,ret_type_opt (* added by me *) ,_) = List.find (fun (n,_,_,_) -> n = name) pl in sty,ret_type_opt (* GAH: lord, I have no idea what this is about *)
with Not_found -> assert false in
List.iter2
(fun sty ty ->
check_constraints_rec env sty.ptyp_loc visited ty)
- styl tyl)
- l
+ styl tyl;
+ match sret_type_opt,ret_type_opt with
+ | Some sr,Some r ->
+ check_constraints_rec env sr.ptyp_loc visited r
+ | _ ->
+ ())
+ l
+ in
+ begin match decl.type_kind with
+ | Type_abstract -> ()
+ | Type_variant l ->
+ let gen_variants lst = List.map (fun (a,b) -> (a,b,None)) lst in
+ process_variants (gen_variants l)
+ | Type_generalized_variant l ->
+ process_variants l
+
| Type_record (l, _) ->
let rec find_pl = function
Ptype_record pl -> pl
@@ -479,9 +500,12 @@ let compute_variance env tvl nega posi cntr ty =
let make_variance ty = (ty, ref false, ref false, ref false)
let whole_type decl =
match decl.type_kind with
- Type_variant tll ->
+ | Type_generalized_variant tll ->
Btype.newgenty
- (Ttuple (List.map (fun (_, tl) -> Btype.newgenty (Ttuple tl)) tll))
+ (Ttuple (List.map (fun (_, tl,_ (* added by me *)) -> Btype.newgenty (Ttuple tl)) tll)) (* GAH: WHAT?*)
+ | Type_variant tll ->
+ Btype.newgenty
+ (Ttuple (List.map (fun (_, tl) -> Btype.newgenty (Ttuple tl)) tll)) (* GAH: WHAT?*)
| Type_record (ftl, _) ->
Btype.newgenty
(Ttuple (List.map (fun (_, _, ty) -> ty) ftl))
@@ -503,15 +527,24 @@ let compute_variance_decl env check decl (required, loc) =
let tvl2 = List.map make_variance fvl in
let tvl = tvl0 @ tvl1 in
begin match decl.type_kind with
- Type_abstract ->
+ | Type_abstract ->
begin match decl.type_manifest with
None -> assert false
| Some ty -> compute_variance env tvl true false false ty
end
- | Type_variant tll ->
+ | Type_variant tll -> (* GAH: what in the blazes *)
List.iter
(fun (_,tl) ->
- List.iter (compute_variance env tvl true false false) tl)
+ List.iter (compute_variance env tvl true false false) tl)
+ tll
+ | Type_generalized_variant tll -> (* GAH: what in the blazes *)
+ List.iter
+ (fun (_,tl,ret_type_opt) ->
+ match ret_type_opt with
+ | None ->
+ List.iter (compute_variance env tvl true false false) tl
+ | Some ret_type ->
+ List.iter (compute_variance env tvl true true true) tl) (* GAH: variance calculation, is this right *)
tll
| Type_record (ftl, _) ->
List.iter
@@ -612,7 +645,7 @@ let check_duplicates name_sdecl_list =
(fun (name, sdecl) -> match sdecl.ptype_kind with
Ptype_variant cl ->
List.iter
- (fun (cname, _, loc) ->
+ (fun (cname, _, _, loc) -> (* probably right *)
try
let name' = Hashtbl.find constrs cname in
Location.prerr_warning loc
@@ -940,9 +973,14 @@ let report_error ppf = function
fprintf ppf "A type variable is unbound in this type declaration";
let ty = Ctype.repr ty in
begin match decl.type_kind, decl.type_manifest with
- Type_variant tl, _ ->
- explain_unbound ppf ty tl (fun (_,tl) -> Btype.newgenty (Ttuple tl))
- "case" (fun (lab,_) -> lab ^ " of ")
+ | Type_generalized_variant tl, _ ->
+ explain_unbound ppf ty tl (fun (_,tl,_) ->
+ Btype.newgenty (Ttuple tl))
+ "case" (fun (lab,_,_) -> lab ^ " of ")
+ | Type_variant tl, _ ->
+ explain_unbound ppf ty tl (fun (_,tl) ->
+ Btype.newgenty (Ttuple tl))
+ "case" (fun (lab,_) -> lab ^ " of ")
| Type_record (tl, _), _ ->
explain_unbound ppf ty tl (fun (_,_,t) -> t)
"field" (fun (lab,_,_) -> lab ^ ": ")
diff --git a/typing/types.ml b/typing/types.ml
index 5996719d4..d1ef644a3 100644
--- a/typing/types.ml
+++ b/typing/types.ml
@@ -106,6 +106,7 @@ and value_kind =
type constructor_description =
{ cstr_res: type_expr; (* Type of the result *)
+ cstr_existentials: type_expr list; (* list of existentials *)
cstr_args: type_expr list; (* Type of the arguments *)
cstr_arity: int; (* Number of arguments *)
cstr_tag: constructor_tag; (* Tag for heap blocks *)
@@ -150,6 +151,7 @@ and type_kind =
| Type_variant of (string * type_expr list) list
| Type_record of
(string * mutable_flag * type_expr) list * record_representation
+ | Type_generalized_variant of (string * type_expr list * type_expr option) list
type exception_declaration = type_expr list
diff --git a/typing/types.mli b/typing/types.mli
index a4c640845..962dfd02e 100644
--- a/typing/types.mli
+++ b/typing/types.mli
@@ -103,6 +103,7 @@ and value_kind =
type constructor_description =
{ cstr_res: type_expr; (* Type of the result *)
+ cstr_existentials: type_expr list; (* list of existentials *)
cstr_args: type_expr list; (* Type of the arguments *)
cstr_arity: int; (* Number of arguments *)
cstr_tag: constructor_tag; (* Tag for heap blocks *)
@@ -147,6 +148,7 @@ and type_kind =
| Type_variant of (string * type_expr list) list
| Type_record of
(string * mutable_flag * type_expr) list * record_representation
+ | Type_generalized_variant of (string * type_expr list * type_expr option) list
type exception_declaration = type_expr list