PR#6416 et al.: injective mapping between identifiers and printed names (#1120)
parent
c8343888fa
commit
349db3d869
3
Changes
3
Changes
|
@ -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,
|
||||
|
|
|
@ -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 ();
|
||||
|
|
|
@ -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 ();
|
||||
|
|
|
@ -14,6 +14,7 @@
|
|||
(**************************************************************************)
|
||||
|
||||
open Format
|
||||
let () = Printtyp.Naming_context.enable false
|
||||
|
||||
let new_fmt () =
|
||||
let buf = Buffer.create 512 in
|
||||
|
|
|
@ -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 ||
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|}]
|
|
@ -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
|
||||
|}]
|
|
@ -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
|
||||
|}]
|
|
@ -1 +1,5 @@
|
|||
pervasives_leitmotiv.ml
|
||||
pr4791.ml
|
||||
pr6323.ml
|
||||
pr7402.ml
|
||||
pr7620_bad.ml
|
||||
|
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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. *)
|
||||
|
|
|
@ -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 ->
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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' =
|
||||
type 'a diff = Same of 'a | Diff of 'a * 'a
|
||||
|
||||
let trees_of_type_expansion (t,t') =
|
||||
if same_path t t'
|
||||
then begin add_delayed (proxy t); type_expr ppf t end
|
||||
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
|
||||
type_expansion ppf t t'
|
||||
(* 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_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 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;
|
||||
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) ()
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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) ->
|
||||
|
|
|
@ -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;
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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 =
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
]
|
||||
;;
|
||||
|
||||
|
|
|
@ -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;;
|
||||
|
|
Loading…
Reference in New Issue