Allow compiling ocamldoc with -principal (#8955)

Also solves issue #6922

Changes

@@ -257,6 +257,10 @@ Working version
 
 ### Bug fixes:
 
+- #6922, #8955: Fix regression with -principal type inference for inherited
+  methods, allowing to compile ocamldoc with -principal
+  (Jacques Garrigue, review by Leo White)
+
 - #7925, #8611: fix error highlighting for exceptionally
   long toplevel phrases
   (Kyle Miller, reported by Armaël Guéneau, review by Armaël Guéneau

ocamldoc/Makefile

@@ -116,7 +116,9 @@ INCLUDES_NODEP=\
 DEPINCLUDES=$(INCLUDES_DEP)
 INCLUDES=$(INCLUDES_DEP) $(INCLUDES_NODEP)
 
-COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -warn-error A -safe-string -strict-sequence -strict-formats -bin-annot
+COMPFLAGS=$(INCLUDES) -absname -w +a-4-9-41-42-44-45-48 -warn-error A \
+  -safe-string -strict-sequence -strict-formats -bin-annot -principal
+
 LINKFLAGS=$(INCLUDES) -nostdlib
 
 CMOFILES=\

testsuite/tests/typing-poly-bugs/pr6922_ok.ml

@@ -0,0 +1,216 @@
+(* TEST
+flags = " -w a "
+* setup-ocamlc.byte-build-env
+** ocamlc.byte
+*** check-ocamlc.byte-output
+*)
+
+module Order = struct
+    module type Total = sig
+        type t
+        val compare: t -> t -> int
+    end
+end
+
+module type Profile = sig
+    module Priority: Order.Total
+
+    class type ['level] prioritizer = object
+        method code: 'level -> Priority.t
+        method tag: 'level -> string
+    end
+
+    class ['level] event:
+        'level #prioritizer -> 'level -> string ->
+        object
+            method prioritizer: 'level prioritizer
+            method level: 'level
+            method message: string
+        end
+
+    class type ['event] archiver = object
+        constraint 'event = 'level #event
+        method emit: 'event -> unit
+    end
+
+    class virtual ['archiver] agent:
+        'level #prioritizer -> 'level -> 'archiver list ->
+        object
+            constraint 'event = 'level #event
+            constraint 'archiver = 'event #archiver
+            val mutable archivers_: 'archiver list
+            val mutable limit_: Priority.t
+            method virtual private event: 'level -> string -> 'event
+            method setlimit: 'level -> unit
+            method enabled: 'level -> bool
+            method private put: 'a 'b. 'level -> ('event -> 'b) -> ('a, unit, string, string, string, 'b) format6 -> 'a
+        end
+end
+
+module Create(P: Order.Total) = struct
+    module Priority = P
+
+    class type ['level] prioritizer = object
+        method code: 'level -> Priority.t
+        method tag: 'level -> string
+    end
+
+    class ['level] event prioritizer level message =
+        let prioritizer = (prioritizer :> 'level prioritizer) in
+        object
+            method prioritizer = prioritizer
+            method level: 'level = level
+            method message: string = message
+        end
+
+    class type ['event] archiver = object
+        constraint 'event = 'level #event
+        method emit: 'event -> unit
+    end
+
+    class virtual ['archiver] agent prioritizer limit archivers =
+        let _ = (prioritizer :> 'level prioritizer) in
+        let _ = (archivers :> 'archiver list) in
+        object(self:'self)
+            constraint 'event = 'level #event
+            constraint 'archiver = 'event #archiver
+
+            val mutable archivers_ = archivers
+            val mutable limit_ = prioritizer#code limit
+
+            method virtual private event: 'level -> string -> 'event
+
+            method setlimit limit = limit_ <- prioritizer#code limit
+            method enabled limit = prioritizer#code limit >= limit_
+
+            method private put:
+                type a b. 'level -> ('event -> b) ->
+                (a, unit, string, string, string, b) format6 -> a
+                = fun level cont ->
+                    let f message =
+                        let e = self#event level message in
+                        if self#enabled level then
+                            List.iter (fun j -> j#emit e) archivers_;
+                        cont e
+                    in
+                    Printf.kprintf f
+        end
+end
+
+module Basic = struct
+    include Create(struct type t = int  let compare a b = b - a end)
+
+    type invalid = [ `Invalid ]
+    type fail = [ `Fail ]
+    type error = [ `Error ]
+    type warn = [ `Warn ]
+    type notice = [ `Notice ]
+    type info = [ `Info ]
+    type debug = [ `Debug ]
+
+    type basic = [ invalid | fail | error | warn | notice | info | debug ]
+    type enable = [ `None | `All ]
+    type level = [ basic | enable ]
+end
+
+class ['level] basic_prioritizer =
+    object(_:'self)
+        constraint 'self = 'level #Basic.prioritizer
+        constraint 'level = [> Basic.level ]
+
+        method code = function
+            | `All -> max_int
+            | `Invalid -> 7000
+            | `Fail -> 6000
+            | `Error -> 5000
+            | `Warn -> 4000
+            | `Notice -> 3000
+            | `Info -> 2000
+            | `Debug -> 1000
+            | `None -> min_int
+            | _ -> invalid_arg "Oni_cf_journal: no code defined for priority!"
+
+        method tag =
+            let invalid_ = "INVALID" in
+            let fail_ = "FAIL" in
+            let error_ = "ERROR" in
+            let warn_ = "WARN" in
+            let notice_ = "NOTICE" in
+            let info_ = "INFO" in
+            let debug_ = "DEBUG" in
+            function
+            | `Invalid -> invalid_
+            | `Fail -> fail_
+            | `Error -> error_
+            | `Warn -> warn_
+            | `Notice -> notice_
+            | `Info -> info_
+            | `Debug -> debug_
+            | _ -> invalid_arg "Oni_cf_journal: no tag defined for priority!"
+    end
+
+class ['event] basic_channel_archiver channel = object
+    constraint 'self = 'event #Basic.archiver
+    constraint 'level = [> Basic.level ]
+    constraint 'event = 'level #Basic.event
+
+    method channel = channel
+
+    method emit e =
+        let _ = (e :> 'event) in
+        let n = e#level in
+        let p = e#prioritizer in
+        if (p#code `Fail) - (p#code e#level) > 0 then begin
+            let tag = p#tag n in
+            let m = e#message in
+            Printf.fprintf channel "%s: %s\n" tag m;
+            flush channel
+        end
+end
+
+class virtual ['archiver] basic_agent prioritizer limit archivers =
+    let _ = (prioritizer :> 'level basic_prioritizer) in
+    (*
+    let _ = (limit : 'level) in
+    let _ = (archivers : 'archiver list) in
+    *)
+    object(self)
+        constraint 'level = [> Basic.level ]
+        constraint 'event = 'level #Basic.event
+        constraint 'archiver = 'event #Basic.archiver
+        inherit ['archiver] Basic.agent prioritizer limit archivers (* as super *)
+
+        (*
+        method! private put:
+            'a 'b. 'level -> ('event -> 'b) ->
+            ('a, unit, string, 'b) format4 -> 'a = super#put
+        *)
+
+        method invalid:
+            'a 'b. ('a, unit, string, string, string, 'b) format6 -> 'a =
+            self#put `Invalid (fun x -> invalid_arg x#message)
+
+        method fail:
+            'a 'b. ('a, unit, string, string, string, 'b) format6 -> 'a =
+            self#put `Fail (fun x -> failwith x#message)
+
+        method error:
+            'a. ('a, unit, string, string, string, unit) format6 -> 'a =
+            self#put `Error ignore
+
+        method warn:
+            'a. ('a, unit, string, string, string, unit) format6 -> 'a =
+            self#put `Warn ignore
+
+        method notice:
+            'a. ('a, unit, string, string, string, unit) format6 -> 'a =
+            self#put `Notice ignore
+
+        method info:
+            'a. ('a, unit, string, string, string, unit) format6 -> 'a =
+            self#put `Info ignore
+
+        method debug:
+            'a. ('a, unit, string, string, string, bool) format6 -> 'a =
+            self#put `Debug (fun _ -> true)
+    end

testsuite/tests/typing-poly/poly.ml

@@ -1754,3 +1754,13 @@ let x : [ `Foo of 'a t | `Foo of _ s ] = id (`Foo []);;
 [%%expect{|
 val x : [ `Foo of 'a list t ] = `Foo []
 |}]
+
+(* generalize spine of inherited methods too *)
+
+class c = object (self) method m ?(x=0) () = x method n = self#m () end;;
+class d = object (self) inherit c method n' = self#m () end;;
+[%%expect{|
+class c : object method m : ?x:int -> unit -> int method n : int end
+class d :
+  object method m : ?x:int -> unit -> int method n : int method n' : int end
+|}]

testsuite/typing

@@ -1,40 +0,0 @@
-tests/basic
-tests/basic-float
-tests/basic-io
-tests/basic-io-2
-tests/basic-manyargs
-tests/basic-modules
-tests/basic-more
-tests/basic-multdef
-tests/basic-private
-tests/typing-extension-constructor
-tests/typing-extensions
-tests/typing-fstclassmod
-tests/typing-gadts
-tests/typing-immediate
-tests/typing-implicit_unpack
-tests/typing-labels
-tests/typing-misc
-tests/typing-misc-bugs
-tests/typing-missing-cmi
-tests/typing-modules
-tests/typing-modules-bugs
-tests/typing-objects
-tests/typing-objects-bugs
-tests/typing-poly
-tests/typing-poly-bugs
-tests/typing-polyvariants-bugs
-tests/typing-polyvariants-bugs-2
-tests/typing-private
-tests/typing-private-bugs
-tests/typing-recmod
-tests/typing-recordarg
-tests/typing-rectypes-bugs
-tests/typing-safe-linking
-tests/typing-short-paths
-tests/typing-signatures
-tests/typing-sigsubst
-tests/typing-typeparam
-tests/typing-unboxed
-tests/typing-warnings
-tests/warnings

tools/Makefile

@@ -81,7 +81,7 @@ INCLUDES = $(addprefix -I $(ROOTDIR)/,utils parsing typing bytecomp \
                        middle_end/flambda/base_types driver toplevel \
                        file_formats lambda)
 COMPFLAGS = -absname -w +a-4-9-41-42-44-45-48 -strict-sequence -warn-error A \
- -safe-string -strict-formats -bin-annot $(INCLUDES)
+ -principal -safe-string -strict-formats -bin-annot $(INCLUDES)
 LINKFLAGS = $(INCLUDES)
 VPATH := $(filter-out -I,$(INCLUDES))
 

typing/typeclass.ml

@@ -834,8 +834,7 @@ and class_structure cl_num final val_env met_env loc
 
   (* Check that the binder has a correct type *)
   let ty =
-    if final then Ctype.newty (Tobject (Ctype.newvar(), ref None))
+    if final then Ctype.newobj (Ctype.newvar()) else self_type in
-    else self_type in
   begin try Ctype.unify val_env public_self ty with
     Ctype.Unify _ ->
       raise(Error(spat.ppat_loc, val_env, Pattern_type_clash public_self))
@@ -865,7 +864,7 @@ and class_structure cl_num final val_env met_env loc
            str
       )
   in
-  Ctype.unify val_env self_type (Ctype.newvar ());
+  Ctype.unify val_env self_type (Ctype.newvar ()); (* useless ? *)
   let sign =
     {csig_self = public_self;
      csig_vars = Vars.map (fun (_id, mut, vr, ty) -> (mut, vr, ty)) !vars;
@@ -875,6 +874,11 @@ and class_structure cl_num final val_env met_env loc
   let priv_meths =
     List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent)
       methods in
+  (* ensure that inherited methods are listed too *)
+  List.iter (fun (met, _kind, _ty) ->
+      if Meths.mem met !meths then () else
+      ignore (Ctype.filter_self_method val_env met Private meths self_type))
+    methods;
   if final then begin
     (* Unify private_self and a copy of self_type. self_type will not
        be modified after this point *)