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:
|
### 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
|
- MPR#7116, GPR#1430: new -config-var option
|
||||||
to get the value of a single configuration variable in scripts.
|
to get the value of a single configuration variable in scripts.
|
||||||
(Gabriel Scherer, review by Sébastien Hinderer and David Allsopp,
|
(Gabriel Scherer, review by Sébastien Hinderer and David Allsopp,
|
||||||
|
|
|
@ -44,7 +44,8 @@ let interface ppf sourcefile outputprefix =
|
||||||
if !Clflags.print_types then
|
if !Clflags.print_types then
|
||||||
Printtyp.wrap_printing_env ~error:false initial_env (fun () ->
|
Printtyp.wrap_printing_env ~error:false initial_env (fun () ->
|
||||||
fprintf std_formatter "%a@."
|
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);
|
ignore (Includemod.signatures initial_env sg sg);
|
||||||
Typecore.force_delayed_checks ();
|
Typecore.force_delayed_checks ();
|
||||||
Warnings.check_fatal ();
|
Warnings.check_fatal ();
|
||||||
|
|
|
@ -44,7 +44,8 @@ let interface ppf sourcefile outputprefix =
|
||||||
if !Clflags.print_types then
|
if !Clflags.print_types then
|
||||||
Printtyp.wrap_printing_env ~error:false initial_env (fun () ->
|
Printtyp.wrap_printing_env ~error:false initial_env (fun () ->
|
||||||
fprintf std_formatter "%a@."
|
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);
|
ignore (Includemod.signatures initial_env sg sg);
|
||||||
Typecore.force_delayed_checks ();
|
Typecore.force_delayed_checks ();
|
||||||
Warnings.check_fatal ();
|
Warnings.check_fatal ();
|
||||||
|
|
|
@ -14,6 +14,7 @@
|
||||||
(**************************************************************************)
|
(**************************************************************************)
|
||||||
|
|
||||||
open Format
|
open Format
|
||||||
|
let () = Printtyp.Naming_context.enable false
|
||||||
|
|
||||||
let new_fmt () =
|
let new_fmt () =
|
||||||
let buf = Buffer.create 512 in
|
let buf = Buffer.create 512 in
|
||||||
|
|
|
@ -16,6 +16,7 @@
|
||||||
(** The functions to get a string from different kinds of elements (types, modules, ...). *)
|
(** The functions to get a string from different kinds of elements (types, modules, ...). *)
|
||||||
|
|
||||||
module Name = Odoc_name
|
module Name = Odoc_name
|
||||||
|
let () = Printtyp.Naming_context.enable false
|
||||||
|
|
||||||
let string_of_variance t (co,cn) =
|
let string_of_variance t (co,cn) =
|
||||||
if ( t.Odoc_type.ty_kind = Odoc_type.Type_abstract ||
|
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 =
|
val sort : (module Set.S with type elt = 'a) -> 'a list -> 'a list = <fun>
|
||||||
<fun>
|
val make_set : ('a -> 'a -> int) -> (module Set.S with type elt = 'a) = <fun>
|
||||||
val make_set : ('a -> 'a -> int) -> (module Stdlib.Set.S with type elt = 'a) =
|
|
||||||
<fun>
|
|
||||||
val sort_cmp : ('a -> 'a -> int) -> 'a list -> 'a list = <fun>
|
val sort_cmp : ('a -> 'a -> int) -> 'a list -> 'a list = <fun>
|
||||||
module type S = sig type t val x : t end
|
module type S = sig type t val x : t end
|
||||||
val f : (module S with type t = int) -> int = <fun>
|
val f : (module S with type t = int) -> int = <fun>
|
||||||
|
@ -71,8 +69,8 @@ module rec Typ :
|
||||||
| String of ('a, string) TypEq.t
|
| String of ('a, string) TypEq.t
|
||||||
| Pair of (module PAIR with type t = 'a)
|
| Pair of (module PAIR with type t = 'a)
|
||||||
end
|
end
|
||||||
val int : int Typ.typ = Int <abstr>
|
val int : int Typ.typ = Typ.Int <abstr>
|
||||||
val str : string Typ.typ = String <abstr>
|
val str : string Typ.typ = Typ.String <abstr>
|
||||||
val pair : 'a Typ.typ -> 'b Typ.typ -> ('a * 'b) Typ.typ = <fun>
|
val pair : 'a Typ.typ -> 'b Typ.typ -> ('a * 'b) Typ.typ = <fun>
|
||||||
val to_string : 'a Typ.typ -> 'a -> string = <fun>
|
val to_string : 'a Typ.typ -> 'a -> string = <fun>
|
||||||
module type MapT =
|
module type MapT =
|
||||||
|
|
|
@ -4,6 +4,8 @@ inside_out.ml
|
||||||
labels.ml
|
labels.ml
|
||||||
occur_check.ml
|
occur_check.ml
|
||||||
polyvars.ml
|
polyvars.ml
|
||||||
|
pr6416.ml
|
||||||
|
pr6634.ml
|
||||||
pr6939-flat-float-array.ml
|
pr6939-flat-float-array.ml
|
||||||
pr6939-no-flat-float-array.ml
|
pr6939-no-flat-float-array.ml
|
||||||
pr7103.ml
|
pr7103.ml
|
||||||
|
@ -11,6 +13,7 @@ pr7228.ml
|
||||||
pr7668_bad.ml
|
pr7668_bad.ml
|
||||||
printing.ml
|
printing.ml
|
||||||
records.ml
|
records.ml
|
||||||
|
unique_names_in_unification.ml
|
||||||
variant.ml
|
variant.ml
|
||||||
wellfounded.ml
|
wellfounded.ml
|
||||||
empty_variant.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
|
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 Path
|
||||||
open Types
|
open Types
|
||||||
open Outcometree
|
open Outcometree
|
||||||
|
module Out_name = Printtyp.Out_name
|
||||||
|
|
||||||
module type OBJ =
|
module type OBJ =
|
||||||
sig
|
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
|
else if O.tag arg = Obj.double_tag then
|
||||||
list := Oval_float (O.obj arg : float) :: !list
|
list := Oval_float (O.obj arg : float) :: !list
|
||||||
else
|
else
|
||||||
list := Oval_constr (Oide_ident "_", []) :: !list
|
list := Oval_constr (Oide_ident (Out_name.create "_"), []) :: !list
|
||||||
done;
|
done;
|
||||||
List.rev !list
|
List.rev !list
|
||||||
end
|
end
|
||||||
|
@ -110,7 +111,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
|
||||||
|
|
||||||
let outval_of_untyped_exception bucket =
|
let outval_of_untyped_exception bucket =
|
||||||
if O.tag bucket <> 0 then
|
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
|
else
|
||||||
let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
|
let name = (O.obj(O.field(O.field bucket 0) 0) : string) in
|
||||||
let args =
|
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
|
&& O.tag(O.field bucket 1) = 0
|
||||||
then outval_of_untyped_exception_args (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
|
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. *)
|
(* 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
|
Oide_ident name
|
||||||
| Pdot(p, _s, _pos) ->
|
| Pdot(p, _s, _pos) ->
|
||||||
if try
|
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'
|
| Tconstr(ty_path', _, _) -> Path.same ty_path ty_path'
|
||||||
| _ -> false
|
| _ -> false
|
||||||
with Not_found -> false
|
with Not_found -> false
|
||||||
then Oide_ident name
|
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 _ ->
|
| Papply _ ->
|
||||||
Printtyp.tree_of_path ty_path
|
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
|
then nest tree_of_val depth forced_obj ty_arg
|
||||||
else tree_of_val depth forced_obj ty_arg
|
else tree_of_val depth forced_obj ty_arg
|
||||||
in
|
in
|
||||||
Oval_constr (Oide_ident "lazy", [v])
|
Oval_constr (Oide_ident (Out_name.create "lazy"), [v])
|
||||||
end
|
end
|
||||||
| Tconstr(path, ty_list, _) -> begin
|
| Tconstr(path, ty_list, _) -> begin
|
||||||
try
|
try
|
||||||
|
@ -414,7 +416,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
|
||||||
lbls 0 obj unbx
|
lbls 0 obj unbx
|
||||||
in
|
in
|
||||||
Oval_constr(tree_of_constr env path
|
Oval_constr(tree_of_constr env path
|
||||||
(Ident.name cd_id),
|
(Out_name.create (Ident.name cd_id)),
|
||||||
[ r ])
|
[ r ])
|
||||||
end
|
end
|
||||||
| {type_kind = Type_record(lbl_list, rep)} ->
|
| {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
|
(* PR#5722: print full module path only
|
||||||
for first record field *)
|
for first record field *)
|
||||||
let lid =
|
let lid =
|
||||||
if pos = 0 then tree_of_label env path name
|
if pos = 0 then tree_of_label env path (Out_name.create name)
|
||||||
else Oide_ident name
|
else Oide_ident (Out_name.create name)
|
||||||
and v =
|
and v =
|
||||||
if unboxed then
|
if unboxed then
|
||||||
tree_of_val (depth - 1) obj ty_arg
|
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
|
and tree_of_constr_with_args
|
||||||
tree_of_cstr cstr_name inlined start depth obj ty_args unboxed =
|
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 =
|
let args =
|
||||||
if inlined || unboxed then
|
if inlined || unboxed then
|
||||||
match ty_args with
|
match ty_args with
|
||||||
|
|
|
@ -344,7 +344,7 @@ let execute_phrase print_outcome ppf phr =
|
||||||
Ophr_eval (outv, ty)
|
Ophr_eval (outv, ty)
|
||||||
| _ -> assert false
|
| _ -> assert false
|
||||||
else
|
else
|
||||||
Ophr_signature (pr_item newenv sg'))
|
Ophr_signature (pr_item oldenv sg'))
|
||||||
else Ophr_signature []
|
else Ophr_signature []
|
||||||
| Exception exn ->
|
| Exception exn ->
|
||||||
toplevel_env := oldenv;
|
toplevel_env := oldenv;
|
||||||
|
|
|
@ -272,7 +272,7 @@ let execute_phrase print_outcome ppf phr =
|
||||||
Ophr_eval (outv, ty)
|
Ophr_eval (outv, ty)
|
||||||
|
|
||||||
| [] -> Ophr_signature []
|
| [] -> Ophr_signature []
|
||||||
| _ -> Ophr_signature (pr_item newenv sg'))
|
| _ -> Ophr_signature (pr_item oldenv sg'))
|
||||||
else Ophr_signature []
|
else Ophr_signature []
|
||||||
| Exception exn ->
|
| Exception exn ->
|
||||||
toplevel_env := oldenv;
|
toplevel_env := oldenv;
|
||||||
|
|
|
@ -81,7 +81,7 @@ let value_descriptions ~loc env ~mark cxt subst id vd1 vd2 =
|
||||||
|
|
||||||
(* Inclusion between type declarations *)
|
(* 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
|
let mark = mark_positive mark in
|
||||||
if mark then
|
if mark then
|
||||||
Env.mark_type_used (Ident.name id) decl1;
|
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
|
(Ident.name id) decl1 id decl2
|
||||||
in
|
in
|
||||||
if err <> [] then
|
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 *)
|
(* Inclusion between extension constructors *)
|
||||||
|
|
||||||
|
@ -104,20 +104,20 @@ let extension_constructors ~loc env ~mark cxt subst id ext1 ext2 =
|
||||||
|
|
||||||
(* Inclusion between class declarations *)
|
(* 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
|
let decl2 = Subst.cltype_declaration subst decl2 in
|
||||||
match Includeclass.class_type_declarations ~loc env decl1 decl2 with
|
match Includeclass.class_type_declarations ~loc env decl1 decl2 with
|
||||||
[] -> ()
|
[] -> ()
|
||||||
| reason ->
|
| reason ->
|
||||||
raise(Error[cxt, old_env,
|
raise(Error[cxt, env,
|
||||||
Class_type_declarations(id, decl1, decl2, reason)])
|
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
|
let decl2 = Subst.class_declaration subst decl2 in
|
||||||
match Includeclass.class_declarations env decl1 decl2 with
|
match Includeclass.class_declarations env decl1 decl2 with
|
||||||
[] -> ()
|
[] -> ()
|
||||||
| reason ->
|
| 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 *)
|
(* Expand a module type identifier when possible *)
|
||||||
|
|
||||||
|
@ -557,7 +557,6 @@ let modtypes env m1 m2 =
|
||||||
(* Error report *)
|
(* Error report *)
|
||||||
|
|
||||||
open Format
|
open Format
|
||||||
open Printtyp
|
|
||||||
|
|
||||||
let show_loc msg ppf loc =
|
let show_loc msg ppf loc =
|
||||||
let pos = loc.Location.loc_start in
|
let pos = loc.Location.loc_start in
|
||||||
|
@ -570,19 +569,23 @@ let show_locs ppf (loc1, loc2) =
|
||||||
|
|
||||||
let include_err ppf = function
|
let include_err ppf = function
|
||||||
| Missing_field (id, loc, kind) ->
|
| 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
|
show_loc "Expected declaration" ppf loc
|
||||||
| Value_descriptions(id, d1, d2) ->
|
| Value_descriptions(id, d1, d2) ->
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
"@[<hv 2>Values do not match:@ %a@;<1 -2>is not included in@ %a@]"
|
"@[<hv 2>Values do not match:@ %a@;<1 -2>is not included in@ %a@]"
|
||||||
(value_description id) d1 (value_description id) d2;
|
!Oprint.out_sig_item (Printtyp.tree_of_value_description id d1)
|
||||||
show_locs ppf (d1.val_loc, d2.val_loc);
|
!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) ->
|
| Type_declarations(id, d1, d2, errs) ->
|
||||||
fprintf ppf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]"
|
fprintf ppf "@[<v>@[<hv>%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]"
|
||||||
"Type declarations do not match"
|
"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"
|
"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)
|
show_locs (d1.type_loc, d2.type_loc)
|
||||||
(Includecore.report_type_mismatch
|
(Includecore.report_type_mismatch
|
||||||
"the first" "the second" "declaration") errs
|
"the first" "the second" "declaration") errs
|
||||||
|
@ -590,21 +593,23 @@ let include_err ppf = function
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
"@[<hv 2>Extension declarations do not match:@ \
|
"@[<hv 2>Extension declarations do not match:@ \
|
||||||
%a@;<1 -2>is not included in@ %a@]"
|
%a@;<1 -2>is not included in@ %a@]"
|
||||||
(extension_constructor id) x1
|
!Oprint.out_sig_item
|
||||||
(extension_constructor id) x2;
|
(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)
|
show_locs ppf (x1.ext_loc, x2.ext_loc)
|
||||||
| Module_types(mty1, mty2)->
|
| Module_types(mty1, mty2)->
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
"@[<hv 2>Modules do not match:@ \
|
"@[<hv 2>Modules do not match:@ \
|
||||||
%a@;<1 -2>is not included in@ %a@]"
|
%a@;<1 -2>is not included in@ %a@]"
|
||||||
modtype mty1
|
!Oprint.out_module_type (Printtyp.tree_of_modtype mty1)
|
||||||
modtype mty2
|
!Oprint.out_module_type (Printtyp.tree_of_modtype mty2)
|
||||||
| Modtype_infos(id, d1, d2) ->
|
| Modtype_infos(id, d1, d2) ->
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
"@[<hv 2>Module type declarations do not match:@ \
|
"@[<hv 2>Module type declarations do not match:@ \
|
||||||
%a@;<1 -2>does not match@ %a@]"
|
%a@;<1 -2>does not match@ %a@]"
|
||||||
(modtype_declaration id) d1
|
!Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d1)
|
||||||
(modtype_declaration id) d2
|
!Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d2)
|
||||||
| Modtype_permutation ->
|
| Modtype_permutation ->
|
||||||
fprintf ppf "Illegal permutation of structure fields"
|
fprintf ppf "Illegal permutation of structure fields"
|
||||||
| Interface_mismatch(impl_name, intf_name) ->
|
| Interface_mismatch(impl_name, intf_name) ->
|
||||||
|
@ -614,15 +619,17 @@ let include_err ppf = function
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
"@[<hv 2>Class type declarations do not match:@ \
|
"@[<hv 2>Class type declarations do not match:@ \
|
||||||
%a@;<1 -2>does not match@ %a@]@ %a"
|
%a@;<1 -2>does not match@ %a@]@ %a"
|
||||||
(Printtyp.cltype_declaration id) d1
|
!Oprint.out_sig_item
|
||||||
(Printtyp.cltype_declaration id) d2
|
(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
|
Includeclass.report_error reason
|
||||||
| Class_declarations(id, d1, d2, reason) ->
|
| Class_declarations(id, d1, d2, reason) ->
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
"@[<hv 2>Class declarations do not match:@ \
|
"@[<hv 2>Class declarations do not match:@ \
|
||||||
%a@;<1 -2>does not match@ %a@]@ %a"
|
%a@;<1 -2>does not match@ %a@]@ %a"
|
||||||
(Printtyp.class_declaration id) d1
|
!Oprint.out_sig_item (Printtyp.tree_of_class_declaration id d1 Trec_first)
|
||||||
(Printtyp.class_declaration id) d2
|
!Oprint.out_sig_item (Printtyp.tree_of_class_declaration id d2 Trec_first)
|
||||||
Includeclass.report_error reason
|
Includeclass.report_error reason
|
||||||
| Unbound_modtype_path path ->
|
| Unbound_modtype_path path ->
|
||||||
fprintf ppf "Unbound module type %a" Printtyp.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
|
let rec context ppf = function
|
||||||
Module id :: rem ->
|
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 ->
|
| 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 ->
|
| Body x :: rem ->
|
||||||
fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem
|
fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem
|
||||||
| Arg x :: 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>"
|
fprintf ppf "<here>"
|
||||||
and context_mty ppf = function
|
and context_mty ppf = function
|
||||||
|
@ -650,7 +658,7 @@ and args ppf = function
|
||||||
Body x :: rem ->
|
Body x :: rem ->
|
||||||
fprintf ppf "(%s)%a" (argname x) args rem
|
fprintf ppf "(%s)%a" (argname x) args rem
|
||||||
| Arg x :: rem ->
|
| Arg x :: rem ->
|
||||||
fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem
|
fprintf ppf "(%a :@ %a) : ..." Printtyp.ident x context_mty rem
|
||||||
| cxt ->
|
| cxt ->
|
||||||
fprintf ppf " :@ %a" context_mty cxt
|
fprintf ppf " :@ %a" context_mty cxt
|
||||||
and argname x =
|
and argname x =
|
||||||
|
@ -669,7 +677,7 @@ let path_of_context = function
|
||||||
let context ppf cxt =
|
let context ppf cxt =
|
||||||
if cxt = [] then () else
|
if cxt = [] then () else
|
||||||
if List.for_all (function Module _ -> true | _ -> false) cxt then
|
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
|
else
|
||||||
fprintf ppf "@[<hv 2>At position@ %a@]@ " context cxt
|
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)
|
else if !pe then (fprintf ppf "...@ "; pe := false)
|
||||||
in
|
in
|
||||||
let print_errs ppf = List.iter (include_err' ppf) 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
|
(* We could do a better job to split the individual error items
|
||||||
as sub-messages of the main interface mismatch on the whole unit. *)
|
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 =
|
let rec print_ident ppf =
|
||||||
function
|
function
|
||||||
Oide_ident s -> print_lident ppf s
|
Oide_ident s -> print_lident ppf s.printed_name
|
||||||
| Oide_dot (id, s) ->
|
| Oide_dot (id, s) ->
|
||||||
print_ident ppf id; pp_print_char ppf '.'; print_lident ppf s
|
print_ident ppf id; pp_print_char ppf '.'; print_lident ppf s
|
||||||
| Oide_apply (id1, id2) ->
|
| Oide_apply (id1, id2) ->
|
||||||
|
@ -309,7 +309,7 @@ and print_simple_out_type ppf =
|
||||||
| Otyp_sum _ | Otyp_manifest (_, _) -> ()
|
| Otyp_sum _ | Otyp_manifest (_, _) -> ()
|
||||||
| Otyp_record lbls -> print_record_decl ppf lbls
|
| Otyp_record lbls -> print_record_decl ppf lbls
|
||||||
| Otyp_module (p, n, tyl) ->
|
| Otyp_module (p, n, tyl) ->
|
||||||
fprintf ppf "@[<1>(module %s" p;
|
fprintf ppf "@[<1>(module %a" print_ident p;
|
||||||
let first = ref true in
|
let first = ref true in
|
||||||
List.iter2
|
List.iter2
|
||||||
(fun s t ->
|
(fun s t ->
|
||||||
|
|
|
@ -22,10 +22,14 @@
|
||||||
[Toploop.print_out_sig_item]
|
[Toploop.print_out_sig_item]
|
||||||
[Toploop.print_out_phrase] *)
|
[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 =
|
type out_ident =
|
||||||
| Oide_apply of out_ident * out_ident
|
| Oide_apply of out_ident * out_ident
|
||||||
| Oide_dot of out_ident * string
|
| Oide_dot of out_ident * string
|
||||||
| Oide_ident of string
|
| Oide_ident of out_name
|
||||||
|
|
||||||
type out_string =
|
type out_string =
|
||||||
| Ostr_string
|
| Ostr_string
|
||||||
|
@ -69,7 +73,7 @@ type out_type =
|
||||||
| Otyp_variant of
|
| Otyp_variant of
|
||||||
bool * out_variant * bool * (string list) option
|
bool * out_variant * bool * (string list) option
|
||||||
| Otyp_poly of string list * out_type
|
| 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
|
| Otyp_attribute of out_type * out_attribute
|
||||||
|
|
||||||
and out_variant =
|
and out_variant =
|
||||||
|
|
|
@ -32,24 +32,255 @@ let rec longident ppf = function
|
||||||
| Ldot(p, s) -> fprintf ppf "%a.%s" longident p s
|
| Ldot(p, s) -> fprintf ppf "%a.%s" longident p s
|
||||||
| Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2
|
| 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 =
|
(* printing environment for path shortening and naming *)
|
||||||
try Ident.find_same id !unique_names with Not_found -> Ident.name id
|
let printing_env = ref Env.empty
|
||||||
|
let human_unique n id = Printf.sprintf "%s/%d" (Ident.name id) n
|
||||||
|
|
||||||
let add_unique id =
|
type namespace =
|
||||||
try ignore (Ident.find_same id !unique_names)
|
| Type
|
||||||
with Not_found ->
|
| Module
|
||||||
unique_names := Ident.add id (Ident.unique_toplevel_name id) !unique_names
|
| 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 *)
|
(* Print a path *)
|
||||||
|
|
||||||
let ident_stdlib = Ident.create_persistent "Stdlib"
|
let ident_stdlib = Ident.create_persistent "Stdlib"
|
||||||
let printing_env = ref Env.empty
|
|
||||||
let non_shadowed_pervasive = function
|
let non_shadowed_pervasive = function
|
||||||
| Pdot(Pident id, s, _) as path ->
|
| Pdot(Pident id, s, _) as path ->
|
||||||
Ident.same id ident_stdlib &&
|
Ident.same id ident_stdlib &&
|
||||||
|
@ -126,17 +357,15 @@ let rewrite_double_underscore_paths env p =
|
||||||
else
|
else
|
||||||
rewrite_double_underscore_paths env p
|
rewrite_double_underscore_paths env p
|
||||||
|
|
||||||
let rec tree_of_path = function
|
let rec tree_of_path namespace = function
|
||||||
| Pident id ->
|
| Pident id ->
|
||||||
Oide_ident (ident_name id)
|
Oide_ident (ident_name namespace id)
|
||||||
| Pdot(_, s, _pos) as path
|
| Pdot(_, s, _pos) as path when non_shadowed_pervasive path ->
|
||||||
when non_shadowed_pervasive path ->
|
Oide_ident (Naming_context.pervasives_name namespace s)
|
||||||
Oide_ident s
|
|
||||||
| Pdot(p, s, _pos) ->
|
| Pdot(p, s, _pos) ->
|
||||||
Oide_dot (tree_of_path p, s)
|
Oide_dot (tree_of_path Module p, s)
|
||||||
| Papply(p1, p2) ->
|
| Papply(p1, p2) ->
|
||||||
Oide_apply (tree_of_path p1,
|
Oide_apply (tree_of_path Module p1, tree_of_path Module p2)
|
||||||
tree_of_path p2)
|
|
||||||
|
|
||||||
let rec path ppf = function
|
let rec path ppf = function
|
||||||
| Pident id ->
|
| Pident id ->
|
||||||
|
@ -151,19 +380,24 @@ let rec path ppf = function
|
||||||
| Papply(p1, p2) ->
|
| Papply(p1, p2) ->
|
||||||
fprintf ppf "%a(%a)" path p1 path p2
|
fprintf ppf "%a(%a)" path p1 path p2
|
||||||
|
|
||||||
let tree_of_path p =
|
let tree_of_path namespace p =
|
||||||
tree_of_path (rewrite_double_underscore_paths !printing_env p)
|
tree_of_path namespace (rewrite_double_underscore_paths !printing_env p)
|
||||||
let path ppf p =
|
let path ppf p =
|
||||||
path ppf (rewrite_double_underscore_paths !printing_env p)
|
path ppf (rewrite_double_underscore_paths !printing_env p)
|
||||||
|
|
||||||
let rec string_of_out_ident = function
|
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_dot (id, s) -> String.concat "." [string_of_out_ident id; s]
|
||||||
| Oide_apply (id1, id2) ->
|
| Oide_apply (id1, id2) ->
|
||||||
String.concat ""
|
String.concat ""
|
||||||
[string_of_out_ident id1; "("; string_of_out_ident id2; ")"]
|
[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 *)
|
(* Print a recursive annotation *)
|
||||||
|
|
||||||
|
@ -417,7 +651,7 @@ let set_printing_env env =
|
||||||
end
|
end
|
||||||
|
|
||||||
let wrap_printing_env env f =
|
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)
|
try_finally f (fun () -> set_printing_env Env.empty)
|
||||||
|
|
||||||
let wrap_printing_env ~error env f =
|
let wrap_printing_env ~error env f =
|
||||||
|
@ -642,14 +876,18 @@ let mark_loops ty =
|
||||||
let reset_loop_marks () =
|
let reset_loop_marks () =
|
||||||
visited_objects := []; aliased := []; delayed := []
|
visited_objects := []; aliased := []; delayed := []
|
||||||
|
|
||||||
|
let reset_except_context () =
|
||||||
|
reset_names (); reset_loop_marks ()
|
||||||
|
|
||||||
let reset () =
|
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 =
|
let reset_and_mark_loops ty =
|
||||||
reset (); mark_loops ty
|
reset_except_context (); mark_loops ty
|
||||||
|
|
||||||
let reset_and_mark_loops_list tyl =
|
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 *)
|
(* Disabled in classic mode when printing an unification error *)
|
||||||
let print_labels = ref true
|
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 p', s = best_type_path p in
|
||||||
let tyl' = apply_subst s tyl in
|
let tyl' = apply_subst s tyl in
|
||||||
if is_nth s && not (tyl'=[]) then tree_of_typexp sch (List.hd tyl') else
|
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 ->
|
| Tvariant row ->
|
||||||
let row = row_repr row in
|
let row = row_repr row in
|
||||||
let fields =
|
let fields =
|
||||||
|
@ -710,7 +948,7 @@ let rec tree_of_typexp sch ty =
|
||||||
begin match row.row_name with
|
begin match row.row_name with
|
||||||
| Some(p, tyl) when namable_row row ->
|
| Some(p, tyl) when namable_row row ->
|
||||||
let (p', s) = best_type_path p in
|
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 args = tree_of_typlist sch (apply_subst s tyl) in
|
||||||
let out_variant =
|
let out_variant =
|
||||||
if is_nth s then List.hd args else Otyp_constr (id, args) in
|
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) ->
|
| Tpackage (p, n, tyl) ->
|
||||||
let n =
|
let n =
|
||||||
List.map (fun li -> String.concat "." (Longident.flatten li)) n in
|
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
|
in
|
||||||
if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed;
|
if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed;
|
||||||
if is_aliased px && aliasable ty then begin
|
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 args = tree_of_typlist sch tyl in
|
||||||
let (p', s) = best_type_path p in
|
let (p', s) = best_type_path p in
|
||||||
assert (s = Id);
|
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"
|
fatal_error "Printtyp.tree_of_typobject"
|
||||||
end
|
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
|
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 *)
|
(* Maxence *)
|
||||||
let type_scheme_max ?(b_reset_names=true) ppf ty =
|
let type_scheme_max ?(b_reset_names=true) ppf ty =
|
||||||
if b_reset_names then reset_names () ;
|
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 =
|
let rec tree_of_type_decl id decl =
|
||||||
|
|
||||||
reset();
|
reset_except_context();
|
||||||
|
|
||||||
let params = filter_params decl.type_params in
|
let params = filter_params decl.type_params in
|
||||||
|
|
||||||
|
@ -1028,7 +1257,7 @@ let constructor_arguments ppf a =
|
||||||
(* Print an extension declaration *)
|
(* Print an extension declaration *)
|
||||||
|
|
||||||
let tree_of_extension_constructor id ext es =
|
let tree_of_extension_constructor id ext es =
|
||||||
reset ();
|
reset_except_context ();
|
||||||
let ty_name = Path.name ext.ext_type_path in
|
let ty_name = Path.name ext.ext_type_path in
|
||||||
let ty_params = filter_params ext.ext_type_params in
|
let ty_params = filter_params ext.ext_type_params in
|
||||||
List.iter add_alias ty_params;
|
List.iter add_alias ty_params;
|
||||||
|
@ -1148,7 +1377,8 @@ let rec tree_of_class_type sch params =
|
||||||
then
|
then
|
||||||
tree_of_class_type sch params cty
|
tree_of_class_type sch params cty
|
||||||
else
|
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 ->
|
| Cty_signature sign ->
|
||||||
let sty = repr sign.csig_self in
|
let sty = repr sign.csig_self in
|
||||||
let self_ty =
|
let self_ty =
|
||||||
|
@ -1211,7 +1441,7 @@ let class_variance =
|
||||||
let tree_of_class_declaration id cl rs =
|
let tree_of_class_declaration id cl rs =
|
||||||
let params = filter_params cl.cty_params in
|
let params = filter_params cl.cty_params in
|
||||||
|
|
||||||
reset ();
|
reset_except_context ();
|
||||||
List.iter add_alias params;
|
List.iter add_alias params;
|
||||||
prepare_class_type params cl.cty_type;
|
prepare_class_type params cl.cty_type;
|
||||||
let sty = Ctype.self_type cl.cty_type in
|
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 tree_of_cltype_declaration id cl rs =
|
||||||
let params = List.map repr cl.clty_params in
|
let params = List.map repr cl.clty_params in
|
||||||
|
|
||||||
reset ();
|
reset_except_context ();
|
||||||
List.iter add_alias params;
|
List.iter add_alias params;
|
||||||
prepare_class_type params cl.clty_type;
|
prepare_class_type params cl.clty_type;
|
||||||
let sty = Ctype.self_type cl.clty_type in
|
let sty = Ctype.self_type cl.clty_type in
|
||||||
|
@ -1291,6 +1521,10 @@ let dummy =
|
||||||
type_unboxed = unboxed_false_default_false;
|
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
|
let hide_rec_items = function
|
||||||
| Sig_type(id, _decl, rs) ::rem
|
| Sig_type(id, _decl, rs) ::rem
|
||||||
when rs = Trec_first && not !Clflags.real_paths ->
|
when rs = Trec_first && not !Clflags.real_paths ->
|
||||||
|
@ -1301,14 +1535,37 @@ let hide_rec_items = function
|
||||||
in
|
in
|
||||||
let ids = id :: get_ids rem in
|
let ids = id :: get_ids rem in
|
||||||
set_printing_env
|
set_printing_env
|
||||||
(List.fold_right
|
(hide ids !printing_env)
|
||||||
(fun id -> Env.add_type ~check:false (Ident.rename id) dummy)
|
|
||||||
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
|
let rec tree_of_modtype ?(ellipsis=false) = function
|
||||||
| Mty_ident p ->
|
| Mty_ident p ->
|
||||||
Omty_ident (tree_of_path p)
|
Omty_ident (tree_of_path Module_type p)
|
||||||
| Mty_signature sg ->
|
| Mty_signature sg ->
|
||||||
Omty_signature (if ellipsis then [Osig_ellipsis]
|
Omty_signature (if ellipsis then [Osig_ellipsis]
|
||||||
else tree_of_signature sg)
|
else tree_of_signature sg)
|
||||||
|
@ -1322,7 +1579,7 @@ let rec tree_of_modtype ?(ellipsis=false) = function
|
||||||
Omty_functor (Ident.name param,
|
Omty_functor (Ident.name param,
|
||||||
may_map (tree_of_modtype ~ellipsis:false) ty_arg, res)
|
may_map (tree_of_modtype ~ellipsis:false) ty_arg, res)
|
||||||
| Mty_alias(_, p) ->
|
| Mty_alias(_, p) ->
|
||||||
Omty_alias (tree_of_path p)
|
Omty_alias (tree_of_path Module p)
|
||||||
|
|
||||||
and tree_of_signature sg =
|
and tree_of_signature sg =
|
||||||
wrap_env (fun env -> env) (tree_of_signature_rec !printing_env false) 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
|
and tree_of_signature_rec env' in_type_group = function
|
||||||
[] -> []
|
[] -> []
|
||||||
| item :: rem as items ->
|
| item :: rem as items ->
|
||||||
let in_type_group =
|
let in_type_group = still_in_type_group env' in_type_group item in
|
||||||
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 (sg, rem) = filter_rem_sig item rem in
|
let (sg, rem) = filter_rem_sig item rem in
|
||||||
hide_rec_items items;
|
hide_rec_items items;
|
||||||
|
protect_rec_items items;
|
||||||
|
reset_naming_context ();
|
||||||
let trees = trees_of_sigitem item in
|
let trees = trees_of_sigitem item in
|
||||||
let env' = Env.add_signature (item :: sg) env' in
|
let env' = Env.add_signature (item :: sg) env' in
|
||||||
trees @ tree_of_signature_rec env' in_type_group rem
|
trees @ tree_of_signature_rec env' in_type_group rem
|
||||||
|
@ -1398,15 +1651,20 @@ let refresh_weak () =
|
||||||
|
|
||||||
let print_items showval env x =
|
let print_items showval env x =
|
||||||
refresh_weak();
|
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 ->
|
| 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;
|
hide_rec_items items;
|
||||||
|
protect_rec_items items;
|
||||||
|
reset_naming_context ();
|
||||||
let trees = trees_of_sigitem item in
|
let trees = trees_of_sigitem item in
|
||||||
List.map (fun d -> (d, showval env item)) trees @
|
List.map (fun d -> (d, showval env item)) trees @
|
||||||
print showval env rem in
|
print showval in_type_group (Env.add_signature (item :: sg) env) rem in
|
||||||
print showval env x
|
print showval false env x
|
||||||
|
|
||||||
(* Print a signature body (used by -i when compiling a .ml) *)
|
(* Print a signature body (used by -i when compiling a .ml) *)
|
||||||
|
|
||||||
|
@ -1416,6 +1674,22 @@ let print_signature ppf tree =
|
||||||
let signature ppf sg =
|
let signature ppf sg =
|
||||||
fprintf ppf "%a" print_signature (tree_of_signature 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 *)
|
(* Print an unification error *)
|
||||||
|
|
||||||
let same_path t t' =
|
let same_path t t' =
|
||||||
|
@ -1435,22 +1709,42 @@ let same_path t t' =
|
||||||
| _ ->
|
| _ ->
|
||||||
false
|
false
|
||||||
|
|
||||||
let type_expansion t ppf t' =
|
type 'a diff = Same of 'a | Diff of 'a * 'a
|
||||||
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'
|
|
||||||
|
|
||||||
let type_path_expansion tp ppf tp' =
|
let trees_of_type_expansion (t,t') =
|
||||||
if Path.same tp tp' then path ppf tp else
|
if same_path t t'
|
||||||
fprintf ppf "@[<2>%a@ =@ %a@]" path tp path tp'
|
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
|
let rec trace fst txt ppf = function
|
||||||
| (t1, t1') :: (t2, t2') :: rem ->
|
| te :: te2 :: rem ->
|
||||||
if not fst then fprintf ppf "@,";
|
if not fst then fprintf ppf "@,";
|
||||||
fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@] %a"
|
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
|
(trace false txt) rem
|
||||||
| _ -> ()
|
| _ -> ()
|
||||||
|
|
||||||
|
@ -1466,13 +1760,9 @@ let rec filter_trace keep_last = function
|
||||||
else (t1, t1') :: (t2, t2') :: rem'
|
else (t1, t1') :: (t2, t2') :: rem'
|
||||||
| _ -> []
|
| _ -> []
|
||||||
|
|
||||||
let rec type_path_list ppf = function
|
let type_path_list =
|
||||||
| [tp, tp'] -> type_path_expansion tp ppf tp'
|
Format.pp_print_list ~pp_sep:(fun ppf () -> Format.pp_print_break ppf 2 0)
|
||||||
| (tp, tp') :: rem ->
|
type_path_expansion
|
||||||
fprintf ppf "%a@;<2 0>%a"
|
|
||||||
(type_path_expansion tp) tp'
|
|
||||||
type_path_list rem
|
|
||||||
| [] -> ()
|
|
||||||
|
|
||||||
(* Hide variant name and var, to force printing the expanded type *)
|
(* Hide variant name and var, to force printing the expanded type *)
|
||||||
let hide_variant_name t =
|
let hide_variant_name t =
|
||||||
|
@ -1631,33 +1921,8 @@ let warn_on_missing_def env ppf t =
|
||||||
end
|
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 =
|
let unification_error env unif tr txt1 ppf txt2 ty_expect_explanation =
|
||||||
reset ();
|
reset ();
|
||||||
trace_same_names tr;
|
|
||||||
let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in
|
let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in
|
||||||
let mis = mismatch env unif tr in
|
let mis = mismatch env unif tr in
|
||||||
match tr with
|
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
|
and t2, t2' = may_prepare_expansion (tr = []) t2 in
|
||||||
print_labels := not !Clflags.classic;
|
print_labels := not !Clflags.classic;
|
||||||
let tr = List.map prepare_expansion tr in
|
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
|
fprintf ppf
|
||||||
"@[<v>\
|
"@[<v>\
|
||||||
@[%t@;<1 2>%a@ \
|
@[%t@;<1 2>%a@ \
|
||||||
|
@ -1676,8 +1944,8 @@ let unification_error env unif tr txt1 ppf txt2 ty_expect_explanation =
|
||||||
%t\
|
%t\
|
||||||
@]%a%t\
|
@]%a%t\
|
||||||
@]"
|
@]"
|
||||||
txt1 (type_expansion t1) t1'
|
txt1 type_expansion te1
|
||||||
txt2 (type_expansion t2) t2'
|
txt2 type_expansion te2
|
||||||
ty_expect_explanation
|
ty_expect_explanation
|
||||||
(trace false "is not compatible with type") tr
|
(trace false "is not compatible with type") tr
|
||||||
(explain mis);
|
(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 t1;
|
||||||
warn_on_missing_def env ppf t2
|
warn_on_missing_def env ppf t2
|
||||||
end;
|
end;
|
||||||
|
Conflicts.print ppf;
|
||||||
print_labels := true
|
print_labels := true
|
||||||
with exn ->
|
with exn ->
|
||||||
print_labels := true;
|
print_labels := true;
|
||||||
|
@ -1701,11 +1970,13 @@ let report_unification_error ppf env ?(unif=true) tr
|
||||||
|
|
||||||
let trace fst keep_last txt ppf tr =
|
let trace fst keep_last txt ppf tr =
|
||||||
print_labels := not !Clflags.classic;
|
print_labels := not !Clflags.classic;
|
||||||
trace_same_names tr;
|
|
||||||
try match tr with
|
try match tr with
|
||||||
t1 :: t2 :: tr' ->
|
t1 :: t2 :: tr' ->
|
||||||
if fst then trace fst txt ppf (t1 :: t2 :: filter_trace keep_last tr')
|
let t1 = trees_of_type_expansion t1 in
|
||||||
else trace fst txt ppf (filter_trace keep_last tr);
|
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
|
print_labels := true
|
||||||
| _ -> ()
|
| _ -> ()
|
||||||
with exn ->
|
with exn ->
|
||||||
|
@ -1720,29 +1991,38 @@ let report_subtyping_error ppf env tr1 txt1 tr2 =
|
||||||
fprintf ppf "@[<v>%a" (trace true (tr2 = []) txt1) tr1;
|
fprintf ppf "@[<v>%a" (trace true (tr2 = []) txt1) tr1;
|
||||||
if tr2 = [] then fprintf ppf "@]" else
|
if tr2 = [] then fprintf ppf "@]" else
|
||||||
let mis = mismatch env true tr2 in
|
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
|
(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 () ->
|
wrap_printing_env ~error:true env (fun () ->
|
||||||
reset ();
|
reset ();
|
||||||
List.iter
|
let tp0 = trees_of_type_path_expansion tp0 in
|
||||||
(fun (tp, tp') -> path_same_name tp0 tp; path_same_name tp0' tp')
|
match tpl with
|
||||||
tpl;
|
|
||||||
match tpl with
|
|
||||||
[] -> assert false
|
[] -> assert false
|
||||||
| [tp, tp'] ->
|
| [tp] ->
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
"@[%t@;<1 2>%a@ \
|
"@[%t@;<1 2>%a@ \
|
||||||
%t@;<1 2>%a\
|
%t@;<1 2>%a\
|
||||||
@]"
|
@]"
|
||||||
txt1 (type_path_expansion tp) tp'
|
txt1 type_path_expansion (trees_of_type_path_expansion tp)
|
||||||
txt3 (type_path_expansion tp0) tp0'
|
txt3 type_path_expansion tp0
|
||||||
| _ ->
|
| _ ->
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
"@[%t@;<1 2>@[<hv>%a@]\
|
"@[%t@;<1 2>@[<hv>%a@]\
|
||||||
@ %t@;<1 2>%a\
|
@ %t@;<1 2>%a\
|
||||||
@]"
|
@]"
|
||||||
txt2 type_path_list tpl
|
txt2 type_path_list (List.map trees_of_type_path_expansion tpl)
|
||||||
txt3 (type_path_expansion tp0) tp0')
|
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 tree_of_path: Path.t -> out_ident
|
||||||
val path: formatter -> Path.t -> unit
|
val path: formatter -> Path.t -> unit
|
||||||
val string_of_path: Path.t -> string
|
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 raw_type_expr: formatter -> type_expr -> unit
|
||||||
val string_of_label: Asttypes.arg_label -> string
|
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 *)
|
(* This affects all the printing functions below *)
|
||||||
(* Also, if [~error:true], then disable the loading of cmis *)
|
(* 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 reset: unit -> unit
|
||||||
val mark_loops: type_expr -> unit
|
val mark_loops: type_expr -> unit
|
||||||
val reset_and_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
|
Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item
|
||||||
val modtype: formatter -> module_type -> unit
|
val modtype: formatter -> module_type -> unit
|
||||||
val signature: formatter -> signature -> unit
|
val signature: formatter -> signature -> unit
|
||||||
|
val tree_of_modtype: module_type -> out_module_type
|
||||||
val tree_of_modtype_declaration:
|
val tree_of_modtype_declaration:
|
||||||
Ident.t -> modtype_declaration -> out_sig_item
|
Ident.t -> modtype_declaration -> out_sig_item
|
||||||
val tree_of_signature: Types.signature -> out_sig_item list
|
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
|
(* 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. *)
|
for Foo__bar. This pattern is used by the stdlib. *)
|
||||||
val rewrite_double_underscore_paths: Env.t -> Path.t -> Path.t
|
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];
|
Printtyp.reset_and_mark_loops_list [abbrev; actual; expected];
|
||||||
fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \
|
fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \
|
||||||
but is used with type@ %a@]"
|
but is used with type@ %a@]"
|
||||||
Printtyp.type_expr abbrev
|
!Oprint.out_type (Printtyp.tree_of_typexp false abbrev)
|
||||||
Printtyp.type_expr actual
|
!Oprint.out_type (Printtyp.tree_of_typexp false actual)
|
||||||
Printtyp.type_expr expected
|
!Oprint.out_type (Printtyp.tree_of_typexp false expected)
|
||||||
| Constructor_type_mismatch (c, trace) ->
|
| Constructor_type_mismatch (c, trace) ->
|
||||||
Printtyp.report_unification_error ppf env trace
|
Printtyp.report_unification_error ppf env trace
|
||||||
(function ppf ->
|
(function ppf ->
|
||||||
|
@ -1929,7 +1929,9 @@ let report_error env ppf = function
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
"@[The abbreviation %a@ is used with parameters@ %a@ \
|
"@[The abbreviation %a@ is used with parameters@ %a@ \
|
||||||
which are incompatible with constraints@ %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 ->
|
| Class_match_failure error ->
|
||||||
Includeclass.report_error ppf error
|
Includeclass.report_error ppf error
|
||||||
| Unbound_val lab ->
|
| Unbound_val lab ->
|
||||||
|
@ -1941,7 +1943,9 @@ let report_error env ppf = function
|
||||||
List.iter Printtyp.mark_loops [ty; ty1];
|
List.iter Printtyp.mark_loops [ty; ty1];
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
"The %s %s@ has type@;<1 2>%a@ where@ %a@ is unbound"
|
"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
|
in
|
||||||
let print_reason ppf = function
|
let print_reason ppf = function
|
||||||
| Ctype.CC_Method (ty0, real, lab, ty) ->
|
| Ctype.CC_Method (ty0, real, lab, ty) ->
|
||||||
|
|
|
@ -719,7 +719,9 @@ end) = struct
|
||||||
let tpaths = unique (compare_type_path env) [tpath] others in
|
let tpaths = unique (compare_type_path env) [tpath] others in
|
||||||
match tpaths with
|
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 disambiguate_by_type env tpath lbls =
|
||||||
let check_type (lbl, _) =
|
let check_type (lbl, _) =
|
||||||
|
@ -736,11 +738,13 @@ end) = struct
|
||||||
[] -> unbound_name_error env lid
|
[] -> unbound_name_error env lid
|
||||||
| (lbl, use) :: rest ->
|
| (lbl, use) :: rest ->
|
||||||
use ();
|
use ();
|
||||||
|
Printtyp.Conflicts.reset ();
|
||||||
let paths = ambiguous_types env lbl rest in
|
let paths = ambiguous_types env lbl rest in
|
||||||
|
let expansion = Format.asprintf "%t" Printtyp.Conflicts.print in
|
||||||
if paths <> [] then
|
if paths <> [] then
|
||||||
warn lid.loc
|
warn lid.loc
|
||||||
(Warnings.Ambiguous_name ([Longident.last lid.txt],
|
(Warnings.Ambiguous_name ([Longident.last lid.txt],
|
||||||
paths, false));
|
paths, false, expansion));
|
||||||
lbl
|
lbl
|
||||||
end
|
end
|
||||||
| Some(tpath0, tpath, pr) ->
|
| Some(tpath0, tpath, pr) ->
|
||||||
|
@ -761,11 +765,14 @@ end) = struct
|
||||||
let lbl_tpath = get_type_path lbl' in
|
let lbl_tpath = get_type_path lbl' in
|
||||||
if not (compare_type_path env tpath lbl_tpath) then warn_pr ()
|
if not (compare_type_path env tpath lbl_tpath) then warn_pr ()
|
||||||
else
|
else
|
||||||
|
Printtyp.Conflicts.reset ();
|
||||||
let paths = ambiguous_types env lbl rest in
|
let paths = ambiguous_types env lbl rest in
|
||||||
|
let expansion =
|
||||||
|
Format.asprintf "%t" Printtyp.Conflicts.print in
|
||||||
if paths <> [] then
|
if paths <> [] then
|
||||||
warn lid.loc
|
warn lid.loc
|
||||||
(Warnings.Ambiguous_name ([Longident.last lid.txt],
|
(Warnings.Ambiguous_name ([Longident.last lid.txt],
|
||||||
paths, false))
|
paths, false, expansion))
|
||||||
end;
|
end;
|
||||||
lbl
|
lbl
|
||||||
with Not_found -> try
|
with Not_found -> try
|
||||||
|
@ -841,7 +848,7 @@ let disambiguate_lid_a_list loc closed env opath lid_a_list =
|
||||||
let open Warnings in
|
let open Warnings in
|
||||||
match msg with
|
match msg with
|
||||||
| Not_principal _ -> w_pr := true
|
| 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], _) ->
|
| Name_out_of_scope(ty, [s], _) ->
|
||||||
w_scope := s :: !w_scope; w_scope_ty := ty
|
w_scope := s :: !w_scope; w_scope_ty := ty
|
||||||
| _ -> Location.prerr_warning loc msg
|
| _ -> 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")
|
(Warnings.Not_principal "this type-based record disambiguation")
|
||||||
else begin
|
else begin
|
||||||
match List.rev !w_amb with
|
match List.rev !w_amb with
|
||||||
(_,types)::_ as amb ->
|
(_,types,ex)::_ as amb ->
|
||||||
let paths =
|
let paths =
|
||||||
List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in
|
List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in
|
||||||
let path = List.hd paths 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
|
if List.for_all (compare_type_path env path) (List.tl paths) then
|
||||||
Location.prerr_warning loc
|
Location.prerr_warning loc
|
||||||
(Warnings.Ambiguous_name (List.map fst amb, types, true))
|
(Warnings.Ambiguous_name (List.map fst3 amb, types, true, ex))
|
||||||
else
|
else
|
||||||
List.iter
|
List.iter
|
||||||
(fun (s,l) -> Location.prerr_warning loc
|
(fun (s,l,ex) -> Location.prerr_warning loc
|
||||||
(Warnings.Ambiguous_name ([s],l,false)))
|
(Warnings.Ambiguous_name ([s],l,false, ex)))
|
||||||
amb
|
amb
|
||||||
| _ -> ()
|
| _ -> ()
|
||||||
end;
|
end;
|
||||||
|
|
|
@ -2013,15 +2013,20 @@ let report_error ppf = function
|
||||||
| Constraint_failed (ty, ty') ->
|
| Constraint_failed (ty, ty') ->
|
||||||
Printtyp.reset_and_mark_loops ty;
|
Printtyp.reset_and_mark_loops ty;
|
||||||
Printtyp.mark_loops ty';
|
Printtyp.mark_loops ty';
|
||||||
|
Printtyp.Naming_context.reset ();
|
||||||
fprintf ppf "@[%s@ @[<hv>Type@ %a@ should be an instance of@ %a@]@]"
|
fprintf ppf "@[%s@ @[<hv>Type@ %a@ should be an instance of@ %a@]@]"
|
||||||
"Constraints are not satisfied in this type."
|
"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') ->
|
| Parameters_differ (path, ty, ty') ->
|
||||||
Printtyp.reset_and_mark_loops ty;
|
Printtyp.reset_and_mark_loops ty;
|
||||||
Printtyp.mark_loops ty';
|
Printtyp.mark_loops ty';
|
||||||
|
Printtyp.Naming_context.reset ();
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
"@[<hv>In the definition of %s, type@ %a@ should be@ %a@]"
|
"@[<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) ->
|
| Inconsistent_constraint (env, trace) ->
|
||||||
fprintf ppf "The type constraints are not consistent.@.";
|
fprintf ppf "The type constraints are not consistent.@.";
|
||||||
Printtyp.report_unification_error ppf env trace
|
Printtyp.report_unification_error ppf env trace
|
||||||
|
@ -2050,7 +2055,7 @@ let report_error ppf = function
|
||||||
)
|
)
|
||||||
"case" (fun ppf c ->
|
"case" (fun ppf c ->
|
||||||
fprintf ppf
|
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)
|
Printtyp.constructor_arguments c.Types.cd_args)
|
||||||
| Type_record (tl, _), _ ->
|
| Type_record (tl, _), _ ->
|
||||||
explain_unbound ppf ty tl (fun l -> l.Types.ld_type)
|
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
|
if !Clflags.print_types then begin
|
||||||
Typecore.force_delayed_checks ();
|
Typecore.force_delayed_checks ();
|
||||||
Printtyp.wrap_printing_env ~error:false initial_env
|
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 *)
|
(str, Tcoerce_none) (* result is ignored by Compile.implementation *)
|
||||||
end else begin
|
end else begin
|
||||||
let sourceintf =
|
let sourceintf =
|
||||||
|
|
|
@ -922,9 +922,9 @@ let report_error env ppf = function
|
||||||
Printtyp.reset_and_mark_loops_list [ty; ty'];
|
Printtyp.reset_and_mark_loops_list [ty; ty'];
|
||||||
fprintf ppf "@[<hov>%s %a@ %s@ %a@]"
|
fprintf ppf "@[<hov>%s %a@ %s@ %a@]"
|
||||||
"This variant type contains a constructor"
|
"This variant type contains a constructor"
|
||||||
Printtyp.type_expr ty
|
!Oprint.out_type (tree_of_typexp false ty)
|
||||||
"which should be"
|
"which should be"
|
||||||
Printtyp.type_expr ty')
|
!Oprint.out_type (tree_of_typexp false ty'))
|
||||||
| Not_a_variant ty ->
|
| Not_a_variant ty ->
|
||||||
Printtyp.reset_and_mark_loops ty;
|
Printtyp.reset_and_mark_loops ty;
|
||||||
fprintf ppf
|
fprintf ppf
|
||||||
|
|
|
@ -67,7 +67,7 @@ type t =
|
||||||
| Unused_extension of string * bool * bool * bool (* 38 *)
|
| Unused_extension of string * bool * bool * bool (* 38 *)
|
||||||
| Unused_rec_flag (* 39 *)
|
| Unused_rec_flag (* 39 *)
|
||||||
| Name_out_of_scope of string * string list * bool (* 40 *)
|
| 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 *)
|
| Disambiguated_name of string (* 42 *)
|
||||||
| Nonoptional_label of string (* 43 *)
|
| Nonoptional_label of string (* 43 *)
|
||||||
| Open_shadow_identifier of string * string (* 44 *)
|
| Open_shadow_identifier of string * string (* 44 *)
|
||||||
|
@ -89,6 +89,7 @@ type t =
|
||||||
| Unused_module of string (* 60 *)
|
| Unused_module of string (* 60 *)
|
||||||
| Unboxable_type_in_prim_decl of string (* 61 *)
|
| Unboxable_type_in_prim_decl of string (* 61 *)
|
||||||
| Constraint_on_gadt (* 62 *)
|
| Constraint_on_gadt (* 62 *)
|
||||||
|
| Erroneous_printed_signature of string (* 63 *)
|
||||||
;;
|
;;
|
||||||
|
|
||||||
(* If you remove a warning, leave a hole in the numbering. NEVER change
|
(* If you remove a warning, leave a hole in the numbering. NEVER change
|
||||||
|
@ -160,9 +161,10 @@ let number = function
|
||||||
| Unused_module _ -> 60
|
| Unused_module _ -> 60
|
||||||
| Unboxable_type_in_prim_decl _ -> 61
|
| Unboxable_type_in_prim_decl _ -> 61
|
||||||
| Constraint_on_gadt -> 62
|
| 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. *)
|
(* Must be the max number returned by the [number] function. *)
|
||||||
|
@ -436,14 +438,16 @@ let message = function
|
||||||
not visible in the current scope: "
|
not visible in the current scope: "
|
||||||
^ String.concat " " slist ^ ".\n\
|
^ String.concat " " slist ^ ".\n\
|
||||||
They will not be selected if the type becomes unknown."
|
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 ^
|
s ^ " belongs to several types: " ^ String.concat " " tl ^
|
||||||
"\nThe first one was selected. Please disambiguate if this is wrong."
|
"\nThe first one was selected. Please disambiguate if this is wrong."
|
||||||
| Ambiguous_name (_, _, false) -> assert false
|
^ expansion
|
||||||
| Ambiguous_name (_slist, tl, true) ->
|
| Ambiguous_name (_, _, false, _ ) -> assert false
|
||||||
|
| Ambiguous_name (_slist, tl, true, expansion) ->
|
||||||
"these field labels belong to several types: " ^
|
"these field labels belong to several types: " ^
|
||||||
String.concat " " tl ^
|
String.concat " " tl ^
|
||||||
"\nThe first one was selected. Please disambiguate if this is wrong."
|
"\nThe first one was selected. Please disambiguate if this is wrong."
|
||||||
|
^ expansion
|
||||||
| Disambiguated_name s ->
|
| Disambiguated_name s ->
|
||||||
"this use of " ^ s ^ " relies on type-directed disambiguation,\n\
|
"this use of " ^ s ^ " relies on type-directed disambiguation,\n\
|
||||||
it will not compile with OCaml 4.00 or earlier."
|
it will not compile with OCaml 4.00 or earlier."
|
||||||
|
@ -521,6 +525,14 @@ let message = function
|
||||||
or [@@unboxed]." t t
|
or [@@unboxed]." t t
|
||||||
| Constraint_on_gadt ->
|
| Constraint_on_gadt ->
|
||||||
"Type constraints do not apply to GADT cases of variant types."
|
"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
|
let sub_locs = function
|
||||||
|
@ -636,7 +648,8 @@ let descriptions =
|
||||||
59, "Assignment to non-mutable value";
|
59, "Assignment to non-mutable value";
|
||||||
60, "Unused module declaration";
|
60, "Unused module declaration";
|
||||||
61, "Unboxable type in primitive 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_extension of string * bool * bool * bool (* 38 *)
|
||||||
| Unused_rec_flag (* 39 *)
|
| Unused_rec_flag (* 39 *)
|
||||||
| Name_out_of_scope of string * string list * bool (* 40 *)
|
| 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 *)
|
| Disambiguated_name of string (* 42 *)
|
||||||
| Nonoptional_label of string (* 43 *)
|
| Nonoptional_label of string (* 43 *)
|
||||||
| Open_shadow_identifier of string * string (* 44 *)
|
| Open_shadow_identifier of string * string (* 44 *)
|
||||||
|
@ -82,6 +82,7 @@ type t =
|
||||||
| Unused_module of string (* 60 *)
|
| Unused_module of string (* 60 *)
|
||||||
| Unboxable_type_in_prim_decl of string (* 61 *)
|
| Unboxable_type_in_prim_decl of string (* 61 *)
|
||||||
| Constraint_on_gadt (* 62 *)
|
| Constraint_on_gadt (* 62 *)
|
||||||
|
| Erroneous_printed_signature of string (* 63 *)
|
||||||
;;
|
;;
|
||||||
|
|
||||||
val parse_options : bool -> string -> unit;;
|
val parse_options : bool -> string -> unit;;
|
||||||
|
|
Loading…
Reference in New Issue