Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Allow compiling ocamldoc with -principal (#8955) 

Also solves issue #6922
master
Jacques Garrigue 2019-09-30 21:14:06 +02:00 committed by GitHub
parent d9429166ac
commit 1e895dbaee
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
7 changed files with 241 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Changes
View File

@ -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

4
ocamldoc/Makefile
View File

@ -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=\

216
testsuite/tests/typing-poly-bugs/pr6922_ok.ml Normal file
View File

@ -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

10
testsuite/tests/typing-poly/poly.ml
View File

@ -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
|}]

40
testsuite/typing
View File

@ -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

2
tools/Makefile
View File

@ -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))

10
typing/typeclass.ml
View File

@ -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))
else self_type in
if final then Ctype.newobj (Ctype.newvar()) 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 *)