Fix PR#5545, cleaner use of generalize_spine

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

Changes

@@ -53,6 +53,7 @@ Standard library:
   (Daniel Bünzli, review by Jacques-Pascal Deplaix)
 
 Type system:
+- PR#5545: Type annotations on methods cannot control the choice of abbreviation
 * PR#6465: allow incremental weakening of module aliases (Jacques Garrigue).
   This is done by adding equations to submodules when expanding aliases.
   In theory this may be incompatible is some corner cases defining a module

testsuite/tests/typing-objects/Tests.ml.reference

@@ -2,8 +2,8 @@
 #   - : < x : int > ->
     < x : int > -> < x : int > -> < x : int > * < x : int > * < x : int >
 = <fun>
-#               class ['a] c : unit -> object constraint 'a = int method f : 'a c end
-and ['a] d : unit -> object constraint 'a = int method f : 'a c end
+#               class ['a] c : unit -> object constraint 'a = int method f : int c end
+and ['a] d : unit -> object constraint 'a = int method f : int c end
 #                 Characters 238-275:
   ........d () = object
     inherit ['a] c ()
@@ -285,7 +285,8 @@ Error: This expression has type 'a t but an expression was expected of type
 Warning 10: this expression should have type unit.
 - : ('a t as 'a) t -> unit = <fun>
 #         class ['a] c :
-  unit -> object constraint 'a = (< .. > as 'b) -> unit method m : 'a end
+  unit ->
+  object constraint 'a = (< .. > as 'b) -> unit method m : 'b -> unit end
 #       class ['a] c :
   unit ->
   object constraint 'a = unit -> (< .. > as 'b) method m : 'a -> 'b end

testsuite/tests/typing-poly/poly.ml.principal.reference

@@ -74,7 +74,11 @@
     method empty : bool
     method fold : f:('a -> 'c -> 'c) -> init:'c -> 'c
   end
-#                   class ['a] ostream1 :
+#                   Characters 166-178:
+      self#tl#fold ~f ~init:(f self#hd init)
+      ^^^^^^^^^^^^
+Warning 18: this use of a polymorphic method is not principal.
+class ['a] ostream1 :
   hd:'a ->
   tl:'b ->
   object ('b)

typing/ctype.ml

@@ -1124,6 +1124,13 @@ let instance_def sch =
   cleanup_types ();
   ty
 
+let generic_instance ?partial env sch =
+  let old = !current_level in
+  current_level := generic_level;
+  let ty = instance env sch in
+  current_level := old;
+  ty
+
 let instance_list env schl =
   let env = gadt_env env in
   let tyl = List.map (fun t -> copy ?env t) schl in

typing/ctype.mli

@@ -110,6 +110,8 @@ val instance: ?partial:bool -> Env.t -> type_expr -> type_expr
            partial=true  -> newty2 ty.level Tvar for non generic subterms *)
 val instance_def: type_expr -> type_expr
         (* use defaults *)
+val generic_instance: ?partial:bool -> Env.t -> type_expr -> type_expr
+        (* Same as instance, but new nodes at generic_level *)
 val instance_list: Env.t -> type_expr list -> type_expr list
         (* Take an instance of a list of type schemes *)
 val instance_constructor:

typing/typeclass.ml

@@ -676,6 +676,8 @@ let rec class_field self_loc cl_num self_type meths vars
 
       let field =
         lazy begin
+          (* Read the generalized type *)
+          let (_, ty) = Meths.find lab.txt !meths in
           let meth_type =
             Btype.newgenty (Tarrow(Nolabel, self_type, ty, Cok)) in
           Ctype.raise_nongen_level ();
@@ -815,12 +817,16 @@ and class_structure cl_num final val_env met_env loc
   end;
 
   (* Typing of method bodies *)
-  if !Clflags.principal then
-    List.iter (fun (_,_,ty) -> Ctype.generalize_spine ty) methods;
+  (* if !Clflags.principal then *) begin
+    let ms = !meths in
+    (* Generalize the spine of methods accessed through self *)
+    Meths.iter (fun _ (_,ty) -> Ctype.generalize_spine ty) ms;
+    meths :=
+      Meths.map (fun (id,ty) -> (id, Ctype.generic_instance val_env ty)) ms;
+    (* But keep levels correct on the type of self *)
+    Meths.iter (fun _ (_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) ms
+  end;
   let fields = List.map Lazy.force (List.rev fields) in
-  if !Clflags.principal then
-    List.iter (fun (_,_,ty) -> Ctype.unify val_env ty (Ctype.newvar ()))
-      methods;
   let meths = Meths.map (function (id, ty) -> id) !meths in
 
   (* Check for private methods made public *)
@@ -1217,7 +1223,7 @@ let initial_env define_class approx
 
   (* Temporary type for the class constructor *)
   let constr_type = approx cl.pci_expr in
-  if !Clflags.principal then Ctype.generalize_spine constr_type;
+  (*if !Clflags.principal then*) Ctype.generalize_spine constr_type;
   let dummy_cty =
     Cty_signature
       { csig_self = Ctype.newvar ();