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

principality 

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/gadts@10775 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Jacques Garrigue 2010-11-09 06:23:53 +00:00
parent 4a4e69bf1b
commit 1bcd80bdf9
2 changed files with 25 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
typing/ctype.ml
View File

@ -2835,20 +2835,18 @@ and eqtype_list rename type_pairs subst env tl1 tl2 =
List.iter2 (eqtype rename type_pairs subst env) tl1 tl2
and eqtype_fields rename type_pairs subst env ty1 ty2 =
let (fields1, rest1) = flatten_fields ty1 in
let (fields2, rest2) = flatten_fields ty2 in
(* First check if same row => already equal *)
let row1 = get_object_row ty1 and row2 = get_object_row ty2 in
let same_row =
row1 == row2 || TypePairs.mem type_pairs (row1,row2) ||
(rename && List.mem (row1, row2) !subst)
rest1 == rest2 || TypePairs.mem type_pairs (rest1,rest2) ||
(rename && List.mem (rest1, rest2) !subst)
in
if same_row then () else
(* Start the real work *)
let (fields2, rest2) = flatten_fields ty2 in
(* Try expansion, needed when called from Includecore.type_manifest *)
match expand_head_rigid env rest2 with
{desc=Tobject(ty2,_)} -> eqtype_fields rename type_pairs subst env ty1 ty2
| _ ->
let (fields1, rest1) = flatten_fields ty1 in
let (pairs, miss1, miss2) = associate_fields fields1 fields2 in
eqtype rename type_pairs subst env rest1 rest2;
if (miss1 <> []) || (miss2 <> []) then raise (Unify []);

25
typing/typecore.ml
View File

@ -2383,9 +2383,14 @@ and type_expect ?in_function env sexp ty_expected' =
| _ -> assert false
end
| Pexp_match(sarg, caselist) ->
if !Clflags.principal then begin_def ();
let arg = type_exp env sarg in
if !Clflags.principal then begin
end_def ();
generalize_structure arg.exp_type;
end;
let cases, partial =
type_cases env arg.exp_type ty_expected (Some loc) caselist
type_cases env arg.exp_type ty_expected' (Some loc) caselist
in
re {
exp_desc = Texp_match(arg, cases, partial);
@ -2395,7 +2400,7 @@ and type_expect ?in_function env sexp ty_expected' =
| Pexp_tuple sexpl ->
let subtypes = List.map (fun _ -> newgenvar ()) sexpl in
let to_unify = newgenty (Ttuple subtypes) in
unify_exp_types loc env to_unify ty_expected ;
unify_exp_types loc env to_unify ty_expected' ;
let expl = List.map2 (fun body ty -> type_expect env body ty) sexpl subtypes in
re {
exp_desc = Texp_tuple expl;
@ -2525,10 +2530,22 @@ and type_cases ?in_function env ty_arg ty_res partial_loc caselist =
List.map2
(fun (pat, (ext_env, unpacks)) (spat, sexp) ->
let sexp = wrap_unpacks sexp unpacks in
let exp = type_expect ?in_function ext_env sexp ty_res in
({pat with pat_type = ty_arg'}, exp))
let ty_res' =
if !Clflags.principal then begin
begin_def ();
let ty = instance ~partial:true ty_res in
end_def ();
generalize_structure ty; ty
end else ty_res in
let exp = type_expect ?in_function ext_env sexp ty_res' in
({pat with pat_type = ty_arg'},
{exp with exp_type = instance ty_res'}))
pat_env_list caselist
in
if !Clflags.principal then begin
let ty_res' = instance ty_res in
List.iter (fun (_,exp) -> unify_exp env exp ty_res') cases
end;
let check_partial loc cases =
Parmatch.check_partial_gadt (*env*) (partial_pred env ty_arg) loc cases(* (List.map fst caselist)*)
in