only expand to first concrete definition

git-svn-id: http://caml.inria.fr/svn/ocaml/branches/record-disambiguation@13035 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

typing/ctype.ml

@@ -1400,6 +1400,19 @@ let expand_head env ty =
     Btype.backtrack snap;
     repr ty
 
+(* Expand until we find a non-abstract type declaration *)
+
+let rec extract_concrete_typedecl env ty =
+  let ty = repr ty in
+  match ty.desc with
+    Tconstr (p, _, _) ->
+      let decl = Env.find_type p env in
+      if decl.type_kind <> Type_abstract then (p, decl) else
+      let ty =
+	try try_expand_once env ty with Cannot_expand -> raise Not_found
+      in extract_concrete_typedecl env ty
+  | _ -> raise Not_found
+
 (* Implementing function [expand_head_opt], the compiler's own version of
    [expand_head] used for type-based optimisations.
    [expand_head_opt] uses [Env.find_type_expansion_opt] to access the

typing/ctype.mli

@@ -147,6 +147,10 @@ val expand_head_opt: Env.t -> type_expr -> type_expr
 (** The compiler's own version of [expand_head] necessary for type-based
     optimisations. *)
 val full_expand: Env.t -> type_expr -> type_expr
+val extract_concrete_typedecl: Env.t -> type_expr -> Path.t * type_declaration
+        (* Return the first concrete type declaration found expanding
+	   the type. Raise [Not_found] if none appears or not a type
+	   constructor. *)
 
 val enforce_constraints: Env.t -> type_expr -> unit
 

typing/typecore.ml

@@ -245,20 +245,16 @@ let extract_option_type env ty =
     when Path.same path Predef.path_option -> ty
   | _ -> assert false
 
-let rec extract_label_names sexp env ty =
+let extract_label_names sexp env ty =
-  let ty = expand_head env ty in
+  try
-  match ty.desc with
+    let (_,td) = extract_concrete_typedecl env ty in
-  | Tconstr (path, _, _) ->
+    begin match td.type_kind with
-      let td = Env.find_type path env in
+    | Type_record (fields, _) ->
-      begin match td.type_kind with
+        List.map (fun (name, _, _) -> name) fields
-      | Type_record (fields, _) ->
+    | _ -> assert false
-          List.map (fun (name, _, _) -> name) fields
+    end
-      | Type_abstract when td.type_manifest <> None ->
+  with Not_found ->
-          extract_label_names sexp env (expand_head env ty)
+    assert false
-      | _ -> assert false
-      end
-  | _ ->
-      assert false
 
 (* Typing of patterns *)
 
@@ -527,6 +523,15 @@ let rec find_record_qual = function
   | ({ txt = Longident.Ldot _ } as lid, _) :: _ -> Some lid
   | _ :: rest -> find_record_qual rest
 
+let rec expand_path env p =
+  let decl = Env.find_type p env in
+  match decl.type_manifest with
+    None -> p
+  | Some ty ->
+      match repr ty with
+	{desc=Tconstr(p,_,_)} -> expand_path env p
+      | _ -> assert false
+
 let type_label_a_list ?labels env type_lbl_a opath lid_a_list =
   (* Priority order for selecting record type
      1) use first qualified label
@@ -552,13 +557,18 @@ let type_label_a_list ?labels env type_lbl_a opath lid_a_list =
         let _, label = Typetexp.find_label env lid.loc lid.txt in
         let ty_res = instance Env.empty label.lbl_res in
         let path =
-          match opath, (expand_head env ty_res).desc with
+          match opath, ty_res.desc with
-            Some (p1,pr), Tconstr(p2,_,_) when not (Path.same p1 p2) ->
+            Some (p1,pr), Tconstr(p2,_,_) ->
-              if not pr then
+	      if not (Path.same (expand_path env p1) (expand_path env p2))
+	      && not pr then
                 Location.prerr_warning lid.loc
                   (Warnings.Not_principal "this type-based record selection");
               p1
-          | _, Tconstr (p, _, _) -> p
+          | _, Tconstr _ ->
+	      begin match ty_res.desc with
+		Tconstr (p,_,_) -> p
+	      | _ -> assert false
+	      end
           | _ -> assert false
         in
         path, snd (Env.find_type_descrs path env)
@@ -813,9 +823,10 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
         (label_path, label_lid, label, arg)
       in
       let opath =
-        match expand_head !env expected_ty with
+        try
-          {desc = Tconstr (p,_,_)} -> Some (p, true)
+	  let (p,_) = extract_concrete_typedecl !env expected_ty in
-        | _ -> None
+	  Some (p, true)
+	with Not_found -> None
       in
       let lbl_pat_list =
         type_label_a_list ?labels !env type_label_pat opath lid_sp_list in
@@ -1827,10 +1838,11 @@ and type_expect ?in_function env sexp ty_expected =
       in
       let opath =
         let get_path ty =
-          match expand_head env ty with
+	  try
-            {desc = Tconstr (p, _, _); level} ->
+	    let (p,_) = extract_concrete_typedecl env ty in
-              Some (p, level = generic_level || not !Clflags.principal)
+	    (* XXX level may be wrong *)
-          | _ -> None
+            Some (p, ty.level = generic_level || not !Clflags.principal)
+          with Not_found -> None
         in
         match get_path ty_expected with
           None ->
@@ -2432,12 +2444,12 @@ and type_label_access env loc srecord lid =
       end_def ();
       generalize_structure record.exp_type
     end;
-    let ty_exp = expand_head env record.exp_type in
+    let ty_exp = record.exp_type in
     let record = {record with exp_type = instance env record.exp_type} in
     begin try
       let (label_path,label) = Env.lookup_label lid.txt env in
       let ty_res = instance Env.empty label.lbl_res in
-      match ty_exp.desc, (expand_head env ty_res).desc with
+      match (expand_head env ty_exp).desc, (expand_head env ty_res).desc with
         Tconstr(p1,_,_), Tconstr(p2,_,_) when not (Path.same p1 p2) ->
           raise Exit
       | _ -> (record, label_path, label)
@@ -2448,10 +2460,11 @@ and type_label_access env loc srecord lid =
             Path.Pdot (mod_path, lab, Path.nopos)
         | _ -> fst (Typetexp.find_label env lid.loc lid.txt)
       in
-      let _, labels =
+      let labels =
-        match ty_exp.desc with
+	try
-          Tconstr(p,_,_) -> Env.find_type_descrs p env
+	  let (p,_) = extract_concrete_typedecl env ty_exp in
-        | _ -> assert false
+	  snd (Env.find_type_descrs p env)
+	with Not_found -> []
       in
       try
         let label = List.find (fun descr -> descr.lbl_name = lab) labels in