Set object name of self type

Sets the object name of the self type to the #-abbreviation, which
improves error messages and allows us to remove the `unify_parents`
functions from Typeclass.

5 files changed, 13 insertions, 40 deletions

diff --git a/testsuite/tests/typing-gadts/pr7391.ml b/testsuite/tests/typing-gadts/pr7391.ml
index f5ffc205f5..f16654c5a0 100644
--- a/testsuite/tests/typing-gadts/pr7391.ml
+++ b/testsuite/tests/typing-gadts/pr7391.ml
@@ -29,7 +29,7 @@ class virtual child2 :
   object ('a)
     method private virtual parent : < previous : 'a option; .. >
   end
-- : < child : child2; previous : child2 option > = <obj>
+- : < child : child1; previous : child1 option > = <obj>
 |}]
 
 (* Worked in 4.03 *)
@@ -43,7 +43,7 @@ let _ =
       end
   end;;
 [%%expect{|
-- : < child : unit -> child2; previous : child2 option > = <obj>
+- : < child : unit -> child1; previous : child1 option > = <obj>
 |}]
 
 (* Worked in 4.03 *)
@@ -57,7 +57,7 @@ let _ =
       end
   end;;
 [%%expect{|
-- : < child : unit -> child2; previous : child2 option > = <obj>
+- : < child : unit -> child1; previous : child1 option > = <obj>
 |}]
 
 (* Didn't work in 4.03, but works in 4.07 *)
@@ -73,7 +73,7 @@ let _ =
       in o
   end;;
 [%%expect{|
-- : < child : child2; previous : child2 option > = <obj>
+- : < child : child1; previous : child1 option > = <obj>
 |}]
 
 (* Also didn't work in 4.03 *)
@@ -91,5 +91,5 @@ let _ =
   end;;
 [%%expect{|
 type gadt = Not_really_though : gadt
-- : < child : gadt -> child2; previous : child2 option > = <obj>
+- : < child : gadt -> child1; previous : child1 option > = <obj>
 |}]
diff --git a/testsuite/tests/typing-objects/dummy.ml b/testsuite/tests/typing-objects/dummy.ml
index 0029d955b0..b2577256b7 100644
--- a/testsuite/tests/typing-objects/dummy.ml
+++ b/testsuite/tests/typing-objects/dummy.ml
@@ -60,7 +60,7 @@ class foo1 = object(self)
     end
 end;;
 [%%expect{|
-class foo1 : object method child : child2 method previous : child2 option end
+class foo1 : object method child : child1 method previous : child1 option end
 |}]
 
 class nested = object
@@ -76,7 +76,7 @@ end;;
 [%%expect{|
 class nested :
   object
-    method obj : < child : unit -> child2; previous : child2 option >
+    method obj : < child : unit -> child1; previous : child1 option >
   end
 |}]
 
@@ -93,7 +93,7 @@ class just_to_see = object(self)
 end;;
 [%%expect{|
 class just_to_see :
-  object method child : child2 method previous : child2 option end
+  object method child : child1 method previous : child1 option end
 |}]
 
 class just_to_see2 = object
@@ -111,7 +111,7 @@ class just_to_see2 = object
 end;;
 [%%expect{|
 class just_to_see2 :
-  object method obj : < child : child2; previous : child2 option > end
+  object method obj : < child : child1; previous : child1 option > end
 |}]
 
 type gadt = Not_really_though : gadt
@@ -127,7 +127,7 @@ end;;
 [%%expect{|
 type gadt = Not_really_though : gadt
 class just_to_see3 :
-  object method child : gadt -> child2 method previous : child2 option end
+  object method child : gadt -> child1 method previous : child1 option end
 |}]
 
 class leading_up_to = object(self : 'a)
diff --git a/testsuite/tests/typing-objects/pr6907_bad.ml b/testsuite/tests/typing-objects/pr6907_bad.ml
index 427ad98701..cafe04f440 100644
--- a/testsuite/tests/typing-objects/pr6907_bad.ml
+++ b/testsuite/tests/typing-objects/pr6907_bad.ml
@@ -18,6 +18,5 @@ Line 2, characters 2-27:
       ^^^^^^^^^^^^^^^^^^^^^^^^^
 Error: Some type variables are unbound in this type:
          class base : 'e -> ['e] t
-       The method update has type 'e -> < update : 'a; .. > as 'a where 'e
-       is unbound
+       The method update has type 'e -> #base where 'e is unbound
 |}];;
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 694f64e7ed..47104b360c 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -3519,7 +3519,6 @@ let update_class_signature env sign =
 
 let hide_private_methods env sign =
   let self = expand_head env sign.Types.csig_self in
-  remove_object_name self;
   let fields, _ = flatten_fields (object_fields self) in
   List.iter
     (fun (_, k, _) ->
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 622593da4d..9bd726d817 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -1583,11 +1583,12 @@ let class_infos define_class kind
     end
   end;
 
+  Ctype.set_object_name obj_id params (Btype.self_type typ);
+
   (* Check the other temporary abbreviation (#-type) *)
   begin
     let (cl_params', cl_type) = Ctype.instance_class params typ in
     let ty = Btype.self_type cl_type in
-    Ctype.set_object_name obj_id cl_params ty;
     begin try
       List.iter2 (Ctype.unify env) cl_params cl_params'
     with Ctype.Unify _ ->
@@ -1930,31 +1931,6 @@ let class_type_declarations env cls =
      decls,
    env)
 
-let rec unify_parents env ty cl =
-  match cl.cl_desc with
-    Tcl_ident (p, _, _) ->
-      begin try
-        let decl = Env.find_class p env in
-        let _, body = Ctype.find_cltype_for_path env decl.cty_path in
-        Ctype.unify env ty (Ctype.instance body)
-      with
-        Not_found -> ()
-      | _exn -> assert false
-      end
-  | Tcl_structure st -> unify_parents_struct env ty st
-  | Tcl_open (_, cl)
-  | Tcl_fun (_, _, _, cl, _)
-  | Tcl_apply (cl, _)
-  | Tcl_let (_, _, _, cl)
-  | Tcl_constraint (cl, _, _, _, _) -> unify_parents env ty cl
-and unify_parents_struct env ty st =
-  List.iter
-    (function
-      | {cf_desc = Tcf_inherit (_, cl, _, _, _)} ->
-          unify_parents env ty cl
-      | _ -> ())
-    st.cstr_fields
-
 let type_object env loc s =
   incr class_num;
   let desc =
@@ -1963,7 +1939,6 @@ let type_object env loc s =
   in
   complete_class_signature loc env Concrete Object desc.cstr_type;
   let meths = Btype.public_methods desc.cstr_type in
-  unify_parents_struct env desc.cstr_type.csig_self desc;
   (desc, meths)
 
 let () =