simplify conjunctive types

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2853 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

typing/ctype.ml

@@ -1280,7 +1280,7 @@ and unify_kind k1 k2 =
 
 and unify_row env row1 row2 =
   let row1 = row_repr row1 and row2 = row_repr row2 in
-  let rm1 = row_more row1 and rm2 =row_more row2 in
+  let rm1 = row_more row1 and rm2 = row_more row2 in
   if rm1 == rm2 then () else
   let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in
   ignore (List.fold_left
@@ -1299,11 +1299,16 @@ and unify_row env row1 row2 =
         row_field_repr f1 = Rabsent || row_field_repr f2 <> Rabsent)
       pairs
   in
+  let empty fields =
+    List.for_all (fun (_,f) -> row_field_repr f = Rabsent) fields in
   let name =
-    if r1 = [] && row2.row_name <> None && keep (fun f1 f2 -> f2, f1)
-    then row2.row_name
-    else if r2 = [] && row1.row_name <> None && keep (fun f1 f2 -> f1, f2)
-    then row1.row_name else None
+    if row1.row_name <> None && (row1.row_closed || empty r2) &&
+      (not row2.row_closed || keep (fun f1 f2 -> f1, f2) && empty r1)
+    then row1.row_name
+    else if row2.row_name <> None && (row2.row_closed || empty r1) &&
+      (not row1.row_closed || keep (fun f1 f2 -> f2, f1) && empty r2)
+    then row1.row_name
+    else None
   in
   let bound = row1.row_bound @ row2.row_bound in
   let row0 = {row_fields = []; row_more = more; row_bound = bound;
@@ -2280,6 +2285,35 @@ let rec cyclic_abbrev env id ty =
   | _ ->
       false
 
+let rec normalize_type_rec env ty =
+  let ty = repr ty in
+  if ty.level >= lowest_level then begin
+    mark_type_node ty;
+    begin match ty.desc with Tvariant row ->
+      let row = row_repr row in
+      List.iter
+        (fun (_,f) ->
+          match row_field_repr f with Reither(b, ty::(_::_ as tyl), e) ->
+            let tyl' =
+              List.fold_left
+                (fun tyl ty ->
+                  if List.exists (fun ty' -> equal env false [ty] [ty']) tyl
+                  then tyl else ty::tyl)
+                [ty] tyl
+            in
+            if List.length tyl' < List.length tyl + 1 then
+              e := Some(Reither(b, List.rev tyl', ref None))
+          | _ -> ())
+        row.row_fields
+    | _ -> ()
+    end;
+    iter_type_expr (normalize_type_rec env) ty
+  end
+
+let normalize_type env ty = ()
+  normalize_type_rec env ty;
+  unmark_type ty
+      
 
                               (*************************)
                               (*  Remove dependencies  *)

typing/ctype.mli

@@ -184,6 +184,7 @@ val nondep_cltype_declaration:
         (* Same for class type declarations. *)
 val correct_abbrev: Env.t -> Ident.t -> type_expr list -> type_expr -> unit
 val cyclic_abbrev: Env.t -> Ident.t -> type_expr -> bool
+val normalize_type: Env.t -> type_expr -> unit
 
 val closed_schema: type_expr -> bool
         (* Check whether the given type scheme contains no non-generic

typing/parmatch.ml

@@ -359,9 +359,10 @@ let full_match tdefs force env =  match env with
               else (tag, f)::acc)
             [] fields
         in
-        let closed = { row_fields = more_fields; row_more = Ctype.newvar();
-                       row_bound = row.row_bound; row_closed = true;
-                       row_name = None }
+        let closed =
+          { row_fields = more_fields; row_more = Ctype.newvar();
+            row_bound = row.row_bound; row_closed = true;
+            row_name = if more_fields = [] then row.row_name else None }
          (* Cannot fail *)
         in Ctype.unify tdefs row.row_more (Btype.newgenty (Tvariant closed))
       end;

typing/printtyp.ml

@@ -94,7 +94,7 @@ let proxy ty =
   | _ -> ty
 
 let namable_row row =
-  row.row_name <> None &&
+  row.row_name <> None && row.row_closed &&
   List.for_all
     (fun (_,f) -> match row_field_repr f with
       Reither(c,l,_) -> if c then l = [] else List.length l = 1
@@ -165,7 +165,9 @@ let rec mark_loops_rec visited ty =
     | Tsubst ty           ->  mark_loops_rec visited ty
     | Tlink _             -> fatal_error "Printtyp.mark_loops_rec (2)"
 
-let mark_loops ty = mark_loops_rec [] ty
+let mark_loops ty =
+  normalize_type Env.empty ty;
+  mark_loops_rec [] ty
 
 let reset_loop_marks () =
   visited_objects := []; aliased := []

typing/typecore.ml

@@ -114,7 +114,7 @@ let rec extract_row_fields p =
       extract_row_fields p1 @ extract_row_fields p2
   | Tpat_variant(l, None, _) ->
       [l, Rpresent None]
-  | Tpat_variant(l, Some{pat_desc = Tpat_any; pat_type = ty}, _) ->
+  | Tpat_variant(l, Some{pat_type = ty}, _) ->
       [l, Rpresent(Some ty)]
   | _ ->
       raise Not_found
@@ -125,13 +125,10 @@ let build_or_pat env loc lid =
     with Not_found ->
       raise(Typetexp.Error(loc, Typetexp.Unbound_type_constructor lid))
   in
-  let tyl, ty =
-    match decl.type_manifest with
-      None -> raise(Error(loc, Not_a_variant_type lid))
-    | Some ty -> instance_parameterized_type decl.type_params ty
-  in
+  let tyl = List.map (fun _ -> newvar()) decl.type_params in
   let fields =
-    match (repr ty).desc with
+    let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in
+    match ty.desc with
       Tvariant row when static_row row ->
         (row_repr row).row_fields
     | _ -> raise(Error(loc, Not_a_variant_type lid))
@@ -189,9 +186,10 @@ let rec type_pat env sp =
       let ty_var =
         try
           let fields = extract_row_fields p in
-          newty (Tvariant { row_fields = fields; row_more = newvar();
-                            row_closed = false; row_name = None;
-                            row_bound = [] })
+          newgenty
+            (Tvariant { row_fields = fields; row_more = newgenvar();
+                        row_closed = false; row_name = None;
+                        row_bound = [] })
         with Not_found -> p.pat_type
       in
       let id = enter_variable sp.ppat_loc name ty_var in

typing/typemod.ml

@@ -462,6 +462,20 @@ and type_struct env sstr =
 let _ =
   Typecore.type_module := type_module
 
+(* Normalize types in a signature *)
+
+let rec normalize_modtype env = function
+    Tmty_ident p -> ()
+  | Tmty_signature sg -> normalize_signature env sg
+  | Tmty_functor(id, param, body) -> normalize_modtype env body
+
+and normalize_signature env = List.iter (normalize_signature_item env)
+
+and normalize_signature_item env = function
+    Tsig_value(id, desc) -> Ctype.normalize_type env desc.val_type
+  | Tsig_module(id, mty) -> normalize_modtype env mty
+  | _ -> ()
+
 (* Typecheck an implementation file *)
 
 let type_implementation sourcefile prefixname modulename initial_env ast =
@@ -479,6 +493,7 @@ let type_implementation sourcefile prefixname modulename initial_env ast =
       Includemod.compunit sourcefile sg intf_file dclsig
     end else begin
       check_nongen_schemes finalenv str;
+      normalize_signature finalenv sg;
       Env.save_signature sg modulename (prefixname ^ ".cmi");
       Tcoerce_none
     end in