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

PR#6416 et al.: injective mapping between identifiers and printed names (#1120)

master
Florian Angeletti 2018-06-26 22:03:45 +02:00 committed by GitHub
parent c8343888fa
commit 349db3d869
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
34 changed files with 1258 additions and 199 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
Changes
View File

@ -48,6 +48,9 @@ Working version
### Compiler user-interface and warnings:
- PR#6416, GPR#1120: unique printed names for identifiers
(Florian Angeletti, review by Jacques Garrigue)
- MPR#7116, GPR#1430: new -config-var option
to get the value of a single configuration variable in scripts.
(Gabriel Scherer, review by Sébastien Hinderer and David Allsopp,

3
driver/compile.ml
View File

@ -44,7 +44,8 @@ let interface ppf sourcefile outputprefix =
if !Clflags.print_types then
Printtyp.wrap_printing_env ~error:false initial_env (fun () ->
fprintf std_formatter "%a@."
Printtyp.signature (Typemod.simplify_signature sg));
(Printtyp.printed_signature sourcefile)
(Typemod.simplify_signature sg));
ignore (Includemod.signatures initial_env sg sg);
Typecore.force_delayed_checks ();
Warnings.check_fatal ();

3
driver/optcompile.ml
View File

@ -44,7 +44,8 @@ let interface ppf sourcefile outputprefix =
if !Clflags.print_types then
Printtyp.wrap_printing_env ~error:false initial_env (fun () ->
fprintf std_formatter "%a@."
Printtyp.signature (Typemod.simplify_signature sg));
(Printtyp.printed_signature sourcefile)
(Typemod.simplify_signature sg));
ignore (Includemod.signatures initial_env sg sg);
Typecore.force_delayed_checks ();
Warnings.check_fatal ();

1
ocamldoc/odoc_print.ml
View File

@ -14,6 +14,7 @@
(**************************************************************************)
open Format
let () = Printtyp.Naming_context.enable false
let new_fmt () =
let buf = Buffer.create 512 in

1
ocamldoc/odoc_str.ml
View File

@ -16,6 +16,7 @@
(** The functions to get a string from different kinds of elements (types, modules, ...). *)
module Name = Odoc_name
let () = Printtyp.Naming_context.enable false
let string_of_variance t (co,cn) =
if ( t.Odoc_type.ty_kind = Odoc_type.Type_abstract ||

10
testsuite/tests/typing-implicit_unpack/implicit_unpack.ocaml.reference
View File

@ -1,7 +1,5 @@
val sort : (module Stdlib.Set.S with type elt = 'a) -> 'a list -> 'a list =
<fun>
val make_set : ('a -> 'a -> int) -> (module Stdlib.Set.S with type elt = 'a) =
<fun>
val sort : (module Set.S with type elt = 'a) -> 'a list -> 'a list = <fun>
val make_set : ('a -> 'a -> int) -> (module Set.S with type elt = 'a) = <fun>
val sort_cmp : ('a -> 'a -> int) -> 'a list -> 'a list = <fun>
module type S = sig type t val x : t end
val f : (module S with type t = int) -> int = <fun>
@ -71,8 +69,8 @@ module rec Typ :
| String of ('a, string) TypEq.t
| Pair of (module PAIR with type t = 'a)
end
val int : int Typ.typ = Int <abstr>
val str : string Typ.typ = String <abstr>
val int : int Typ.typ = Typ.Int <abstr>
val str : string Typ.typ = Typ.String <abstr>
val pair : 'a Typ.typ -> 'b Typ.typ -> ('a * 'b) Typ.typ = <fun>
val to_string : 'a Typ.typ -> 'a -> string = <fun>
module type MapT =

3
testsuite/tests/typing-misc/ocamltests
View File

@ -4,6 +4,8 @@ inside_out.ml
labels.ml
occur_check.ml
polyvars.ml
pr6416.ml
pr6634.ml
pr6939-flat-float-array.ml
pr6939-no-flat-float-array.ml
pr7103.ml
@ -11,6 +13,7 @@ pr7228.ml
pr7668_bad.ml
printing.ml
records.ml
unique_names_in_unification.ml
variant.ml
wellfounded.ml
empty_variant.ml

416
testsuite/tests/typing-misc/pr6416.ml Normal file
View File

@ -0,0 +1,416 @@
(* TEST
* expect
*)
module M = struct
type t = A
module M : sig
val f : t -> unit
end = struct
type t = B
let f B = ()
end
end;;
[%%expect{|
Line _, characters 8-52:
........struct
type t = B
let f B = ()
end
Error: Signature mismatch:
Modules do not match:
sig type t = B val f : t -> unit end
is not included in
sig val f : t -> unit end
Values do not match:
val f : t/1 -> unit
is not included in
val f : t/2 -> unit
Line _, characters 4-14:
type t = B
^^^^^^^^^^
Definition of type t/1
Line _, characters 2-12:
type t = A
^^^^^^^^^^
Definition of type t/2
|}]
module N = struct
type t= A
module M: sig type u = A of t end =
struct type t = B type u = A of t end
end;;
[%%expect{|
Line _, characters 2-39:
struct type t = B type u = A of t end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Signature mismatch:
Modules do not match:
sig type t = B type u = A of t end
is not included in
sig type u = A of t end
Type declarations do not match:
type u = A of t/1
is not included in
type u = A of t/2
The types for field A are not equal.
Line _, characters 9-19:
struct type t = B type u = A of t end
^^^^^^^^^^
Definition of type t/1
Line _, characters 2-11:
type t= A
^^^^^^^^^
Definition of type t/2
|}]
module K = struct
module type s
module M: sig module A:functor(X:s) -> sig end end =
struct
module type s
module A(X:s) =struct end
end
end;;
[%%expect{|
Line _, characters 4-70:
....struct
module type s
module A(X:s) =struct end
end
Error: Signature mismatch:
Modules do not match:
sig module type s module A : functor (X : s) -> sig end end
is not included in
sig module A : functor (X : s) -> sig end end
In module A:
Modules do not match:
functor (X : s/1) -> sig end
is not included in
functor (X : s/2) -> sig end
At position module A(X : <here>) : ...
Modules do not match: s/2 is not included in s/1
Line _, characters 6-19:
module type s
^^^^^^^^^^^^^
Definition of module type s/1
Line _, characters 2-15:
module type s
^^^^^^^^^^^^^
Definition of module type s/2
|}]
module L = struct
module T = struct type t end
module M: sig type t = A of T.t end =
struct
module T = struct type t end
type t = A of T.t
end
end;;
[%%expect {|
Line _, characters 4-77:
....struct
module T = struct type t end
type t = A of T.t
end
Error: Signature mismatch:
Modules do not match:
sig module T : sig type t end type t = A of T.t end
is not included in
sig type t = A of T.t end
Type declarations do not match:
type t = A of T/1.t
is not included in
type t = A of T/2.t
The types for field A are not equal.
Line _, characters 6-34:
module T = struct type t end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of module T/1
Line _, characters 2-30:
module T = struct type t end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of module T/2
|}]
module O = struct
module type s
type t = A
module M: sig val f: (module s) -> t -> t end =
struct module type s type t = B let f (module X:s) A = B end
end;;
[%%expect{|
Line _, characters 2-62:
struct module type s type t = B let f (module X:s) A = B end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Signature mismatch:
Modules do not match:
sig module type s type t = B val f : (module s) -> t/2 -> t/1 end
is not included in
sig val f : (module s) -> t -> t end
Values do not match:
val f : (module s/1) -> t/2 -> t/1
is not included in
val f : (module s/2) -> t/2 -> t/2
Line _, characters 23-33:
struct module type s type t = B let f (module X:s) A = B end
^^^^^^^^^^
Definition of type t/1
Line _, characters 2-12:
type t = A
^^^^^^^^^^
Definition of type t/2
Line _, characters 9-22:
struct module type s type t = B let f (module X:s) A = B end
^^^^^^^^^^^^^
Definition of module type s/1
Line _, characters 2-15:
module type s
^^^^^^^^^^^^^
Definition of module type s/2
|}]
module P = struct
module type a
type a = A
module M : sig val f: a -> (module a) -> a end
= struct type a = B let f A _ = B end
end;;
[%%expect{|
Line _, characters 5-41:
= struct type a = B let f A _ = B end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Signature mismatch:
Modules do not match:
sig type a = B val f : a/2 -> 'a -> a/1 end
is not included in
sig val f : a -> (module a) -> a end
Values do not match:
val f : a/2 -> 'a -> a/1
is not included in
val f : a/2 -> (module a) -> a/2
Line _, characters 12-22:
= struct type a = B let f A _ = B end
^^^^^^^^^^
Definition of type a/1
Line _, characters 2-12:
type a = A
^^^^^^^^^^
Definition of type a/2
|}]
module Q = struct
class a = object method m = () end
module M: sig class b: a end =
struct
class a = object method c = let module X = struct type t end in () end
class b = a
end
end;;
[%%expect{|
Line _, characters 2-105:
..struct
class a = object method c = let module X = struct type t end in () end
class b = a
end
Error: Signature mismatch:
Modules do not match:
sig class a : object method c : unit end class b : a end
is not included in
sig class b : a end
Class declarations do not match:
class b : a
does not match
class b : a/2
The first class type has no method m
The public method c cannot be hidden
Line _, characters 4-74:
class a = object method c = let module X = struct type t end in () end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of class type a/1
Line _, characters 2-36:
class a = object method m = () end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of class type a/2
|}]
module R = struct
class type a = object method m: unit end
module M: sig class type b= a end =
struct
class type a = object end
class type b = a
end
end;;
[%%expect{|
Line _, characters 2-65:
..struct
class type a = object end
class type b = a
end
Error: Signature mismatch:
Modules do not match:
sig class type a = object end class type b = a end
is not included in
sig class type b = a end
Class type declarations do not match:
class type b = a/1
does not match
class type b = a/2
The first class type has no method m
Line _, characters 4-29:
class type a = object end
^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of class type a/1
Line _, characters 2-42:
class type a = object method m: unit end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of class type a/2
|}]
module S = struct
class a= object end
class b = a
end;;
[%%expect{|
module S : sig class a : object end class b : a end
|}]
module X: sig
type t
class type a = object method m:t end
module K: sig
type t
class type c = object method m: t end
end
end = struct
type t
class type a = object method m:t end
module K = struct
type t
class type c = object inherit a end
end
end;;
[%%expect{|
Line _, characters 6-141:
......struct
type t
class type a = object method m:t end
module K = struct
type t
class type c = object inherit a end
end
end..
Error: Signature mismatch:
Modules do not match:
sig
type t
class type a = object method m : t end
module K : sig type t class type c = object method m : t/2 end end
end
is not included in
sig
type t
class type a = object method m : t end
module K : sig type t class type c = object method m : t end end
end
In module K:
Modules do not match:
sig type t = K.t class type c = object method m : t/2 end end
is not included in
sig type t class type c = object method m : t end end
In module K:
Class type declarations do not match:
class type c = object method m : t/2 end
does not match
class type c = object method m : t/1 end
The method m has type t/2 but is expected to have type t/1
Type t/2 is not compatible with type t/1 = K.t
Line _, characters 4-10:
type t
^^^^^^
Definition of type t/1
Line _, characters 2-8:
type t
^^^^^^
Definition of type t/2
|}]
;;
module rec M: sig type t type a = M.t end =
struct type t module M = struct type t end type a = M.t end;;
[%%expect{|
Line _, characters 0-59:
struct type t module M = struct type t end type a = M.t end;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Error: Signature mismatch:
Modules do not match:
sig type t = M.t module M : sig type t = M.M.t end type a = M.t end
is not included in
sig type t type a = M.t end
Type declarations do not match:
type a = M/1.t
is not included in
type a = M/2.t
Line _, characters 14-42:
struct type t module M = struct type t end type a = M.t end;;
^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of module M/1
Line _:
Definition of module M/2
|}]
(** Multiple redefinition of t *)
type t = A;;
type t = B;;
type t = C;;
type t = D;;
module M: sig val f: t -> t -> t -> t end = struct
let f A B C = D
end;;
[%%expect {|
type t = A
type t = B
type t = C
type t = D
Line _, characters 44-72:
............................................struct
let f A B C = D
end..
Error: Signature mismatch:
Modules do not match:
sig val f : t/2 -> t/3 -> t/4 -> t/1 end
is not included in
sig val f : t -> t -> t -> t end
Values do not match:
val f : t/2 -> t/3 -> t/4 -> t/1
is not included in
val f : t/1 -> t/1 -> t/1 -> t/1
Line _, characters 0-10:
type t = D;;
^^^^^^^^^^
Definition of type t/1
Line _, characters 0-10:
type t = A;;
^^^^^^^^^^
Definition of type t/2
Line _, characters 0-10:
type t = B;;
^^^^^^^^^^
Definition of type t/3
Line _, characters 0-10:
type t = C;;
^^^^^^^^^^
Definition of type t/4
|}]

34
testsuite/tests/typing-misc/pr6634.ml Normal file
View File

@ -0,0 +1,34 @@
(* TEST
* expect
*)
type t = int
module M : sig type t end with type t = [`T of t] =
struct
type t = [`T of t]
end;;
[%%expect{|
type t = int
Line _, characters 0-31:
struct
type t = [`T of t]
end..
Error: Signature mismatch:
Modules do not match:
sig type t = [ `T of t ] end
is not included in
sig type t = [ `T of t ] end
Type declarations do not match:
type t = [ `T of t/2 ]
is not included in
type t = [ `T of t/1 ]
Line _, characters 0-12:
type t = int
^^^^^^^^^^^^
Definition of type t/1
Line _, characters 2-20:
type t = [`T of t]
^^^^^^^^^^^^^^^^^^
Definition of type t/2
|}]

104
testsuite/tests/typing-misc/unique_names_in_unification.ml Normal file
View File

@ -0,0 +1,104 @@
(* TEST
* expect
*)
type t = A
let x = A
module M = struct
type t = B
let f: t -> t = fun B -> x
end;;
[%%expect{|
type t = A
val x : t = A
Line _, characters 27-28:
let f: t -> t = fun B -> x
^
Error: This expression has type t/2 but an expression was expected of type
t/1
Line _, characters 2-12:
type t = B
^^^^^^^^^^
Definition of type t/1
Line _, characters 0-10:
type t = A
^^^^^^^^^^
Definition of type t/2
|}]
module M = struct type t = B end
let y = M.B
module N = struct
module M = struct
type t = C
end
let f : M.t -> M.t = fun M.C -> y
end;;
[%%expect{|
module M : sig type t = B end
val y : M.t = M.B
Line _, characters 34-35:
let f : M.t -> M.t = fun M.C -> y
^
Error: This expression has type M/2.t but an expression was expected of type
M/1.t
Line _, characters 2-41:
..module M = struct
type t = C
end
Definition of module M/1
Line _, characters 0-32:
module M = struct type t = B end
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of module M/2
|}]
type t = D
let f: t -> t = fun D -> x;;
[%%expect{|
type t = D
Line _, characters 25-26:
let f: t -> t = fun D -> x;;
^
Error: This expression has type t/1 but an expression was expected of type
t/2
Line _, characters 0-10:
type t = A
^^^^^^^^^^
Definition of type t/1
Line _, characters 0-10:
type t = D
^^^^^^^^^^
Definition of type t/2
|}]
type ttt
type ttt = A of ttt | B of uuu
and uuu = C of uuu | D of ttt;;
[%%expect{|
type ttt
type ttt = A of ttt | B of uuu
and uuu = C of uuu | D of ttt
|}]
type nonrec ttt = X of ttt
let x: ttt = let rec y = A y in y;;
[%%expect{|
type nonrec ttt = X of ttt
Line _, characters 32-33:
let x: ttt = let rec y = A y in y;;
^
Error: This expression has type ttt/2 but an expression was expected of type
ttt/1
Line _, characters 0-26:
type nonrec ttt = X of ttt
^^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of type ttt/1
Line _, characters 0-30:
type ttt = A of ttt | B of uuu
^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
Definition of type ttt/2
|}]

4
testsuite/tests/typing-ocamlc-i/ocamltests
View File

@ -1 +1,5 @@
pervasives_leitmotiv.ml
pr4791.ml
pr6323.ml
pr7402.ml
pr7620_bad.ml

13
testsuite/tests/typing-ocamlc-i/pervasives_leitmotiv.compilers.reference Normal file
View File

@ -0,0 +1,13 @@
File "pervasives_leitmotiv.ml", line 1:
Warning 63: The printed interface differs from the inferred interface.
The inferred interface contained items which could not be printed
properly due to name collisions between identifiers.
File "pervasives_leitmotiv.ml", line 10, characters 0-45:
Definition of module Stdlib/1
File "_none_", line 1:
Definition of module Stdlib/2
Beware that this warning is purely informational and will not catch
all instances of erroneous printed interface.
type fpclass = A
module Stdlib : sig type fpclass = B end
val f : fpclass -> Stdlib/1.fpclass -> Stdlib/2.fpclass

14
testsuite/tests/typing-ocamlc-i/pervasives_leitmotiv.ml Normal file
View File

@ -0,0 +1,14 @@
(* TEST
flags = "-i -w +63"
* setup-ocamlc.byte-build-env
** ocamlc.byte
*** check-ocamlc.byte-output
*)
type fpclass = A
module Stdlib = struct
type fpclass = B
end
let f A Stdlib.B = FP_normal

12
testsuite/tests/typing-ocamlc-i/pr4791.compilers.reference Normal file
View File

@ -0,0 +1,12 @@
File "pr4791.ml", line 1:
Warning 63: The printed interface differs from the inferred interface.
The inferred interface contained items which could not be printed
properly due to name collisions between identifiers.
File "pr4791.ml", line 11, characters 2-12:
Definition of type t/1
File "pr4791.ml", line 8, characters 0-10:
Definition of type t/2
Beware that this warning is purely informational and will not catch
all instances of erroneous printed interface.
type t = A
module B : sig type t = B val f : t/2 -> t/1 end

13
testsuite/tests/typing-ocamlc-i/pr4791.ml Normal file
View File

@ -0,0 +1,13 @@
(* TEST
flags = "-i -w +63"
* setup-ocamlc.byte-build-env
** ocamlc.byte
*** check-ocamlc.byte-output
*)
type t = A
module B =
struct
type t = B
let f A = B
end

14
testsuite/tests/typing-ocamlc-i/pr6323.compilers.reference Normal file
View File

@ -0,0 +1,14 @@
File "pr6323.ml", line 1:
Warning 63: The printed interface differs from the inferred interface.
The inferred interface contained items which could not be printed
properly due to name collisions between identifiers.
File "pr6323.ml", line 15, characters 2-24:
Definition of type t/1
File "pr6323.ml", line 8, characters 0-26:
Definition of type t/2
Beware that this warning is purely informational and will not catch
all instances of erroneous printed interface.
type 'a t = B of 'a t list
val foo : 'a -> 'b t list -> 'c t list
module DT :
sig type 'a t = { bar : 'a; } val p : 'a t/2 list -> 'b t/2 list end

17
testsuite/tests/typing-ocamlc-i/pr6323.ml Normal file
View File

@ -0,0 +1,17 @@
(* TEST
flags = "-i -w +63"
* setup-ocamlc.byte-build-env
** ocamlc.byte
*** check-ocamlc.byte-output
*)
type 'a t = B of 'a t list
let rec foo f = function
| B(v)::tl -> B(foo f v)::foo f tl
| [] -> []
module DT = struct
type 'a t = {bar : 'a}
let p t = foo (fun x -> x) t
end

12
testsuite/tests/typing-ocamlc-i/pr7402.compilers.reference Normal file
View File

@ -0,0 +1,12 @@
File "pr7402.ml", line 1:
Warning 63: The printed interface differs from the inferred interface.
The inferred interface contained items which could not be printed
properly due to name collisions between identifiers.
File "pr7402.ml", line 14, characters 0-39:
Definition of module M/1
File "pr7402.ml", line 8, characters 0-70:
Definition of module M/2
Beware that this warning is purely informational and will not catch
all instances of erroneous printed interface.
module M : sig type t val v : t end
module F : sig module M : sig val v : M.t end val v : M/2.t end

19
testsuite/tests/typing-ocamlc-i/pr7402.ml Normal file
View File

@ -0,0 +1,19 @@
(* TEST
flags = "-i -w +63"
* setup-ocamlc.byte-build-env
** ocamlc.byte
*** check-ocamlc.byte-output
*)
module M: sig type t val v:t end = struct
type t = A
let v = A
end
module F = struct
module M = struct
let v = M.v
end
let v = M.v
end

22
toplevel/genprintval.ml
View File

@ -21,6 +21,7 @@ open Longident
open Path
open Types
open Outcometree
module Out_name = Printtyp.Out_name
module type OBJ =
sig
@ -102,7 +103,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
else if O.tag arg = Obj.double_tag then
list := Oval_float (O.obj arg : float) :: !list
else
list := Oval_constr (Oide_ident "_", []) :: !list
list := Oval_constr (Oide_ident (Out_name.create "_"), []) :: !list
done;
List.rev !list
end
@ -110,7 +111,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
let outval_of_untyped_exception bucket =
if O.tag bucket <> 0 then
Oval_constr (Oide_ident (O.obj (O.field bucket 0) : string), [])
let name = Out_name.create (O.obj (O.field bucket 0) : string) in
Oval_constr (Oide_ident name, [])
else
let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
let args =
@ -121,7 +123,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
&& O.tag(O.field bucket 1) = 0
then outval_of_untyped_exception_args (O.field bucket 1) 0
else outval_of_untyped_exception_args bucket 1 in
Oval_constr (Oide_ident name, args)
Oval_constr (Oide_ident (Out_name.create name), args)
(* The user-defined printers. Also used for some builtin types. *)
@ -201,12 +203,12 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
Oide_ident name
| Pdot(p, _s, _pos) ->
if try
match (lookup_fun (Lident name) env).desc with
match (lookup_fun (Lident (Out_name.print name)) env).desc with
| Tconstr(ty_path', _, _) -> Path.same ty_path ty_path'
| _ -> false
with Not_found -> false
then Oide_ident name
else Oide_dot (Printtyp.tree_of_path p, name)
else Oide_dot (Printtyp.tree_of_path p, Out_name.print name)
| Papply _ ->
Printtyp.tree_of_path ty_path
@ -364,7 +366,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
then nest tree_of_val depth forced_obj ty_arg
else tree_of_val depth forced_obj ty_arg
in
Oval_constr (Oide_ident "lazy", [v])
Oval_constr (Oide_ident (Out_name.create "lazy"), [v])
end
| Tconstr(path, ty_list, _) -> begin
try
@ -414,7 +416,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
lbls 0 obj unbx
in
Oval_constr(tree_of_constr env path
(Ident.name cd_id),
(Out_name.create (Ident.name cd_id)),
[ r ])
end
| {type_kind = Type_record(lbl_list, rep)} ->
@ -494,8 +496,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
(* PR#5722: print full module path only
for first record field *)
let lid =
if pos = 0 then tree_of_label env path name
else Oide_ident name
if pos = 0 then tree_of_label env path (Out_name.create name)
else Oide_ident (Out_name.create name)
and v =
if unboxed then
tree_of_val (depth - 1) obj ty_arg
@ -523,7 +525,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
and tree_of_constr_with_args
tree_of_cstr cstr_name inlined start depth obj ty_args unboxed =
let lid = tree_of_cstr cstr_name in
let lid = tree_of_cstr (Out_name.create cstr_name) in
let args =
if inlined || unboxed then
match ty_args with

2
toplevel/opttoploop.ml
View File

@ -344,7 +344,7 @@ let execute_phrase print_outcome ppf phr =
Ophr_eval (outv, ty)
| _ -> assert false
else
Ophr_signature (pr_item newenv sg'))
Ophr_signature (pr_item oldenv sg'))
else Ophr_signature []
| Exception exn ->
toplevel_env := oldenv;

2
toplevel/toploop.ml
View File

@ -272,7 +272,7 @@ let execute_phrase print_outcome ppf phr =
Ophr_eval (outv, ty)
| [] -> Ophr_signature []
| _ -> Ophr_signature (pr_item newenv sg'))
| _ -> Ophr_signature (pr_item oldenv sg'))
else Ophr_signature []
| Exception exn ->
toplevel_env := oldenv;

67
typing/includemod.ml
View File

@ -81,7 +81,7 @@ let value_descriptions ~loc env ~mark cxt subst id vd1 vd2 =
(* Inclusion between type declarations *)
let type_declarations ~loc env ~mark ?(old_env=env) cxt subst id decl1 decl2 =
let type_declarations ~loc env ~mark ?old_env:_ cxt subst id decl1 decl2 =
let mark = mark_positive mark in
if mark then
Env.mark_type_used (Ident.name id) decl1;
@ -91,7 +91,7 @@ let type_declarations ~loc env ~mark ?(old_env=env) cxt subst id decl1 decl2 =
(Ident.name id) decl1 id decl2
in
if err <> [] then
raise(Error[cxt, old_env, Type_declarations(id, decl1, decl2, err)])
raise(Error[cxt, env, Type_declarations(id, decl1, decl2, err)])
(* Inclusion between extension constructors *)
@ -104,20 +104,20 @@ let extension_constructors ~loc env ~mark cxt subst id ext1 ext2 =
(* Inclusion between class declarations *)
let class_type_declarations ~loc ~old_env env cxt subst id decl1 decl2 =
let class_type_declarations ~loc ~old_env:_ env cxt subst id decl1 decl2 =
let decl2 = Subst.cltype_declaration subst decl2 in
match Includeclass.class_type_declarations ~loc env decl1 decl2 with
[] -> ()
| reason ->
raise(Error[cxt, old_env,
raise(Error[cxt, env,
Class_type_declarations(id, decl1, decl2, reason)])
let class_declarations ~old_env env cxt subst id decl1 decl2 =
let class_declarations ~old_env:_ env cxt subst id decl1 decl2 =
let decl2 = Subst.class_declaration subst decl2 in
match Includeclass.class_declarations env decl1 decl2 with
[] -> ()
| reason ->
raise(Error[cxt, old_env, Class_declarations(id, decl1, decl2, reason)])
raise(Error[cxt, env, Class_declarations(id, decl1, decl2, reason)])
(* Expand a module type identifier when possible *)
@ -557,7 +557,6 @@ let modtypes env m1 m2 =
(* Error report *)
open Format
open Printtyp
let show_loc msg ppf loc =
let pos = loc.Location.loc_start in
@ -570,19 +569,23 @@ let show_locs ppf (loc1, loc2) =
let include_err ppf = function
| Missing_field (id, loc, kind) ->
fprintf ppf "The %s `%a' is required but not provided" kind ident id;
fprintf ppf "The %s `%a' is required but not provided"
kind Printtyp.ident id;
show_loc "Expected declaration" ppf loc
| Value_descriptions(id, d1, d2) ->
fprintf ppf
"@[<hv 2>Values do not match:@ %a@;<1 -2>is not included in@ %a@]"
(value_description id) d1 (value_description id) d2;
show_locs ppf (d1.val_loc, d2.val_loc);
!Oprint.out_sig_item (Printtyp.tree_of_value_description id d1)
!Oprint.out_sig_item (Printtyp.tree_of_value_description id d2);
show_locs ppf (d1.val_loc, d2.val_loc)
| Type_declarations(id, d1, d2, errs) ->
fprintf ppf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]"
"Type declarations do not match"
(type_declaration id) d1
!Oprint.out_sig_item
(Printtyp.tree_of_type_declaration id d1 Trec_first)
"is not included in"
(type_declaration id) d2
!Oprint.out_sig_item
(Printtyp.tree_of_type_declaration id d2 Trec_first)
show_locs (d1.type_loc, d2.type_loc)
(Includecore.report_type_mismatch
"the first" "the second" "declaration") errs
@ -590,21 +593,23 @@ let include_err ppf = function
fprintf ppf
"@[<hv 2>Extension declarations do not match:@ \
%a@;<1 -2>is not included in@ %a@]"
(extension_constructor id) x1
(extension_constructor id) x2;
!Oprint.out_sig_item
(Printtyp.tree_of_extension_constructor id x1 Text_first)
!Oprint.out_sig_item
(Printtyp.tree_of_extension_constructor id x2 Text_first);
show_locs ppf (x1.ext_loc, x2.ext_loc)
| Module_types(mty1, mty2)->
fprintf ppf
"@[<hv 2>Modules do not match:@ \
%a@;<1 -2>is not included in@ %a@]"
modtype mty1
modtype mty2
!Oprint.out_module_type (Printtyp.tree_of_modtype mty1)
!Oprint.out_module_type (Printtyp.tree_of_modtype mty2)
| Modtype_infos(id, d1, d2) ->
fprintf ppf
"@[<hv 2>Module type declarations do not match:@ \
%a@;<1 -2>does not match@ %a@]"
(modtype_declaration id) d1
(modtype_declaration id) d2
!Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d1)
!Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d2)
| Modtype_permutation ->
fprintf ppf "Illegal permutation of structure fields"
| Interface_mismatch(impl_name, intf_name) ->
@ -614,15 +619,17 @@ let include_err ppf = function
fprintf ppf
"@[<hv 2>Class type declarations do not match:@ \
%a@;<1 -2>does not match@ %a@]@ %a"
(Printtyp.cltype_declaration id) d1
(Printtyp.cltype_declaration id) d2
!Oprint.out_sig_item
(Printtyp.tree_of_cltype_declaration id d1 Trec_first)
!Oprint.out_sig_item
(Printtyp.tree_of_cltype_declaration id d2 Trec_first)
Includeclass.report_error reason
| Class_declarations(id, d1, d2, reason) ->
fprintf ppf
"@[<hv 2>Class declarations do not match:@ \
%a@;<1 -2>does not match@ %a@]@ %a"
(Printtyp.class_declaration id) d1
(Printtyp.class_declaration id) d2
!Oprint.out_sig_item (Printtyp.tree_of_class_declaration id d1 Trec_first)
!Oprint.out_sig_item (Printtyp.tree_of_class_declaration id d2 Trec_first)
Includeclass.report_error reason
| Unbound_modtype_path path ->
fprintf ppf "Unbound module type %a" Printtyp.path path
@ -633,13 +640,14 @@ let include_err ppf = function
let rec context ppf = function
Module id :: rem ->
fprintf ppf "@[<2>module %a%a@]" ident id args rem
fprintf ppf "@[<2>module %a%a@]" Printtyp.ident id args rem
| Modtype id :: rem ->
fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem
fprintf ppf "@[<2>module type %a =@ %a@]"
Printtyp.ident id context_mty rem
| Body x :: rem ->
fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem
| Arg x :: rem ->
fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem
fprintf ppf "functor (%a : %a) -> ..." Printtyp.ident x context_mty rem
| [] ->
fprintf ppf "<here>"
and context_mty ppf = function
@ -650,7 +658,7 @@ and args ppf = function
Body x :: rem ->
fprintf ppf "(%s)%a" (argname x) args rem
| Arg x :: rem ->
fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem
fprintf ppf "(%a :@ %a) : ..." Printtyp.ident x context_mty rem
| cxt ->
fprintf ppf " :@ %a" context_mty cxt
and argname x =
@ -669,7 +677,7 @@ let path_of_context = function
let context ppf cxt =
if cxt = [] then () else
if List.for_all (function Module _ -> true | _ -> false) cxt then
fprintf ppf "In module %a:@ " path (path_of_context cxt)
fprintf ppf "In module %a:@ " Printtyp.path (path_of_context cxt)
else
fprintf ppf "@[<hv 2>At position@ %a@]@ " context cxt
@ -696,8 +704,9 @@ let report_error ppf errs =
else if !pe then (fprintf ppf "...@ "; pe := false)
in
let print_errs ppf = List.iter (include_err' ppf) in
fprintf ppf "@[<v>%a%a@]" print_errs errs include_err err
Printtyp.Conflicts.reset();
fprintf ppf "@[<v>%a%a%t@]" print_errs errs include_err err
Printtyp.Conflicts.print
(* We could do a better job to split the individual error items
as sub-messages of the main interface mismatch on the whole unit. *)

4
typing/oprint.ml
View File

@ -28,7 +28,7 @@ let print_lident ppf = function
let rec print_ident ppf =
function
Oide_ident s -> print_lident ppf s
Oide_ident s -> print_lident ppf s.printed_name
| Oide_dot (id, s) ->
print_ident ppf id; pp_print_char ppf '.'; print_lident ppf s
| Oide_apply (id1, id2) ->
@ -309,7 +309,7 @@ and print_simple_out_type ppf =
| Otyp_sum _ | Otyp_manifest (_, _) -> ()
| Otyp_record lbls -> print_record_decl ppf lbls
| Otyp_module (p, n, tyl) ->
fprintf ppf "@[<1>(module %s" p;
fprintf ppf "@[<1>(module %a" print_ident p;
let first = ref true in
List.iter2
(fun s t ->

8
typing/outcometree.mli
View File

@ -22,10 +22,14 @@
[Toploop.print_out_sig_item]
[Toploop.print_out_phrase] *)
(** An [out_name] is a string representation of an identifier which can be
rewritten on the fly to avoid name collisions *)
type out_name = { mutable printed_name: string }
type out_ident =
| Oide_apply of out_ident * out_ident
| Oide_dot of out_ident * string
| Oide_ident of string
| Oide_ident of out_name
type out_string =
| Ostr_string
@ -69,7 +73,7 @@ type out_type =
| Otyp_variant of
bool * out_variant * bool * (string list) option
| Otyp_poly of string list * out_type
| Otyp_module of string * string list * out_type list
| Otyp_module of out_ident * string list * out_type list
| Otyp_attribute of out_type * out_attribute
and out_variant =

520
typing/printtyp.ml
View File

@ -32,24 +32,255 @@ let rec longident ppf = function
| Ldot(p, s) -> fprintf ppf "%a.%s" longident p s
| Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2
(* Print an identifier *)
(* Print an identifier avoiding name collisions *)
let unique_names = ref Ident.empty
module Out_name = struct
let create x = { printed_name = x }
let print x = x.printed_name
let set out_name x = out_name.printed_name <- x
end
let ident_name id =
try Ident.find_same id !unique_names with Not_found -> Ident.name id
(* printing environment for path shortening and naming *)
let printing_env = ref Env.empty
let human_unique n id = Printf.sprintf "%s/%d" (Ident.name id) n
let add_unique id =
try ignore (Ident.find_same id !unique_names)
with Not_found ->
unique_names := Ident.add id (Ident.unique_toplevel_name id) !unique_names
type namespace =
| Type
| Module
| Module_type
| Class
| Class_type
| Other (** Other bypasses the unique name identifier mechanism *)
let ident ppf id = pp_print_string ppf (ident_name id)
module Namespace = struct
let id = function
| Type -> 0
| Module -> 1
| Module_type -> 2
| Class -> 3
| Class_type -> 4
| Other -> 5
let size = 1 + id Other
let show =
function
| Type -> "type"
| Module -> "module"
| Module_type -> "module type"
| Class -> "class"
| Class_type -> "class type"
| Other -> ""
let lookup =
let to_lookup f lid =
fst @@ f ?loc:None ?mark:(Some false) (Lident lid) !printing_env in
function
| Type -> fun id -> Env.lookup_type ?loc:None (Lident id) !printing_env
| Module -> fun id ->
Env.lookup_module ~load:false ?loc:None (Lident id) !printing_env
| Module_type -> to_lookup Env.lookup_modtype
| Class -> to_lookup Env.lookup_class
| Class_type -> to_lookup Env.lookup_cltype
| Other -> fun _ -> raise Not_found
let location namespace id =
let env = !printing_env in
let path = Path.Pident id in
try Some (
match namespace with
| Type -> (Env.find_type path env).type_loc
| Module -> (Env.find_module path env).md_loc
| Module_type -> (Env.find_modtype path env).mtd_loc
| Class -> (Env.find_class path env).cty_loc
| Class_type -> (Env.find_cltype path env).clty_loc
| Other -> Location.none
) with Not_found -> None
let best_class_namespace = function
| Papply _ | Pdot _ -> Module
| Pident c ->
match location Class c with
| Some _ -> Class
| None -> Class_type
end
(** {2 Conflicts printing}
Conflicts arise when multiple items are attributed the same name,
the following module stores the global conflict references and
provides the printing functions for explaining the source of
the conflicts.
*)
module Conflicts = struct
module M = Misc.StringMap
type explanation = { kind: namespace; name:string; location:Location.t}
let explanations = ref M.empty
let explain namespace n id =
let name = human_unique n id in
if not (M.mem name !explanations) then
match Namespace.location namespace id with
| None -> ()
| Some location ->
explanations :=
M.add name { kind = namespace; location; name } !explanations
let pp_explanation ppf r=
Format.fprintf ppf "@[<v 2>%aDefinition of %s %s@]"
Location.print r.location (Namespace.show r.kind) r.name
let pp ppf l =
Format.fprintf ppf "@[<v>%a@]" (Format.pp_print_list pp_explanation) l
let reset () = explanations := M.empty
let take () =
let c = !explanations in
reset ();
c |> M.bindings |> List.map snd |> List.sort Pervasives.compare
let print ppf =
let sep ppf = Format.fprintf ppf "@ " in
let l =
List.filter (* remove toplevel locations, since they are too imprecise *)
( fun a ->
a.location.Location.loc_start.Lexing.pos_fname <> "//toplevel//" )
(take ()) in
match l with
| [] -> ()
| l -> Format.fprintf ppf "%t%a" sep pp l
let exists () = M.cardinal !explanations >0
end
module Naming_context = struct
module M = Misc.StringMap
module N = Map.Make(struct type t = int let compare = Pervasives.compare end)
module S = Misc.StringSet
let enabled = ref true
let enable b = enabled := b
(** Name mapping *)
type mapping =
| Need_unique_name of int N.t
(** The same name has already been attributed to multiple types.
The [map] argument contains the specific binding time attributed to each
types.
*)
| Uniquely_associated_to of Ident.t * out_name
(** For now, the name [Ident.name id] has been attributed to [id],
[out_name] is used to expand this name if a conflict arises
at a later point
*)
| Associated_to_pervasives of out_name
(** [Associated_to_pervasives out_name] is used when the item
[Pervasives.$name] has been associated to the name [$name].
Upon a conflict, this name will be expanded to ["Pervasives." ^ name ] *)
let hid_start = 0
let add_hid_id id map =
let new_id = 1 + N.fold (fun _ -> max) map hid_start in
new_id, N.add (Ident.binding_time id) new_id map
let find_hid id map =
try N.find (Ident.binding_time id) map, map with
Not_found -> add_hid_id id map
let pervasives name = "Pervasives." ^ name
let map = Array.make Namespace.size M.empty
let get namespace = map.(Namespace.id namespace)
let set namespace x = map.(Namespace.id namespace) <- x
(* Names used in recursive definitions are not considered when determining
if a name is already attributed in the current environment.
This is a weaker version of hidden_rec_items used by short-path. *)
let protected = ref S.empty
let add_protected id = protected := S.add (Ident.name id) !protected
let reset_protected () = protected := S.empty
let pervasives_name namespace name =
if not !enabled then Out_name.create name else
match M.find name (get namespace) with
| Associated_to_pervasives r -> r
| Need_unique_name _ -> Out_name.create (pervasives name)
| Uniquely_associated_to (id',r) ->
let hid, map = add_hid_id id' N.empty in
Out_name.set r (human_unique hid id');
Conflicts.explain namespace hid id';
set namespace @@ M.add name (Need_unique_name map) (get namespace);
Out_name.create (pervasives name)
| exception Not_found ->
let r = Out_name.create name in
set namespace @@ M.add name (Associated_to_pervasives r) (get namespace);
r
(** Lookup for preexisting named item within the current {!printing_env} *)
let env_ident namespace name =
if S.mem name !protected then None else
match Namespace.lookup namespace name with
| Pident id -> Some id
| _ -> None
| exception Not_found -> None
(** Associate a name to the identifier [id] within [namespace] *)
let ident_name_simple namespace id =
if not !enabled then Out_name.create (Ident.name id) else
let name = Ident.name id in
match M.find name (get namespace) with
| Uniquely_associated_to (id',r) when Ident.same id id' ->
r
| Need_unique_name map ->
let hid, m = find_hid id map in
Conflicts.explain namespace hid id;
set namespace @@ M.add name (Need_unique_name m) (get namespace);
Out_name.create (human_unique hid id)
| Uniquely_associated_to (id',r) ->
let hid', m = find_hid id' N.empty in
let hid, m = find_hid id m in
Out_name.set r (human_unique hid' id');
List.iter (fun (id,hid) -> Conflicts.explain namespace hid id)
[id, hid; id', hid' ];
set namespace @@ M.add name (Need_unique_name m) (get namespace);
Out_name.create (human_unique hid id)
| Associated_to_pervasives r ->
Out_name.set r ("Pervasives." ^ Out_name.print r);
let hid, m = find_hid id N.empty in
set namespace @@ M.add name (Need_unique_name m) (get namespace);
Out_name.create (human_unique hid id)
| exception Not_found ->
let r = Out_name.create name in
set namespace
@@ M.add name (Uniquely_associated_to (id,r) ) (get namespace);
r
(** Same as {!ident_name_simple} but lookup to existing named identifiers
in the current {!printing_env} *)
let ident_name namespace id =
begin match env_ident namespace (Ident.name id) with
| Some id' -> ignore (ident_name_simple namespace id')
| None -> ()
end;
ident_name_simple namespace id
let reset () =
Array.iteri ( fun i _ -> map.(i) <- M.empty ) map
end
let ident_name = Naming_context.ident_name
let reset_naming_context = Naming_context.reset
let ident ppf id = pp_print_string ppf
(Out_name.print (Naming_context.ident_name_simple Other id))
(* Print a path *)
let ident_stdlib = Ident.create_persistent "Stdlib"
let printing_env = ref Env.empty
let non_shadowed_pervasive = function
| Pdot(Pident id, s, _) as path ->
Ident.same id ident_stdlib &&
@ -126,17 +357,15 @@ let rewrite_double_underscore_paths env p =
else
rewrite_double_underscore_paths env p
let rec tree_of_path = function
let rec tree_of_path namespace = function
| Pident id ->
Oide_ident (ident_name id)
| Pdot(_, s, _pos) as path
when non_shadowed_pervasive path ->
Oide_ident s
Oide_ident (ident_name namespace id)
| Pdot(_, s, _pos) as path when non_shadowed_pervasive path ->
Oide_ident (Naming_context.pervasives_name namespace s)
| Pdot(p, s, _pos) ->
Oide_dot (tree_of_path p, s)
Oide_dot (tree_of_path Module p, s)
| Papply(p1, p2) ->
Oide_apply (tree_of_path p1,
tree_of_path p2)
Oide_apply (tree_of_path Module p1, tree_of_path Module p2)
let rec path ppf = function
| Pident id ->
@ -151,19 +380,24 @@ let rec path ppf = function
| Papply(p1, p2) ->
fprintf ppf "%a(%a)" path p1 path p2
let tree_of_path p =
tree_of_path (rewrite_double_underscore_paths !printing_env p)
let tree_of_path namespace p =
tree_of_path namespace (rewrite_double_underscore_paths !printing_env p)
let path ppf p =
path ppf (rewrite_double_underscore_paths !printing_env p)
let rec string_of_out_ident = function
| Oide_ident s -> s
| Oide_ident s -> Out_name.print s
| Oide_dot (id, s) -> String.concat "." [string_of_out_ident id; s]
| Oide_apply (id1, id2) ->
String.concat ""
[string_of_out_ident id1; "("; string_of_out_ident id2; ")"]
let string_of_path p = string_of_out_ident (tree_of_path p)
let string_of_path p = string_of_out_ident (tree_of_path Other p)
let strings_of_paths namespace p =
reset_naming_context ();
let trees = List.map (tree_of_path namespace) p in
List.map string_of_out_ident trees
(* Print a recursive annotation *)
@ -417,7 +651,7 @@ let set_printing_env env =
end
let wrap_printing_env env f =
set_printing_env env;
set_printing_env env; reset_naming_context ();
try_finally f (fun () -> set_printing_env Env.empty)
let wrap_printing_env ~error env f =
@ -642,14 +876,18 @@ let mark_loops ty =
let reset_loop_marks () =
visited_objects := []; aliased := []; delayed := []
let reset_except_context () =
reset_names (); reset_loop_marks ()
let reset () =
unique_names := Ident.empty; reset_names (); reset_loop_marks ()
reset_naming_context (); Conflicts.reset ();
reset_except_context ()
let reset_and_mark_loops ty =
reset (); mark_loops ty
reset_except_context (); mark_loops ty
let reset_and_mark_loops_list tyl =
reset (); List.iter mark_loops tyl
reset_except_context (); List.iter mark_loops tyl
(* Disabled in classic mode when printing an unification error *)
let print_labels = ref true
@ -691,7 +929,7 @@ let rec tree_of_typexp sch ty =
let p', s = best_type_path p in
let tyl' = apply_subst s tyl in
if is_nth s && not (tyl'=[]) then tree_of_typexp sch (List.hd tyl') else
Otyp_constr (tree_of_path p', tree_of_typlist sch tyl')
Otyp_constr (tree_of_path Type p', tree_of_typlist sch tyl')
| Tvariant row ->
let row = row_repr row in
let fields =
@ -710,7 +948,7 @@ let rec tree_of_typexp sch ty =
begin match row.row_name with
| Some(p, tyl) when namable_row row ->
let (p', s) = best_type_path p in
let id = tree_of_path p' in
let id = tree_of_path Type p' in
let args = tree_of_typlist sch (apply_subst s tyl) in
let out_variant =
if is_nth s then List.hd args else Otyp_constr (id, args) in
@ -760,7 +998,7 @@ let rec tree_of_typexp sch ty =
| Tpackage (p, n, tyl) ->
let n =
List.map (fun li -> String.concat "." (Longident.flatten li)) n in
Otyp_module (Path.name p, n, tree_of_typlist sch tyl)
Otyp_module (tree_of_path Module_type p, n, tree_of_typlist sch tyl)
in
if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed;
if is_aliased px && aliasable ty then begin
@ -804,7 +1042,7 @@ and tree_of_typobject sch fi nm =
let args = tree_of_typlist sch tyl in
let (p', s) = best_type_path p in
assert (s = Id);
Otyp_class (non_gen, tree_of_path p', args)
Otyp_class (non_gen, tree_of_path Type p', args)
| _ ->
fatal_error "Printtyp.tree_of_typobject"
end
@ -836,15 +1074,6 @@ and type_sch ppf ty = typexp true ppf ty
and type_scheme ppf ty = reset_and_mark_loops ty; typexp true ppf ty
let type_expansion ppf ty1 ty2 =
let tree1 = tree_of_typexp false ty1 in
let tree2 = tree_of_typexp false ty2 in
let pp = !Oprint.out_type in
if tree1 = tree2 then
pp ppf tree1
else
fprintf ppf "@[<2>%a@ =@ %a@]" pp tree1 pp tree2
(* Maxence *)
let type_scheme_max ?(b_reset_names=true) ppf ty =
if b_reset_names then reset_names () ;
@ -881,7 +1110,7 @@ let mark_loops_constructor_arguments = function
let rec tree_of_type_decl id decl =
reset();
reset_except_context();
let params = filter_params decl.type_params in
@ -1028,7 +1257,7 @@ let constructor_arguments ppf a =
(* Print an extension declaration *)
let tree_of_extension_constructor id ext es =
reset ();
reset_except_context ();
let ty_name = Path.name ext.ext_type_path in
let ty_params = filter_params ext.ext_type_params in
List.iter add_alias ty_params;
@ -1148,7 +1377,8 @@ let rec tree_of_class_type sch params =
then
tree_of_class_type sch params cty
else
Octy_constr (tree_of_path p', tree_of_typlist true tyl)
let namespace = Namespace.best_class_namespace p' in
Octy_constr (tree_of_path namespace p', tree_of_typlist true tyl)
| Cty_signature sign ->
let sty = repr sign.csig_self in
let self_ty =
@ -1211,7 +1441,7 @@ let class_variance =
let tree_of_class_declaration id cl rs =
let params = filter_params cl.cty_params in
reset ();
reset_except_context ();
List.iter add_alias params;
prepare_class_type params cl.cty_type;
let sty = Ctype.self_type cl.cty_type in
@ -1233,7 +1463,7 @@ let class_declaration id ppf cl =
let tree_of_cltype_declaration id cl rs =
let params = List.map repr cl.clty_params in
reset ();
reset_except_context ();
List.iter add_alias params;
prepare_class_type params cl.clty_type;
let sty = Ctype.self_type cl.clty_type in
@ -1291,6 +1521,10 @@ let dummy =
type_unboxed = unboxed_false_default_false;
}
let hide ids env = List.fold_right
(fun id -> Env.add_type ~check:false (Ident.rename id) dummy)
ids env
let hide_rec_items = function
| Sig_type(id, _decl, rs) ::rem
when rs = Trec_first && not !Clflags.real_paths ->
@ -1301,14 +1535,37 @@ let hide_rec_items = function
in
let ids = id :: get_ids rem in
set_printing_env
(List.fold_right
(fun id -> Env.add_type ~check:false (Ident.rename id) dummy)
ids !printing_env)
(hide ids !printing_env)
| _ -> ()
let recursive_sigitem = function
| Sig_class(id,_,rs) -> Some(id,rs,3)
| Sig_class_type (id,_,rs) -> Some(id,rs,2)
| Sig_type(id, _, rs)
| Sig_module(id, _, rs) -> Some (id,rs,0)
| _ -> None
let skip k l = snd (Misc.Stdlib.List.split_at k l)
let protect_rec_items items =
let rec get_ids recs = function
| [] -> []
| item :: rem -> match recursive_sigitem item with
| Some (id, r, k ) when r = recs -> id :: get_ids Trec_next (skip k rem)
| _ -> [] in
List.iter Naming_context.add_protected (get_ids Trec_first items)
let still_in_type_group env' in_type_group item =
match in_type_group, recursive_sigitem item with
true, Some (_,Trec_next,_) -> true
| _, Some (_, (Trec_not | Trec_first),_) ->
Naming_context.reset_protected ();
set_printing_env env'; true
| _ -> Naming_context.reset_protected (); set_printing_env env'; false
let rec tree_of_modtype ?(ellipsis=false) = function
| Mty_ident p ->
Omty_ident (tree_of_path p)
Omty_ident (tree_of_path Module_type p)
| Mty_signature sg ->
Omty_signature (if ellipsis then [Osig_ellipsis]
else tree_of_signature sg)
@ -1322,7 +1579,7 @@ let rec tree_of_modtype ?(ellipsis=false) = function
Omty_functor (Ident.name param,
may_map (tree_of_modtype ~ellipsis:false) ty_arg, res)
| Mty_alias(_, p) ->
Omty_alias (tree_of_path p)
Omty_alias (tree_of_path Module p)
and tree_of_signature sg =
wrap_env (fun env -> env) (tree_of_signature_rec !printing_env false) sg
@ -1330,15 +1587,11 @@ and tree_of_signature sg =
and tree_of_signature_rec env' in_type_group = function
[] -> []
| item :: rem as items ->
let in_type_group =
match in_type_group, item with
true, Sig_type (_, _, Trec_next) -> true
| _, Sig_type (_, _, (Trec_not | Trec_first)) ->
set_printing_env env'; true
| _ -> set_printing_env env'; false
in
let in_type_group = still_in_type_group env' in_type_group item in
let (sg, rem) = filter_rem_sig item rem in
hide_rec_items items;
protect_rec_items items;
reset_naming_context ();
let trees = trees_of_sigitem item in
let env' = Env.add_signature (item :: sg) env' in
trees @ tree_of_signature_rec env' in_type_group rem
@ -1398,15 +1651,20 @@ let refresh_weak () =
let print_items showval env x =
refresh_weak();
let rec print showval env = function
reset_naming_context ();
Conflicts.reset ();
let rec print showval in_type_group env = function
| [] -> []
| item :: rem as items ->
let (_sg, rem) = filter_rem_sig item rem in
let in_type_group = still_in_type_group env in_type_group item in
let (sg, rem) = filter_rem_sig item rem in
hide_rec_items items;
protect_rec_items items;
reset_naming_context ();
let trees = trees_of_sigitem item in
List.map (fun d -> (d, showval env item)) trees @
print showval env rem in
print showval env x
print showval in_type_group (Env.add_signature (item :: sg) env) rem in
print showval false env x
(* Print a signature body (used by -i when compiling a .ml) *)
@ -1416,6 +1674,22 @@ let print_signature ppf tree =
let signature ppf sg =
fprintf ppf "%a" print_signature (tree_of_signature sg)
(* Print a signature body (used by -i when compiling a .ml) *)
let printed_signature sourcefile ppf sg =
(* we are tracking any collision event for warning 63 *)
Conflicts.reset ();
reset_naming_context ();
let t = tree_of_signature sg in
if Warnings.(is_active @@ Erroneous_printed_signature "")
&& Conflicts.exists ()
then begin
let conflicts = Format.asprintf "%t" Conflicts.print in
Location.prerr_warning (Location.in_file sourcefile)
(Warnings.Erroneous_printed_signature conflicts);
Warnings.check_fatal ()
end;
fprintf ppf "%a" print_signature t
(* Print an unification error *)
let same_path t t' =
@ -1435,22 +1709,42 @@ let same_path t t' =
| _ ->
false
let type_expansion t ppf t' =
if same_path t t'
then begin add_delayed (proxy t); type_expr ppf t end
else
let t' = if proxy t == proxy t' then unalias t' else t' in
type_expansion ppf t t'
type 'a diff = Same of 'a | Diff of 'a * 'a
let type_path_expansion tp ppf tp' =
if Path.same tp tp' then path ppf tp else
fprintf ppf "@[<2>%a@ =@ %a@]" path tp path tp'
let trees_of_type_expansion (t,t') =
if same_path t t'
then begin add_delayed (proxy t); Same (tree_of_typexp false t) end
else
let t' = if proxy t == proxy t' then unalias t' else t' in
(* beware order matter due to side effect,
e.g. when printing object types *)
let first = tree_of_typexp false t in
let second = tree_of_typexp false t' in
if first = second then Same first
else Diff(first,second)
let type_expansion ppf = function
| Same t -> !Oprint.out_type ppf t
| Diff(t,t') ->
fprintf ppf "@[<2>%a@ =@ %a@]" !Oprint.out_type t !Oprint.out_type t'
let trees_of_trace = List.map trees_of_type_expansion
let trees_of_type_path_expansion (tp,tp') =
if Path.same tp tp' then Same(tree_of_path Type tp) else
Diff(tree_of_path Type tp, tree_of_path Type tp')
let type_path_expansion ppf = function
| Same p -> fprintf ppf "%s" (string_of_out_ident p)
| Diff(p,p') ->
fprintf ppf "@[<2>%s@ =@ %s@]" (string_of_out_ident p)
(string_of_out_ident p')
let rec trace fst txt ppf = function
| (t1, t1') :: (t2, t2') :: rem ->
| te :: te2 :: rem ->
if not fst then fprintf ppf "@,";
fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@] %a"
(type_expansion t1) t1' txt (type_expansion t2) t2'
type_expansion te txt type_expansion te2
(trace false txt) rem
| _ -> ()
@ -1466,13 +1760,9 @@ let rec filter_trace keep_last = function
else (t1, t1') :: (t2, t2') :: rem'
| _ -> []
let rec type_path_list ppf = function
| [tp, tp'] -> type_path_expansion tp ppf tp'
| (tp, tp') :: rem ->
fprintf ppf "%a@;<2 0>%a"
(type_path_expansion tp) tp'
type_path_list rem
| [] -> ()
let type_path_list =
Format.pp_print_list ~pp_sep:(fun ppf () -> Format.pp_print_break ppf 2 0)
type_path_expansion
(* Hide variant name and var, to force printing the expanded type *)
let hide_variant_name t =
@ -1631,33 +1921,8 @@ let warn_on_missing_def env ppf t =
end
| _ -> ()
let ident_same_name id1 id2 =
if Ident.equal id1 id2 && not (Ident.same id1 id2) then begin
add_unique id1; add_unique id2
end
let rec path_same_name p1 p2 =
match p1, p2 with
Pident id1, Pident id2 -> ident_same_name id1 id2
| Pdot (p1, s1, _), Pdot (p2, s2, _) when s1 = s2 -> path_same_name p1 p2
| Papply (p1, p1'), Papply (p2, p2') ->
path_same_name p1 p2; path_same_name p1' p2'
| _ -> ()
let type_same_name t1 t2 =
match (repr t1).desc, (repr t2).desc with
Tconstr (p1, _, _), Tconstr (p2, _, _) ->
path_same_name (fst (best_type_path p1)) (fst (best_type_path p2))
| _ -> ()
let rec trace_same_names = function
(t1, t1') :: (t2, t2') :: rem ->
type_same_name t1 t2; type_same_name t1' t2'; trace_same_names rem
| _ -> ()
let unification_error env unif tr txt1 ppf txt2 ty_expect_explanation =
reset ();
trace_same_names tr;
let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in
let mis = mismatch env unif tr in
match tr with
@ -1669,6 +1934,9 @@ let unification_error env unif tr txt1 ppf txt2 ty_expect_explanation =
and t2, t2' = may_prepare_expansion (tr = []) t2 in
print_labels := not !Clflags.classic;
let tr = List.map prepare_expansion tr in
let te1 = trees_of_type_expansion (t1,t1')
and te2 = trees_of_type_expansion (t2,t2')
and tr = trees_of_trace tr in
fprintf ppf
"@[<v>\
@[%t@;<1 2>%a@ \
@ -1676,8 +1944,8 @@ let unification_error env unif tr txt1 ppf txt2 ty_expect_explanation =
%t\
@]%a%t\
@]"
txt1 (type_expansion t1) t1'
txt2 (type_expansion t2) t2'
txt1 type_expansion te1
txt2 type_expansion te2
ty_expect_explanation
(trace false "is not compatible with type") tr
(explain mis);
@ -1686,6 +1954,7 @@ let unification_error env unif tr txt1 ppf txt2 ty_expect_explanation =
warn_on_missing_def env ppf t1;
warn_on_missing_def env ppf t2
end;
Conflicts.print ppf;
print_labels := true
with exn ->
print_labels := true;
@ -1701,11 +1970,13 @@ let report_unification_error ppf env ?(unif=true) tr
let trace fst keep_last txt ppf tr =
print_labels := not !Clflags.classic;
trace_same_names tr;
try match tr with
t1 :: t2 :: tr' ->
if fst then trace fst txt ppf (t1 :: t2 :: filter_trace keep_last tr')
else trace fst txt ppf (filter_trace keep_last tr);
let t1 = trees_of_type_expansion t1 in
let t2 = trees_of_type_expansion t2 in
let tr = trees_of_trace (filter_trace keep_last tr') in
if fst then trace fst txt ppf (t1 :: t2 :: tr)
else trace fst txt ppf tr;
print_labels := true
| _ -> ()
with exn ->
@ -1720,29 +1991,38 @@ let report_subtyping_error ppf env tr1 txt1 tr2 =
fprintf ppf "@[<v>%a" (trace true (tr2 = []) txt1) tr1;
if tr2 = [] then fprintf ppf "@]" else
let mis = mismatch env true tr2 in
fprintf ppf "%a%t@]"
fprintf ppf "%a%t%t@]"
(trace false (mis = None) "is not compatible with type") tr2
(explain mis))
(explain mis)
Conflicts.print
)
let report_ambiguous_type_error ppf env (tp0, tp0') tpl txt1 txt2 txt3 =
let report_ambiguous_type_error ppf env tp0 tpl txt1 txt2 txt3 =
wrap_printing_env ~error:true env (fun () ->
reset ();
List.iter
(fun (tp, tp') -> path_same_name tp0 tp; path_same_name tp0' tp')
tpl;
match tpl with
let tp0 = trees_of_type_path_expansion tp0 in
match tpl with
[] -> assert false
| [tp, tp'] ->
| [tp] ->
fprintf ppf
"@[%t@;<1 2>%a@ \
%t@;<1 2>%a\
@]"
txt1 (type_path_expansion tp) tp'
txt3 (type_path_expansion tp0) tp0'
txt1 type_path_expansion (trees_of_type_path_expansion tp)
txt3 type_path_expansion tp0
| _ ->
fprintf ppf
"@[%t@;<1 2>@[<hv>%a@]\
@ %t@;<1 2>%a\
@]"
txt2 type_path_list tpl
txt3 (type_path_expansion tp0) tp0')
txt2 type_path_list (List.map trees_of_type_path_expansion tpl)
txt3 type_path_expansion tp0)
(* Adapt functions to exposed interface *)
let tree_of_path = tree_of_path Other
let tree_of_modtype = tree_of_modtype ~ellipsis:false
let type_expansion ty ppf ty' =
type_expansion ppf (trees_of_type_expansion (ty,ty'))
let tree_of_type_declaration id td rs =
wrap_env (hide [id]) (fun () -> tree_of_type_declaration id td rs) ()

51
typing/printtyp.mli
View File

@ -24,6 +24,24 @@ val ident: formatter -> Ident.t -> unit
val tree_of_path: Path.t -> out_ident
val path: formatter -> Path.t -> unit
val string_of_path: Path.t -> string
module Out_name: sig
val create: string -> out_name
val print: out_name -> string
end
type namespace =
| Type
| Module
| Module_type
| Class
| Class_type
| Other (** Other bypasses the unique name for identifier mechanism *)
val strings_of_paths: namespace -> Path.t list -> string list
(** Print a list of paths, using the same naming context to
avoid name collisions *)
val raw_type_expr: formatter -> type_expr -> unit
val string_of_label: Asttypes.arg_label -> string
@ -32,6 +50,34 @@ val wrap_printing_env: error:bool -> Env.t -> (unit -> 'a) -> 'a
(* This affects all the printing functions below *)
(* Also, if [~error:true], then disable the loading of cmis *)
module Naming_context: sig
val enable: bool -> unit
(** When contextual names are enabled, the mapping between identifiers
and names is ensured to be one-to-one. *)
val reset: unit -> unit
(** Reset the naming context *)
end
(** The [Conflicts] module keeps track of conflicts arising when attributing
names to identifiers and provides functions that can print explanations
for these conflict in error messages *)
module Conflicts: sig
val exists: unit -> bool
(** [exists()] returns true if the current naming context renamed
an identifier to avoid a name collision *)
type explanation =
{ kind: namespace;
name:string; location:Location.t}
val take: unit -> explanation list
val pp: Format.formatter -> explanation list -> unit
val print: Format.formatter -> unit
val reset: unit -> unit
end
val reset: unit -> unit
val mark_loops: type_expr -> unit
val reset_and_mark_loops: type_expr -> unit
@ -59,6 +105,7 @@ val tree_of_module:
Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item
val modtype: formatter -> module_type -> unit
val signature: formatter -> signature -> unit
val tree_of_modtype: module_type -> out_module_type
val tree_of_modtype_declaration:
Ident.t -> modtype_declaration -> out_sig_item
val tree_of_signature: Types.signature -> out_sig_item list
@ -95,3 +142,7 @@ val print_items: (Env.t -> signature_item -> 'a option) ->
(* Simple heuristic to rewrite Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias
for Foo__bar. This pattern is used by the stdlib. *)
val rewrite_double_underscore_paths: Env.t -> Path.t -> Path.t
(** [printed_signature sourcefile ppf sg] print the signature [sg] of
[sourcefile] with potential warnings for name collisions *)
val printed_signature: string -> formatter -> signature -> unit

14
typing/typeclass.ml
View File

@ -1887,9 +1887,9 @@ let report_error env ppf = function
Printtyp.reset_and_mark_loops_list [abbrev; actual; expected];
fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \
but is used with type@ %a@]"
Printtyp.type_expr abbrev
Printtyp.type_expr actual
Printtyp.type_expr expected
!Oprint.out_type (Printtyp.tree_of_typexp false abbrev)
!Oprint.out_type (Printtyp.tree_of_typexp false actual)
!Oprint.out_type (Printtyp.tree_of_typexp false expected)
| Constructor_type_mismatch (c, trace) ->
Printtyp.report_unification_error ppf env trace
(function ppf ->
@ -1929,7 +1929,9 @@ let report_error env ppf = function
fprintf ppf
"@[The abbreviation %a@ is used with parameters@ %a@ \
which are incompatible with constraints@ %a@]"
Printtyp.ident id Printtyp.type_expr params Printtyp.type_expr cstrs
Printtyp.ident id
!Oprint.out_type (Printtyp.tree_of_typexp false params)
!Oprint.out_type (Printtyp.tree_of_typexp false cstrs)
| Class_match_failure error ->
Includeclass.report_error ppf error
| Unbound_val lab ->
@ -1941,7 +1943,9 @@ let report_error env ppf = function
List.iter Printtyp.mark_loops [ty; ty1];
fprintf ppf
"The %s %s@ has type@;<1 2>%a@ where@ %a@ is unbound"
kind lab Printtyp.type_expr ty Printtyp.type_expr ty0
kind lab
!Oprint.out_type (Printtyp.tree_of_typexp false ty)
!Oprint.out_type (Printtyp.tree_of_typexp false ty0)
in
let print_reason ppf = function
| Ctype.CC_Method (ty0, real, lab, ty) ->

24
typing/typecore.ml
View File

@ -719,7 +719,9 @@ end) = struct
let tpaths = unique (compare_type_path env) [tpath] others in
match tpaths with
[_] -> []
| _ -> List.map Printtyp.string_of_path tpaths
| _ -> let open Printtyp in
wrap_printing_env ~error:true env (fun () ->
reset(); strings_of_paths Type tpaths)
let disambiguate_by_type env tpath lbls =
let check_type (lbl, _) =
@ -736,11 +738,13 @@ end) = struct
[] -> unbound_name_error env lid
| (lbl, use) :: rest ->
use ();
Printtyp.Conflicts.reset ();
let paths = ambiguous_types env lbl rest in
let expansion = Format.asprintf "%t" Printtyp.Conflicts.print in
if paths <> [] then
warn lid.loc
(Warnings.Ambiguous_name ([Longident.last lid.txt],
paths, false));
paths, false, expansion));
lbl
end
| Some(tpath0, tpath, pr) ->
@ -761,11 +765,14 @@ end) = struct
let lbl_tpath = get_type_path lbl' in
if not (compare_type_path env tpath lbl_tpath) then warn_pr ()
else
Printtyp.Conflicts.reset ();
let paths = ambiguous_types env lbl rest in
let expansion =
Format.asprintf "%t" Printtyp.Conflicts.print in
if paths <> [] then
warn lid.loc
(Warnings.Ambiguous_name ([Longident.last lid.txt],
paths, false))
paths, false, expansion))
end;
lbl
with Not_found -> try
@ -841,7 +848,7 @@ let disambiguate_lid_a_list loc closed env opath lid_a_list =
let open Warnings in
match msg with
| Not_principal _ -> w_pr := true
| Ambiguous_name([s], l, _) -> w_amb := (s, l) :: !w_amb
| Ambiguous_name([s], l, _, ex) -> w_amb := (s, l, ex) :: !w_amb
| Name_out_of_scope(ty, [s], _) ->
w_scope := s :: !w_scope; w_scope_ty := ty
| _ -> Location.prerr_warning loc msg
@ -875,17 +882,18 @@ let disambiguate_lid_a_list loc closed env opath lid_a_list =
(Warnings.Not_principal "this type-based record disambiguation")
else begin
match List.rev !w_amb with
(_,types)::_ as amb ->
(_,types,ex)::_ as amb ->
let paths =
List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in
let path = List.hd paths in
let fst3 (x,_,_) = x in
if List.for_all (compare_type_path env path) (List.tl paths) then
Location.prerr_warning loc
(Warnings.Ambiguous_name (List.map fst amb, types, true))
(Warnings.Ambiguous_name (List.map fst3 amb, types, true, ex))
else
List.iter
(fun (s,l) -> Location.prerr_warning loc
(Warnings.Ambiguous_name ([s],l,false)))
(fun (s,l,ex) -> Location.prerr_warning loc
(Warnings.Ambiguous_name ([s],l,false, ex)))
amb
| _ -> ()
end;

11
typing/typedecl.ml
View File

@ -2013,15 +2013,20 @@ let report_error ppf = function
| Constraint_failed (ty, ty') ->
Printtyp.reset_and_mark_loops ty;
Printtyp.mark_loops ty';
Printtyp.Naming_context.reset ();
fprintf ppf "@[%s@ @[<hv>Type@ %a@ should be an instance of@ %a@]@]"
"Constraints are not satisfied in this type."
Printtyp.type_expr ty Printtyp.type_expr ty'
!Oprint.out_type (Printtyp.tree_of_typexp false ty)
!Oprint.out_type (Printtyp.tree_of_typexp false ty')
| Parameters_differ (path, ty, ty') ->
Printtyp.reset_and_mark_loops ty;
Printtyp.mark_loops ty';
Printtyp.Naming_context.reset ();
fprintf ppf
"@[<hv>In the definition of %s, type@ %a@ should be@ %a@]"
(Path.name path) Printtyp.type_expr ty Printtyp.type_expr ty'
(Path.name path)
!Oprint.out_type (Printtyp.tree_of_typexp false ty)
!Oprint.out_type (Printtyp.tree_of_typexp false ty')
| Inconsistent_constraint (env, trace) ->
fprintf ppf "The type constraints are not consistent.@.";
Printtyp.report_unification_error ppf env trace
@ -2050,7 +2055,7 @@ let report_error ppf = function
)
"case" (fun ppf c ->
fprintf ppf
"%s of %a" (Ident.name c.Types.cd_id)
"%a of %a" Printtyp.ident c.Types.cd_id
Printtyp.constructor_arguments c.Types.cd_args)
| Type_record (tl, _), _ ->
explain_unbound ppf ty tl (fun l -> l.Types.ld_type)

4
typing/typemod.ml
View File

@ -1862,7 +1862,9 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
if !Clflags.print_types then begin
Typecore.force_delayed_checks ();
Printtyp.wrap_printing_env ~error:false initial_env
(fun () -> fprintf std_formatter "%a@." Printtyp.signature simple_sg);
(fun () -> fprintf std_formatter "%a@."
(Printtyp.printed_signature sourcefile) simple_sg
);
(str, Tcoerce_none) (* result is ignored by Compile.implementation *)
end else begin
let sourceintf =

4
typing/typetexp.ml
View File

@ -922,9 +922,9 @@ let report_error env ppf = function
Printtyp.reset_and_mark_loops_list [ty; ty'];
fprintf ppf "@[<hov>%s %a@ %s@ %a@]"
"This variant type contains a constructor"
Printtyp.type_expr ty
!Oprint.out_type (tree_of_typexp false ty)
"which should be"
Printtyp.type_expr ty')
!Oprint.out_type (tree_of_typexp false ty'))
| Not_a_variant ty ->
Printtyp.reset_and_mark_loops ty;
fprintf ppf

25
utils/warnings.ml
View File

@ -67,7 +67,7 @@ type t =
| Unused_extension of string * bool * bool * bool (* 38 *)
| Unused_rec_flag (* 39 *)
| Name_out_of_scope of string * string list * bool (* 40 *)
| Ambiguous_name of string list * string list * bool (* 41 *)
| Ambiguous_name of string list * string list * bool * string (* 41 *)
| Disambiguated_name of string (* 42 *)
| Nonoptional_label of string (* 43 *)
| Open_shadow_identifier of string * string (* 44 *)
@ -89,6 +89,7 @@ type t =
| Unused_module of string (* 60 *)
| Unboxable_type_in_prim_decl of string (* 61 *)
| Constraint_on_gadt (* 62 *)
| Erroneous_printed_signature of string (* 63 *)
;;
(* If you remove a warning, leave a hole in the numbering. NEVER change
@ -160,9 +161,10 @@ let number = function
| Unused_module _ -> 60
| Unboxable_type_in_prim_decl _ -> 61
| Constraint_on_gadt -> 62
| Erroneous_printed_signature _ -> 63
;;
let last_warning_number = 62
let last_warning_number = 63
;;
(* Must be the max number returned by the [number] function. *)
@ -436,14 +438,16 @@ let message = function
not visible in the current scope: "
^ String.concat " " slist ^ ".\n\
They will not be selected if the type becomes unknown."
| Ambiguous_name ([s], tl, false) ->
| Ambiguous_name ([s], tl, false, expansion) ->
s ^ " belongs to several types: " ^ String.concat " " tl ^
"\nThe first one was selected. Please disambiguate if this is wrong."
| Ambiguous_name (_, _, false) -> assert false
| Ambiguous_name (_slist, tl, true) ->
^ expansion
| Ambiguous_name (_, _, false, _ ) -> assert false
| Ambiguous_name (_slist, tl, true, expansion) ->
"these field labels belong to several types: " ^
String.concat " " tl ^
"\nThe first one was selected. Please disambiguate if this is wrong."
^ expansion
| Disambiguated_name s ->
"this use of " ^ s ^ " relies on type-directed disambiguation,\n\
it will not compile with OCaml 4.00 or earlier."
@ -521,6 +525,14 @@ let message = function
or [@@unboxed]." t t
| Constraint_on_gadt ->
"Type constraints do not apply to GADT cases of variant types."
| Erroneous_printed_signature s ->
"The printed interface differs from the inferred interface.\n\
The inferred interface contained items which could not be printed\n\
properly due to name collisions between identifiers."
^ s
^ "\nBeware that this warning is purely informational and will not catch\n\
all instances of erroneous printed interface."
;;
let sub_locs = function
@ -636,7 +648,8 @@ let descriptions =
59, "Assignment to non-mutable value";
60, "Unused module declaration";
61, "Unboxable type in primitive declaration";
62, "Type constraint on GADT type declaration"
62, "Type constraint on GADT type declaration";
63, "Erroneous printed signature"
]
;;

3
utils/warnings.mli
View File

@ -60,7 +60,7 @@ type t =
| Unused_extension of string * bool * bool * bool (* 38 *)
| Unused_rec_flag (* 39 *)
| Name_out_of_scope of string * string list * bool (* 40 *)
| Ambiguous_name of string list * string list * bool (* 41 *)
| Ambiguous_name of string list * string list * bool * string (* 41 *)
| Disambiguated_name of string (* 42 *)
| Nonoptional_label of string (* 43 *)
| Open_shadow_identifier of string * string (* 44 *)
@ -82,6 +82,7 @@ type t =
| Unused_module of string (* 60 *)
| Unboxable_type_in_prim_decl of string (* 61 *)
| Constraint_on_gadt (* 62 *)
| Erroneous_printed_signature of string (* 63 *)
;;
val parse_options : bool -> string -> unit;;