diff --git a/Changes b/Changes index 41299131e..db135c734 100644 --- a/Changes +++ b/Changes @@ -48,6 +48,9 @@ Working version ### Compiler user-interface and warnings: +- PR#6416, GPR#1120: unique printed names for identifiers + (Florian Angeletti, review by Jacques Garrigue) + - MPR#7116, GPR#1430: new -config-var option to get the value of a single configuration variable in scripts. (Gabriel Scherer, review by Sébastien Hinderer and David Allsopp, diff --git a/driver/compile.ml b/driver/compile.ml index 9aeb66a53..1cde34e8b 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -44,7 +44,8 @@ let interface ppf sourcefile outputprefix = if !Clflags.print_types then Printtyp.wrap_printing_env ~error:false initial_env (fun () -> fprintf std_formatter "%a@." - Printtyp.signature (Typemod.simplify_signature sg)); + (Printtyp.printed_signature sourcefile) + (Typemod.simplify_signature sg)); ignore (Includemod.signatures initial_env sg sg); Typecore.force_delayed_checks (); Warnings.check_fatal (); diff --git a/driver/optcompile.ml b/driver/optcompile.ml index d36119cf1..17b3f819c 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -44,7 +44,8 @@ let interface ppf sourcefile outputprefix = if !Clflags.print_types then Printtyp.wrap_printing_env ~error:false initial_env (fun () -> fprintf std_formatter "%a@." - Printtyp.signature (Typemod.simplify_signature sg)); + (Printtyp.printed_signature sourcefile) + (Typemod.simplify_signature sg)); ignore (Includemod.signatures initial_env sg sg); Typecore.force_delayed_checks (); Warnings.check_fatal (); diff --git a/ocamldoc/odoc_print.ml b/ocamldoc/odoc_print.ml index 0ce40dcc9..7ce95303d 100644 --- a/ocamldoc/odoc_print.ml +++ b/ocamldoc/odoc_print.ml @@ -14,6 +14,7 @@ (**************************************************************************) open Format +let () = Printtyp.Naming_context.enable false let new_fmt () = let buf = Buffer.create 512 in diff --git a/ocamldoc/odoc_str.ml b/ocamldoc/odoc_str.ml index 1189ead5e..e250f1617 100644 --- a/ocamldoc/odoc_str.ml +++ b/ocamldoc/odoc_str.ml @@ -16,6 +16,7 @@ (** The functions to get a string from different kinds of elements (types, modules, ...). *) module Name = Odoc_name +let () = Printtyp.Naming_context.enable false let string_of_variance t (co,cn) = if ( t.Odoc_type.ty_kind = Odoc_type.Type_abstract || diff --git a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ocaml.reference b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ocaml.reference index db6133701..b0a670a70 100644 --- a/testsuite/tests/typing-implicit_unpack/implicit_unpack.ocaml.reference +++ b/testsuite/tests/typing-implicit_unpack/implicit_unpack.ocaml.reference @@ -1,7 +1,5 @@ -val sort : (module Stdlib.Set.S with type elt = 'a) -> 'a list -> 'a list = - -val make_set : ('a -> 'a -> int) -> (module Stdlib.Set.S with type elt = 'a) = - +val sort : (module Set.S with type elt = 'a) -> 'a list -> 'a list = +val make_set : ('a -> 'a -> int) -> (module Set.S with type elt = 'a) = val sort_cmp : ('a -> 'a -> int) -> 'a list -> 'a list = module type S = sig type t val x : t end val f : (module S with type t = int) -> int = @@ -71,8 +69,8 @@ module rec Typ : | String of ('a, string) TypEq.t | Pair of (module PAIR with type t = 'a) end -val int : int Typ.typ = Int -val str : string Typ.typ = String +val int : int Typ.typ = Typ.Int +val str : string Typ.typ = Typ.String val pair : 'a Typ.typ -> 'b Typ.typ -> ('a * 'b) Typ.typ = val to_string : 'a Typ.typ -> 'a -> string = module type MapT = diff --git a/testsuite/tests/typing-misc/ocamltests b/testsuite/tests/typing-misc/ocamltests index 2f80cc48d..359a6c161 100644 --- a/testsuite/tests/typing-misc/ocamltests +++ b/testsuite/tests/typing-misc/ocamltests @@ -4,6 +4,8 @@ inside_out.ml labels.ml occur_check.ml polyvars.ml +pr6416.ml +pr6634.ml pr6939-flat-float-array.ml pr6939-no-flat-float-array.ml pr7103.ml @@ -11,6 +13,7 @@ pr7228.ml pr7668_bad.ml printing.ml records.ml +unique_names_in_unification.ml variant.ml wellfounded.ml empty_variant.ml diff --git a/testsuite/tests/typing-misc/pr6416.ml b/testsuite/tests/typing-misc/pr6416.ml new file mode 100644 index 000000000..19d502fda --- /dev/null +++ b/testsuite/tests/typing-misc/pr6416.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 : ) : ... + 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 +|}] diff --git a/testsuite/tests/typing-misc/pr6634.ml b/testsuite/tests/typing-misc/pr6634.ml new file mode 100644 index 000000000..0e809807a --- /dev/null +++ b/testsuite/tests/typing-misc/pr6634.ml @@ -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 +|}] diff --git a/testsuite/tests/typing-misc/unique_names_in_unification.ml b/testsuite/tests/typing-misc/unique_names_in_unification.ml new file mode 100644 index 000000000..b1623e18f --- /dev/null +++ b/testsuite/tests/typing-misc/unique_names_in_unification.ml @@ -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 +|}] diff --git a/testsuite/tests/typing-ocamlc-i/ocamltests b/testsuite/tests/typing-ocamlc-i/ocamltests index dd3bd42ff..5855e551f 100644 --- a/testsuite/tests/typing-ocamlc-i/ocamltests +++ b/testsuite/tests/typing-ocamlc-i/ocamltests @@ -1 +1,5 @@ +pervasives_leitmotiv.ml +pr4791.ml +pr6323.ml +pr7402.ml pr7620_bad.ml diff --git a/testsuite/tests/typing-ocamlc-i/pervasives_leitmotiv.compilers.reference b/testsuite/tests/typing-ocamlc-i/pervasives_leitmotiv.compilers.reference new file mode 100644 index 000000000..358391a3a --- /dev/null +++ b/testsuite/tests/typing-ocamlc-i/pervasives_leitmotiv.compilers.reference @@ -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 diff --git a/testsuite/tests/typing-ocamlc-i/pervasives_leitmotiv.ml b/testsuite/tests/typing-ocamlc-i/pervasives_leitmotiv.ml new file mode 100644 index 000000000..f6ec3f9b1 --- /dev/null +++ b/testsuite/tests/typing-ocamlc-i/pervasives_leitmotiv.ml @@ -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 diff --git a/testsuite/tests/typing-ocamlc-i/pr4791.compilers.reference b/testsuite/tests/typing-ocamlc-i/pr4791.compilers.reference new file mode 100644 index 000000000..b4938f16e --- /dev/null +++ b/testsuite/tests/typing-ocamlc-i/pr4791.compilers.reference @@ -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 diff --git a/testsuite/tests/typing-ocamlc-i/pr4791.ml b/testsuite/tests/typing-ocamlc-i/pr4791.ml new file mode 100644 index 000000000..f78101700 --- /dev/null +++ b/testsuite/tests/typing-ocamlc-i/pr4791.ml @@ -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 diff --git a/testsuite/tests/typing-ocamlc-i/pr6323.compilers.reference b/testsuite/tests/typing-ocamlc-i/pr6323.compilers.reference new file mode 100644 index 000000000..c06cebec3 --- /dev/null +++ b/testsuite/tests/typing-ocamlc-i/pr6323.compilers.reference @@ -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 diff --git a/testsuite/tests/typing-ocamlc-i/pr6323.ml b/testsuite/tests/typing-ocamlc-i/pr6323.ml new file mode 100644 index 000000000..7aff93f1f --- /dev/null +++ b/testsuite/tests/typing-ocamlc-i/pr6323.ml @@ -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 diff --git a/testsuite/tests/typing-ocamlc-i/pr7402.compilers.reference b/testsuite/tests/typing-ocamlc-i/pr7402.compilers.reference new file mode 100644 index 000000000..08c871992 --- /dev/null +++ b/testsuite/tests/typing-ocamlc-i/pr7402.compilers.reference @@ -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 diff --git a/testsuite/tests/typing-ocamlc-i/pr7402.ml b/testsuite/tests/typing-ocamlc-i/pr7402.ml new file mode 100644 index 000000000..b1ccef885 --- /dev/null +++ b/testsuite/tests/typing-ocamlc-i/pr7402.ml @@ -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 diff --git a/toplevel/genprintval.ml b/toplevel/genprintval.ml index 989902486..d8e5572e1 100644 --- a/toplevel/genprintval.ml +++ b/toplevel/genprintval.ml @@ -21,6 +21,7 @@ open Longident open Path open Types open Outcometree +module Out_name = Printtyp.Out_name module type OBJ = sig @@ -102,7 +103,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct else if O.tag arg = Obj.double_tag then list := Oval_float (O.obj arg : float) :: !list else - list := Oval_constr (Oide_ident "_", []) :: !list + list := Oval_constr (Oide_ident (Out_name.create "_"), []) :: !list done; List.rev !list end @@ -110,7 +111,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct let outval_of_untyped_exception bucket = if O.tag bucket <> 0 then - Oval_constr (Oide_ident (O.obj (O.field bucket 0) : string), []) + let name = Out_name.create (O.obj (O.field bucket 0) : string) in + Oval_constr (Oide_ident name, []) else let name = (O.obj(O.field(O.field bucket 0) 0) : string) in let args = @@ -121,7 +123,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct && O.tag(O.field bucket 1) = 0 then outval_of_untyped_exception_args (O.field bucket 1) 0 else outval_of_untyped_exception_args bucket 1 in - Oval_constr (Oide_ident name, args) + Oval_constr (Oide_ident (Out_name.create name), args) (* The user-defined printers. Also used for some builtin types. *) @@ -201,12 +203,12 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct Oide_ident name | Pdot(p, _s, _pos) -> if try - match (lookup_fun (Lident name) env).desc with + match (lookup_fun (Lident (Out_name.print name)) env).desc with | Tconstr(ty_path', _, _) -> Path.same ty_path ty_path' | _ -> false with Not_found -> false then Oide_ident name - else Oide_dot (Printtyp.tree_of_path p, name) + else Oide_dot (Printtyp.tree_of_path p, Out_name.print name) | Papply _ -> Printtyp.tree_of_path ty_path @@ -364,7 +366,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct then nest tree_of_val depth forced_obj ty_arg else tree_of_val depth forced_obj ty_arg in - Oval_constr (Oide_ident "lazy", [v]) + Oval_constr (Oide_ident (Out_name.create "lazy"), [v]) end | Tconstr(path, ty_list, _) -> begin try @@ -414,7 +416,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct lbls 0 obj unbx in Oval_constr(tree_of_constr env path - (Ident.name cd_id), + (Out_name.create (Ident.name cd_id)), [ r ]) end | {type_kind = Type_record(lbl_list, rep)} -> @@ -494,8 +496,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct (* PR#5722: print full module path only for first record field *) let lid = - if pos = 0 then tree_of_label env path name - else Oide_ident name + if pos = 0 then tree_of_label env path (Out_name.create name) + else Oide_ident (Out_name.create name) and v = if unboxed then tree_of_val (depth - 1) obj ty_arg @@ -523,7 +525,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct and tree_of_constr_with_args tree_of_cstr cstr_name inlined start depth obj ty_args unboxed = - let lid = tree_of_cstr cstr_name in + let lid = tree_of_cstr (Out_name.create cstr_name) in let args = if inlined || unboxed then match ty_args with diff --git a/toplevel/opttoploop.ml b/toplevel/opttoploop.ml index cd6d91da0..b89b20778 100644 --- a/toplevel/opttoploop.ml +++ b/toplevel/opttoploop.ml @@ -344,7 +344,7 @@ let execute_phrase print_outcome ppf phr = Ophr_eval (outv, ty) | _ -> assert false else - Ophr_signature (pr_item newenv sg')) + Ophr_signature (pr_item oldenv sg')) else Ophr_signature [] | Exception exn -> toplevel_env := oldenv; diff --git a/toplevel/toploop.ml b/toplevel/toploop.ml index ed97b5296..ca57c7190 100644 --- a/toplevel/toploop.ml +++ b/toplevel/toploop.ml @@ -272,7 +272,7 @@ let execute_phrase print_outcome ppf phr = Ophr_eval (outv, ty) | [] -> Ophr_signature [] - | _ -> Ophr_signature (pr_item newenv sg')) + | _ -> Ophr_signature (pr_item oldenv sg')) else Ophr_signature [] | Exception exn -> toplevel_env := oldenv; diff --git a/typing/includemod.ml b/typing/includemod.ml index c1a691a2c..4a27792ce 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -81,7 +81,7 @@ let value_descriptions ~loc env ~mark cxt subst id vd1 vd2 = (* Inclusion between type declarations *) -let type_declarations ~loc env ~mark ?(old_env=env) cxt subst id decl1 decl2 = +let type_declarations ~loc env ~mark ?old_env:_ cxt subst id decl1 decl2 = let mark = mark_positive mark in if mark then Env.mark_type_used (Ident.name id) decl1; @@ -91,7 +91,7 @@ let type_declarations ~loc env ~mark ?(old_env=env) cxt subst id decl1 decl2 = (Ident.name id) decl1 id decl2 in if err <> [] then - raise(Error[cxt, old_env, Type_declarations(id, decl1, decl2, err)]) + raise(Error[cxt, env, Type_declarations(id, decl1, decl2, err)]) (* Inclusion between extension constructors *) @@ -104,20 +104,20 @@ let extension_constructors ~loc env ~mark cxt subst id ext1 ext2 = (* Inclusion between class declarations *) -let class_type_declarations ~loc ~old_env env cxt subst id decl1 decl2 = +let class_type_declarations ~loc ~old_env:_ env cxt subst id decl1 decl2 = let decl2 = Subst.cltype_declaration subst decl2 in match Includeclass.class_type_declarations ~loc env decl1 decl2 with [] -> () | reason -> - raise(Error[cxt, old_env, + raise(Error[cxt, env, Class_type_declarations(id, decl1, decl2, reason)]) -let class_declarations ~old_env env cxt subst id decl1 decl2 = +let class_declarations ~old_env:_ env cxt subst id decl1 decl2 = let decl2 = Subst.class_declaration subst decl2 in match Includeclass.class_declarations env decl1 decl2 with [] -> () | reason -> - raise(Error[cxt, old_env, Class_declarations(id, decl1, decl2, reason)]) + raise(Error[cxt, env, Class_declarations(id, decl1, decl2, reason)]) (* Expand a module type identifier when possible *) @@ -557,7 +557,6 @@ let modtypes env m1 m2 = (* Error report *) open Format -open Printtyp let show_loc msg ppf loc = let pos = loc.Location.loc_start in @@ -570,19 +569,23 @@ let show_locs ppf (loc1, loc2) = let include_err ppf = function | Missing_field (id, loc, kind) -> - fprintf ppf "The %s `%a' is required but not provided" kind ident id; + fprintf ppf "The %s `%a' is required but not provided" + kind Printtyp.ident id; show_loc "Expected declaration" ppf loc | Value_descriptions(id, d1, d2) -> fprintf ppf "@[Values do not match:@ %a@;<1 -2>is not included in@ %a@]" - (value_description id) d1 (value_description id) d2; - show_locs ppf (d1.val_loc, d2.val_loc); + !Oprint.out_sig_item (Printtyp.tree_of_value_description id d1) + !Oprint.out_sig_item (Printtyp.tree_of_value_description id d2); + show_locs ppf (d1.val_loc, d2.val_loc) | Type_declarations(id, d1, d2, errs) -> fprintf ppf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]" "Type declarations do not match" - (type_declaration id) d1 + !Oprint.out_sig_item + (Printtyp.tree_of_type_declaration id d1 Trec_first) "is not included in" - (type_declaration id) d2 + !Oprint.out_sig_item + (Printtyp.tree_of_type_declaration id d2 Trec_first) show_locs (d1.type_loc, d2.type_loc) (Includecore.report_type_mismatch "the first" "the second" "declaration") errs @@ -590,21 +593,23 @@ let include_err ppf = function fprintf ppf "@[Extension declarations do not match:@ \ %a@;<1 -2>is not included in@ %a@]" - (extension_constructor id) x1 - (extension_constructor id) x2; + !Oprint.out_sig_item + (Printtyp.tree_of_extension_constructor id x1 Text_first) + !Oprint.out_sig_item + (Printtyp.tree_of_extension_constructor id x2 Text_first); show_locs ppf (x1.ext_loc, x2.ext_loc) | Module_types(mty1, mty2)-> fprintf ppf "@[Modules do not match:@ \ %a@;<1 -2>is not included in@ %a@]" - modtype mty1 - modtype mty2 + !Oprint.out_module_type (Printtyp.tree_of_modtype mty1) + !Oprint.out_module_type (Printtyp.tree_of_modtype mty2) | Modtype_infos(id, d1, d2) -> fprintf ppf "@[Module type declarations do not match:@ \ %a@;<1 -2>does not match@ %a@]" - (modtype_declaration id) d1 - (modtype_declaration id) d2 + !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d1) + !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d2) | Modtype_permutation -> fprintf ppf "Illegal permutation of structure fields" | Interface_mismatch(impl_name, intf_name) -> @@ -614,15 +619,17 @@ let include_err ppf = function fprintf ppf "@[Class type declarations do not match:@ \ %a@;<1 -2>does not match@ %a@]@ %a" - (Printtyp.cltype_declaration id) d1 - (Printtyp.cltype_declaration id) d2 + !Oprint.out_sig_item + (Printtyp.tree_of_cltype_declaration id d1 Trec_first) + !Oprint.out_sig_item + (Printtyp.tree_of_cltype_declaration id d2 Trec_first) Includeclass.report_error reason | Class_declarations(id, d1, d2, reason) -> fprintf ppf "@[Class declarations do not match:@ \ %a@;<1 -2>does not match@ %a@]@ %a" - (Printtyp.class_declaration id) d1 - (Printtyp.class_declaration id) d2 + !Oprint.out_sig_item (Printtyp.tree_of_class_declaration id d1 Trec_first) + !Oprint.out_sig_item (Printtyp.tree_of_class_declaration id d2 Trec_first) Includeclass.report_error reason | Unbound_modtype_path path -> fprintf ppf "Unbound module type %a" Printtyp.path path @@ -633,13 +640,14 @@ let include_err ppf = function let rec context ppf = function Module id :: rem -> - fprintf ppf "@[<2>module %a%a@]" ident id args rem + fprintf ppf "@[<2>module %a%a@]" Printtyp.ident id args rem | Modtype id :: rem -> - fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem + fprintf ppf "@[<2>module type %a =@ %a@]" + Printtyp.ident id context_mty rem | Body x :: rem -> fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem | Arg x :: rem -> - fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem + fprintf ppf "functor (%a : %a) -> ..." Printtyp.ident x context_mty rem | [] -> fprintf ppf "" and context_mty ppf = function @@ -650,7 +658,7 @@ and args ppf = function Body x :: rem -> fprintf ppf "(%s)%a" (argname x) args rem | Arg x :: rem -> - fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem + fprintf ppf "(%a :@ %a) : ..." Printtyp.ident x context_mty rem | cxt -> fprintf ppf " :@ %a" context_mty cxt and argname x = @@ -669,7 +677,7 @@ let path_of_context = function let context ppf cxt = if cxt = [] then () else if List.for_all (function Module _ -> true | _ -> false) cxt then - fprintf ppf "In module %a:@ " path (path_of_context cxt) + fprintf ppf "In module %a:@ " Printtyp.path (path_of_context cxt) else fprintf ppf "@[At position@ %a@]@ " context cxt @@ -696,8 +704,9 @@ let report_error ppf errs = else if !pe then (fprintf ppf "...@ "; pe := false) in let print_errs ppf = List.iter (include_err' ppf) in - fprintf ppf "@[%a%a@]" print_errs errs include_err err - + Printtyp.Conflicts.reset(); + fprintf ppf "@[%a%a%t@]" print_errs errs include_err err + Printtyp.Conflicts.print (* We could do a better job to split the individual error items as sub-messages of the main interface mismatch on the whole unit. *) diff --git a/typing/oprint.ml b/typing/oprint.ml index 7e4458ed9..e877343d7 100644 --- a/typing/oprint.ml +++ b/typing/oprint.ml @@ -28,7 +28,7 @@ let print_lident ppf = function let rec print_ident ppf = function - Oide_ident s -> print_lident ppf s + Oide_ident s -> print_lident ppf s.printed_name | Oide_dot (id, s) -> print_ident ppf id; pp_print_char ppf '.'; print_lident ppf s | Oide_apply (id1, id2) -> @@ -309,7 +309,7 @@ and print_simple_out_type ppf = | Otyp_sum _ | Otyp_manifest (_, _) -> () | Otyp_record lbls -> print_record_decl ppf lbls | Otyp_module (p, n, tyl) -> - fprintf ppf "@[<1>(module %s" p; + fprintf ppf "@[<1>(module %a" print_ident p; let first = ref true in List.iter2 (fun s t -> diff --git a/typing/outcometree.mli b/typing/outcometree.mli index e4c62c31f..ec92d15fe 100644 --- a/typing/outcometree.mli +++ b/typing/outcometree.mli @@ -22,10 +22,14 @@ [Toploop.print_out_sig_item] [Toploop.print_out_phrase] *) +(** An [out_name] is a string representation of an identifier which can be + rewritten on the fly to avoid name collisions *) +type out_name = { mutable printed_name: string } + type out_ident = | Oide_apply of out_ident * out_ident | Oide_dot of out_ident * string - | Oide_ident of string + | Oide_ident of out_name type out_string = | Ostr_string @@ -69,7 +73,7 @@ type out_type = | Otyp_variant of bool * out_variant * bool * (string list) option | Otyp_poly of string list * out_type - | Otyp_module of string * string list * out_type list + | Otyp_module of out_ident * string list * out_type list | Otyp_attribute of out_type * out_attribute and out_variant = diff --git a/typing/printtyp.ml b/typing/printtyp.ml index 1b24b9a65..a88575036 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -32,24 +32,255 @@ let rec longident ppf = function | Ldot(p, s) -> fprintf ppf "%a.%s" longident p s | Lapply(p1, p2) -> fprintf ppf "%a(%a)" longident p1 longident p2 -(* Print an identifier *) +(* Print an identifier avoiding name collisions *) -let unique_names = ref Ident.empty +module Out_name = struct + let create x = { printed_name = x } + let print x = x.printed_name + let set out_name x = out_name.printed_name <- x +end -let ident_name id = - try Ident.find_same id !unique_names with Not_found -> Ident.name id +(* printing environment for path shortening and naming *) +let printing_env = ref Env.empty +let human_unique n id = Printf.sprintf "%s/%d" (Ident.name id) n -let add_unique id = - try ignore (Ident.find_same id !unique_names) - with Not_found -> - unique_names := Ident.add id (Ident.unique_toplevel_name id) !unique_names +type namespace = + | Type + | Module + | Module_type + | Class + | Class_type + | Other (** Other bypasses the unique name identifier mechanism *) -let ident ppf id = pp_print_string ppf (ident_name id) +module Namespace = struct + + let id = function + | Type -> 0 + | Module -> 1 + | Module_type -> 2 + | Class -> 3 + | Class_type -> 4 + | Other -> 5 + + let size = 1 + id Other + + let show = + function + | Type -> "type" + | Module -> "module" + | Module_type -> "module type" + | Class -> "class" + | Class_type -> "class type" + | Other -> "" + + let lookup = + let to_lookup f lid = + fst @@ f ?loc:None ?mark:(Some false) (Lident lid) !printing_env in + function + | Type -> fun id -> Env.lookup_type ?loc:None (Lident id) !printing_env + | Module -> fun id -> + Env.lookup_module ~load:false ?loc:None (Lident id) !printing_env + | Module_type -> to_lookup Env.lookup_modtype + | Class -> to_lookup Env.lookup_class + | Class_type -> to_lookup Env.lookup_cltype + | Other -> fun _ -> raise Not_found + + let location namespace id = + let env = !printing_env in + let path = Path.Pident id in + try Some ( + match namespace with + | Type -> (Env.find_type path env).type_loc + | Module -> (Env.find_module path env).md_loc + | Module_type -> (Env.find_modtype path env).mtd_loc + | Class -> (Env.find_class path env).cty_loc + | Class_type -> (Env.find_cltype path env).clty_loc + | Other -> Location.none + ) with Not_found -> None + + let best_class_namespace = function + | Papply _ | Pdot _ -> Module + | Pident c -> + match location Class c with + | Some _ -> Class + | None -> Class_type + +end + +(** {2 Conflicts printing} + Conflicts arise when multiple items are attributed the same name, + the following module stores the global conflict references and + provides the printing functions for explaining the source of + the conflicts. +*) +module Conflicts = struct + module M = Misc.StringMap + type explanation = { kind: namespace; name:string; location:Location.t} + let explanations = ref M.empty + let explain namespace n id = + let name = human_unique n id in + if not (M.mem name !explanations) then + match Namespace.location namespace id with + | None -> () + | Some location -> + explanations := + M.add name { kind = namespace; location; name } !explanations + + let pp_explanation ppf r= + Format.fprintf ppf "@[%aDefinition of %s %s@]" + Location.print r.location (Namespace.show r.kind) r.name + + let pp ppf l = + Format.fprintf ppf "@[%a@]" (Format.pp_print_list pp_explanation) l + + let reset () = explanations := M.empty + let take () = + let c = !explanations in + reset (); + c |> M.bindings |> List.map snd |> List.sort Pervasives.compare + + let print ppf = + let sep ppf = Format.fprintf ppf "@ " in + let l = + List.filter (* remove toplevel locations, since they are too imprecise *) + ( fun a -> + a.location.Location.loc_start.Lexing.pos_fname <> "//toplevel//" ) + (take ()) in + match l with + | [] -> () + | l -> Format.fprintf ppf "%t%a" sep pp l + + let exists () = M.cardinal !explanations >0 +end + + +module Naming_context = struct + +module M = Misc.StringMap +module N = Map.Make(struct type t = int let compare = Pervasives.compare end) +module S = Misc.StringSet + +let enabled = ref true +let enable b = enabled := b + +(** Name mapping *) +type mapping = + | Need_unique_name of int N.t + (** The same name has already been attributed to multiple types. + The [map] argument contains the specific binding time attributed to each + types. + *) + | Uniquely_associated_to of Ident.t * out_name + (** For now, the name [Ident.name id] has been attributed to [id], + [out_name] is used to expand this name if a conflict arises + at a later point + *) + | Associated_to_pervasives of out_name + (** [Associated_to_pervasives out_name] is used when the item + [Pervasives.$name] has been associated to the name [$name]. + Upon a conflict, this name will be expanded to ["Pervasives." ^ name ] *) + +let hid_start = 0 + +let add_hid_id id map = + let new_id = 1 + N.fold (fun _ -> max) map hid_start in + new_id, N.add (Ident.binding_time id) new_id map + +let find_hid id map = + try N.find (Ident.binding_time id) map, map with + Not_found -> add_hid_id id map + +let pervasives name = "Pervasives." ^ name + +let map = Array.make Namespace.size M.empty +let get namespace = map.(Namespace.id namespace) +let set namespace x = map.(Namespace.id namespace) <- x + +(* Names used in recursive definitions are not considered when determining + if a name is already attributed in the current environment. + This is a weaker version of hidden_rec_items used by short-path. *) +let protected = ref S.empty +let add_protected id = protected := S.add (Ident.name id) !protected +let reset_protected () = protected := S.empty + +let pervasives_name namespace name = + if not !enabled then Out_name.create name else + match M.find name (get namespace) with + | Associated_to_pervasives r -> r + | Need_unique_name _ -> Out_name.create (pervasives name) + | Uniquely_associated_to (id',r) -> + let hid, map = add_hid_id id' N.empty in + Out_name.set r (human_unique hid id'); + Conflicts.explain namespace hid id'; + set namespace @@ M.add name (Need_unique_name map) (get namespace); + Out_name.create (pervasives name) + | exception Not_found -> + let r = Out_name.create name in + set namespace @@ M.add name (Associated_to_pervasives r) (get namespace); + r + +(** Lookup for preexisting named item within the current {!printing_env} *) +let env_ident namespace name = + if S.mem name !protected then None else + match Namespace.lookup namespace name with + | Pident id -> Some id + | _ -> None + | exception Not_found -> None + +(** Associate a name to the identifier [id] within [namespace] *) +let ident_name_simple namespace id = + if not !enabled then Out_name.create (Ident.name id) else + let name = Ident.name id in + match M.find name (get namespace) with + | Uniquely_associated_to (id',r) when Ident.same id id' -> + r + | Need_unique_name map -> + let hid, m = find_hid id map in + Conflicts.explain namespace hid id; + set namespace @@ M.add name (Need_unique_name m) (get namespace); + Out_name.create (human_unique hid id) + | Uniquely_associated_to (id',r) -> + let hid', m = find_hid id' N.empty in + let hid, m = find_hid id m in + Out_name.set r (human_unique hid' id'); + List.iter (fun (id,hid) -> Conflicts.explain namespace hid id) + [id, hid; id', hid' ]; + set namespace @@ M.add name (Need_unique_name m) (get namespace); + Out_name.create (human_unique hid id) + | Associated_to_pervasives r -> + Out_name.set r ("Pervasives." ^ Out_name.print r); + let hid, m = find_hid id N.empty in + set namespace @@ M.add name (Need_unique_name m) (get namespace); + Out_name.create (human_unique hid id) + | exception Not_found -> + let r = Out_name.create name in + set namespace + @@ M.add name (Uniquely_associated_to (id,r) ) (get namespace); + r + +(** Same as {!ident_name_simple} but lookup to existing named identifiers + in the current {!printing_env} *) +let ident_name namespace id = + begin match env_ident namespace (Ident.name id) with + | Some id' -> ignore (ident_name_simple namespace id') + | None -> () + end; + ident_name_simple namespace id + +let reset () = + Array.iteri ( fun i _ -> map.(i) <- M.empty ) map + +end +let ident_name = Naming_context.ident_name +let reset_naming_context = Naming_context.reset + +let ident ppf id = pp_print_string ppf + (Out_name.print (Naming_context.ident_name_simple Other id)) (* Print a path *) let ident_stdlib = Ident.create_persistent "Stdlib" -let printing_env = ref Env.empty + let non_shadowed_pervasive = function | Pdot(Pident id, s, _) as path -> Ident.same id ident_stdlib && @@ -126,17 +357,15 @@ let rewrite_double_underscore_paths env p = else rewrite_double_underscore_paths env p -let rec tree_of_path = function +let rec tree_of_path namespace = function | Pident id -> - Oide_ident (ident_name id) - | Pdot(_, s, _pos) as path - when non_shadowed_pervasive path -> - Oide_ident s + Oide_ident (ident_name namespace id) + | Pdot(_, s, _pos) as path when non_shadowed_pervasive path -> + Oide_ident (Naming_context.pervasives_name namespace s) | Pdot(p, s, _pos) -> - Oide_dot (tree_of_path p, s) + Oide_dot (tree_of_path Module p, s) | Papply(p1, p2) -> - Oide_apply (tree_of_path p1, - tree_of_path p2) + Oide_apply (tree_of_path Module p1, tree_of_path Module p2) let rec path ppf = function | Pident id -> @@ -151,19 +380,24 @@ let rec path ppf = function | Papply(p1, p2) -> fprintf ppf "%a(%a)" path p1 path p2 -let tree_of_path p = - tree_of_path (rewrite_double_underscore_paths !printing_env p) +let tree_of_path namespace p = + tree_of_path namespace (rewrite_double_underscore_paths !printing_env p) let path ppf p = path ppf (rewrite_double_underscore_paths !printing_env p) let rec string_of_out_ident = function - | Oide_ident s -> s + | Oide_ident s -> Out_name.print s | Oide_dot (id, s) -> String.concat "." [string_of_out_ident id; s] | Oide_apply (id1, id2) -> String.concat "" [string_of_out_ident id1; "("; string_of_out_ident id2; ")"] -let string_of_path p = string_of_out_ident (tree_of_path p) +let string_of_path p = string_of_out_ident (tree_of_path Other p) + +let strings_of_paths namespace p = + reset_naming_context (); + let trees = List.map (tree_of_path namespace) p in + List.map string_of_out_ident trees (* Print a recursive annotation *) @@ -417,7 +651,7 @@ let set_printing_env env = end let wrap_printing_env env f = - set_printing_env env; + set_printing_env env; reset_naming_context (); try_finally f (fun () -> set_printing_env Env.empty) let wrap_printing_env ~error env f = @@ -642,14 +876,18 @@ let mark_loops ty = let reset_loop_marks () = visited_objects := []; aliased := []; delayed := [] +let reset_except_context () = + reset_names (); reset_loop_marks () + let reset () = - unique_names := Ident.empty; reset_names (); reset_loop_marks () + reset_naming_context (); Conflicts.reset (); + reset_except_context () let reset_and_mark_loops ty = - reset (); mark_loops ty + reset_except_context (); mark_loops ty let reset_and_mark_loops_list tyl = - reset (); List.iter mark_loops tyl + reset_except_context (); List.iter mark_loops tyl (* Disabled in classic mode when printing an unification error *) let print_labels = ref true @@ -691,7 +929,7 @@ let rec tree_of_typexp sch ty = let p', s = best_type_path p in let tyl' = apply_subst s tyl in if is_nth s && not (tyl'=[]) then tree_of_typexp sch (List.hd tyl') else - Otyp_constr (tree_of_path p', tree_of_typlist sch tyl') + Otyp_constr (tree_of_path Type p', tree_of_typlist sch tyl') | Tvariant row -> let row = row_repr row in let fields = @@ -710,7 +948,7 @@ let rec tree_of_typexp sch ty = begin match row.row_name with | Some(p, tyl) when namable_row row -> let (p', s) = best_type_path p in - let id = tree_of_path p' in + let id = tree_of_path Type p' in let args = tree_of_typlist sch (apply_subst s tyl) in let out_variant = if is_nth s then List.hd args else Otyp_constr (id, args) in @@ -760,7 +998,7 @@ let rec tree_of_typexp sch ty = | Tpackage (p, n, tyl) -> let n = List.map (fun li -> String.concat "." (Longident.flatten li)) n in - Otyp_module (Path.name p, n, tree_of_typlist sch tyl) + Otyp_module (tree_of_path Module_type p, n, tree_of_typlist sch tyl) in if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed; if is_aliased px && aliasable ty then begin @@ -804,7 +1042,7 @@ and tree_of_typobject sch fi nm = let args = tree_of_typlist sch tyl in let (p', s) = best_type_path p in assert (s = Id); - Otyp_class (non_gen, tree_of_path p', args) + Otyp_class (non_gen, tree_of_path Type p', args) | _ -> fatal_error "Printtyp.tree_of_typobject" end @@ -836,15 +1074,6 @@ and type_sch ppf ty = typexp true ppf ty and type_scheme ppf ty = reset_and_mark_loops ty; typexp true ppf ty -let type_expansion ppf ty1 ty2 = - let tree1 = tree_of_typexp false ty1 in - let tree2 = tree_of_typexp false ty2 in - let pp = !Oprint.out_type in - if tree1 = tree2 then - pp ppf tree1 - else - fprintf ppf "@[<2>%a@ =@ %a@]" pp tree1 pp tree2 - (* Maxence *) let type_scheme_max ?(b_reset_names=true) ppf ty = if b_reset_names then reset_names () ; @@ -881,7 +1110,7 @@ let mark_loops_constructor_arguments = function let rec tree_of_type_decl id decl = - reset(); + reset_except_context(); let params = filter_params decl.type_params in @@ -1028,7 +1257,7 @@ let constructor_arguments ppf a = (* Print an extension declaration *) let tree_of_extension_constructor id ext es = - reset (); + reset_except_context (); let ty_name = Path.name ext.ext_type_path in let ty_params = filter_params ext.ext_type_params in List.iter add_alias ty_params; @@ -1148,7 +1377,8 @@ let rec tree_of_class_type sch params = then tree_of_class_type sch params cty else - Octy_constr (tree_of_path p', tree_of_typlist true tyl) + let namespace = Namespace.best_class_namespace p' in + Octy_constr (tree_of_path namespace p', tree_of_typlist true tyl) | Cty_signature sign -> let sty = repr sign.csig_self in let self_ty = @@ -1211,7 +1441,7 @@ let class_variance = let tree_of_class_declaration id cl rs = let params = filter_params cl.cty_params in - reset (); + reset_except_context (); List.iter add_alias params; prepare_class_type params cl.cty_type; let sty = Ctype.self_type cl.cty_type in @@ -1233,7 +1463,7 @@ let class_declaration id ppf cl = let tree_of_cltype_declaration id cl rs = let params = List.map repr cl.clty_params in - reset (); + reset_except_context (); List.iter add_alias params; prepare_class_type params cl.clty_type; let sty = Ctype.self_type cl.clty_type in @@ -1291,6 +1521,10 @@ let dummy = type_unboxed = unboxed_false_default_false; } +let hide ids env = List.fold_right + (fun id -> Env.add_type ~check:false (Ident.rename id) dummy) + ids env + let hide_rec_items = function | Sig_type(id, _decl, rs) ::rem when rs = Trec_first && not !Clflags.real_paths -> @@ -1301,14 +1535,37 @@ let hide_rec_items = function in let ids = id :: get_ids rem in set_printing_env - (List.fold_right - (fun id -> Env.add_type ~check:false (Ident.rename id) dummy) - ids !printing_env) + (hide ids !printing_env) | _ -> () +let recursive_sigitem = function + | Sig_class(id,_,rs) -> Some(id,rs,3) + | Sig_class_type (id,_,rs) -> Some(id,rs,2) + | Sig_type(id, _, rs) + | Sig_module(id, _, rs) -> Some (id,rs,0) + | _ -> None + +let skip k l = snd (Misc.Stdlib.List.split_at k l) + +let protect_rec_items items = + let rec get_ids recs = function + | [] -> [] + | item :: rem -> match recursive_sigitem item with + | Some (id, r, k ) when r = recs -> id :: get_ids Trec_next (skip k rem) + | _ -> [] in + List.iter Naming_context.add_protected (get_ids Trec_first items) + +let still_in_type_group env' in_type_group item = + match in_type_group, recursive_sigitem item with + true, Some (_,Trec_next,_) -> true + | _, Some (_, (Trec_not | Trec_first),_) -> + Naming_context.reset_protected (); + set_printing_env env'; true + | _ -> Naming_context.reset_protected (); set_printing_env env'; false + let rec tree_of_modtype ?(ellipsis=false) = function | Mty_ident p -> - Omty_ident (tree_of_path p) + Omty_ident (tree_of_path Module_type p) | Mty_signature sg -> Omty_signature (if ellipsis then [Osig_ellipsis] else tree_of_signature sg) @@ -1322,7 +1579,7 @@ let rec tree_of_modtype ?(ellipsis=false) = function Omty_functor (Ident.name param, may_map (tree_of_modtype ~ellipsis:false) ty_arg, res) | Mty_alias(_, p) -> - Omty_alias (tree_of_path p) + Omty_alias (tree_of_path Module p) and tree_of_signature sg = wrap_env (fun env -> env) (tree_of_signature_rec !printing_env false) sg @@ -1330,15 +1587,11 @@ and tree_of_signature sg = and tree_of_signature_rec env' in_type_group = function [] -> [] | item :: rem as items -> - let in_type_group = - match in_type_group, item with - true, Sig_type (_, _, Trec_next) -> true - | _, Sig_type (_, _, (Trec_not | Trec_first)) -> - set_printing_env env'; true - | _ -> set_printing_env env'; false - in + let in_type_group = still_in_type_group env' in_type_group item in let (sg, rem) = filter_rem_sig item rem in hide_rec_items items; + protect_rec_items items; + reset_naming_context (); let trees = trees_of_sigitem item in let env' = Env.add_signature (item :: sg) env' in trees @ tree_of_signature_rec env' in_type_group rem @@ -1398,15 +1651,20 @@ let refresh_weak () = let print_items showval env x = refresh_weak(); - let rec print showval env = function + reset_naming_context (); + Conflicts.reset (); + let rec print showval in_type_group env = function | [] -> [] | item :: rem as items -> - let (_sg, rem) = filter_rem_sig item rem in + let in_type_group = still_in_type_group env in_type_group item in + let (sg, rem) = filter_rem_sig item rem in hide_rec_items items; + protect_rec_items items; + reset_naming_context (); let trees = trees_of_sigitem item in List.map (fun d -> (d, showval env item)) trees @ - print showval env rem in - print showval env x + print showval in_type_group (Env.add_signature (item :: sg) env) rem in + print showval false env x (* Print a signature body (used by -i when compiling a .ml) *) @@ -1416,6 +1674,22 @@ let print_signature ppf tree = let signature ppf sg = fprintf ppf "%a" print_signature (tree_of_signature sg) +(* Print a signature body (used by -i when compiling a .ml) *) +let printed_signature sourcefile ppf sg = + (* we are tracking any collision event for warning 63 *) + Conflicts.reset (); + reset_naming_context (); + let t = tree_of_signature sg in + if Warnings.(is_active @@ Erroneous_printed_signature "") + && Conflicts.exists () + then begin + let conflicts = Format.asprintf "%t" Conflicts.print in + Location.prerr_warning (Location.in_file sourcefile) + (Warnings.Erroneous_printed_signature conflicts); + Warnings.check_fatal () + end; + fprintf ppf "%a" print_signature t + (* Print an unification error *) let same_path t t' = @@ -1435,22 +1709,42 @@ let same_path t t' = | _ -> false -let type_expansion t ppf t' = - if same_path t t' - then begin add_delayed (proxy t); type_expr ppf t end - else - let t' = if proxy t == proxy t' then unalias t' else t' in - type_expansion ppf t t' +type 'a diff = Same of 'a | Diff of 'a * 'a -let type_path_expansion tp ppf tp' = - if Path.same tp tp' then path ppf tp else - fprintf ppf "@[<2>%a@ =@ %a@]" path tp path tp' +let trees_of_type_expansion (t,t') = + if same_path t t' + then begin add_delayed (proxy t); Same (tree_of_typexp false t) end + else + let t' = if proxy t == proxy t' then unalias t' else t' in + (* beware order matter due to side effect, + e.g. when printing object types *) + let first = tree_of_typexp false t in + let second = tree_of_typexp false t' in + if first = second then Same first + else Diff(first,second) + +let type_expansion ppf = function + | Same t -> !Oprint.out_type ppf t + | Diff(t,t') -> + fprintf ppf "@[<2>%a@ =@ %a@]" !Oprint.out_type t !Oprint.out_type t' + +let trees_of_trace = List.map trees_of_type_expansion + +let trees_of_type_path_expansion (tp,tp') = + if Path.same tp tp' then Same(tree_of_path Type tp) else + Diff(tree_of_path Type tp, tree_of_path Type tp') + +let type_path_expansion ppf = function + | Same p -> fprintf ppf "%s" (string_of_out_ident p) + | Diff(p,p') -> + fprintf ppf "@[<2>%s@ =@ %s@]" (string_of_out_ident p) + (string_of_out_ident p') let rec trace fst txt ppf = function - | (t1, t1') :: (t2, t2') :: rem -> + | te :: te2 :: rem -> if not fst then fprintf ppf "@,"; fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@] %a" - (type_expansion t1) t1' txt (type_expansion t2) t2' + type_expansion te txt type_expansion te2 (trace false txt) rem | _ -> () @@ -1466,13 +1760,9 @@ let rec filter_trace keep_last = function else (t1, t1') :: (t2, t2') :: rem' | _ -> [] -let rec type_path_list ppf = function - | [tp, tp'] -> type_path_expansion tp ppf tp' - | (tp, tp') :: rem -> - fprintf ppf "%a@;<2 0>%a" - (type_path_expansion tp) tp' - type_path_list rem - | [] -> () +let type_path_list = + Format.pp_print_list ~pp_sep:(fun ppf () -> Format.pp_print_break ppf 2 0) + type_path_expansion (* Hide variant name and var, to force printing the expanded type *) let hide_variant_name t = @@ -1631,33 +1921,8 @@ let warn_on_missing_def env ppf t = end | _ -> () -let ident_same_name id1 id2 = - if Ident.equal id1 id2 && not (Ident.same id1 id2) then begin - add_unique id1; add_unique id2 - end - -let rec path_same_name p1 p2 = - match p1, p2 with - Pident id1, Pident id2 -> ident_same_name id1 id2 - | Pdot (p1, s1, _), Pdot (p2, s2, _) when s1 = s2 -> path_same_name p1 p2 - | Papply (p1, p1'), Papply (p2, p2') -> - path_same_name p1 p2; path_same_name p1' p2' - | _ -> () - -let type_same_name t1 t2 = - match (repr t1).desc, (repr t2).desc with - Tconstr (p1, _, _), Tconstr (p2, _, _) -> - path_same_name (fst (best_type_path p1)) (fst (best_type_path p2)) - | _ -> () - -let rec trace_same_names = function - (t1, t1') :: (t2, t2') :: rem -> - type_same_name t1 t2; type_same_name t1' t2'; trace_same_names rem - | _ -> () - let unification_error env unif tr txt1 ppf txt2 ty_expect_explanation = reset (); - trace_same_names tr; let tr = List.map (fun (t, t') -> (t, hide_variant_name t')) tr in let mis = mismatch env unif tr in match tr with @@ -1669,6 +1934,9 @@ let unification_error env unif tr txt1 ppf txt2 ty_expect_explanation = and t2, t2' = may_prepare_expansion (tr = []) t2 in print_labels := not !Clflags.classic; let tr = List.map prepare_expansion tr in + let te1 = trees_of_type_expansion (t1,t1') + and te2 = trees_of_type_expansion (t2,t2') + and tr = trees_of_trace tr in fprintf ppf "@[\ @[%t@;<1 2>%a@ \ @@ -1676,8 +1944,8 @@ let unification_error env unif tr txt1 ppf txt2 ty_expect_explanation = %t\ @]%a%t\ @]" - txt1 (type_expansion t1) t1' - txt2 (type_expansion t2) t2' + txt1 type_expansion te1 + txt2 type_expansion te2 ty_expect_explanation (trace false "is not compatible with type") tr (explain mis); @@ -1686,6 +1954,7 @@ let unification_error env unif tr txt1 ppf txt2 ty_expect_explanation = warn_on_missing_def env ppf t1; warn_on_missing_def env ppf t2 end; + Conflicts.print ppf; print_labels := true with exn -> print_labels := true; @@ -1701,11 +1970,13 @@ let report_unification_error ppf env ?(unif=true) tr let trace fst keep_last txt ppf tr = print_labels := not !Clflags.classic; - trace_same_names tr; try match tr with t1 :: t2 :: tr' -> - if fst then trace fst txt ppf (t1 :: t2 :: filter_trace keep_last tr') - else trace fst txt ppf (filter_trace keep_last tr); + let t1 = trees_of_type_expansion t1 in + let t2 = trees_of_type_expansion t2 in + let tr = trees_of_trace (filter_trace keep_last tr') in + if fst then trace fst txt ppf (t1 :: t2 :: tr) + else trace fst txt ppf tr; print_labels := true | _ -> () with exn -> @@ -1720,29 +1991,38 @@ let report_subtyping_error ppf env tr1 txt1 tr2 = fprintf ppf "@[%a" (trace true (tr2 = []) txt1) tr1; if tr2 = [] then fprintf ppf "@]" else let mis = mismatch env true tr2 in - fprintf ppf "%a%t@]" + fprintf ppf "%a%t%t@]" (trace false (mis = None) "is not compatible with type") tr2 - (explain mis)) + (explain mis) + Conflicts.print + ) -let report_ambiguous_type_error ppf env (tp0, tp0') tpl txt1 txt2 txt3 = + +let report_ambiguous_type_error ppf env tp0 tpl txt1 txt2 txt3 = wrap_printing_env ~error:true env (fun () -> reset (); - List.iter - (fun (tp, tp') -> path_same_name tp0 tp; path_same_name tp0' tp') - tpl; - match tpl with + let tp0 = trees_of_type_path_expansion tp0 in + match tpl with [] -> assert false - | [tp, tp'] -> + | [tp] -> fprintf ppf "@[%t@;<1 2>%a@ \ %t@;<1 2>%a\ @]" - txt1 (type_path_expansion tp) tp' - txt3 (type_path_expansion tp0) tp0' + txt1 type_path_expansion (trees_of_type_path_expansion tp) + txt3 type_path_expansion tp0 | _ -> fprintf ppf "@[%t@;<1 2>@[%a@]\ @ %t@;<1 2>%a\ @]" - txt2 type_path_list tpl - txt3 (type_path_expansion tp0) tp0') + txt2 type_path_list (List.map trees_of_type_path_expansion tpl) + txt3 type_path_expansion tp0) + +(* Adapt functions to exposed interface *) +let tree_of_path = tree_of_path Other +let tree_of_modtype = tree_of_modtype ~ellipsis:false +let type_expansion ty ppf ty' = + type_expansion ppf (trees_of_type_expansion (ty,ty')) +let tree_of_type_declaration id td rs = + wrap_env (hide [id]) (fun () -> tree_of_type_declaration id td rs) () diff --git a/typing/printtyp.mli b/typing/printtyp.mli index ac92d514a..5ed6081e7 100644 --- a/typing/printtyp.mli +++ b/typing/printtyp.mli @@ -24,6 +24,24 @@ val ident: formatter -> Ident.t -> unit val tree_of_path: Path.t -> out_ident val path: formatter -> Path.t -> unit val string_of_path: Path.t -> string + +module Out_name: sig + val create: string -> out_name + val print: out_name -> string +end + +type namespace = + | Type + | Module + | Module_type + | Class + | Class_type + | Other (** Other bypasses the unique name for identifier mechanism *) + +val strings_of_paths: namespace -> Path.t list -> string list + (** Print a list of paths, using the same naming context to + avoid name collisions *) + val raw_type_expr: formatter -> type_expr -> unit val string_of_label: Asttypes.arg_label -> string @@ -32,6 +50,34 @@ val wrap_printing_env: error:bool -> Env.t -> (unit -> 'a) -> 'a (* This affects all the printing functions below *) (* Also, if [~error:true], then disable the loading of cmis *) +module Naming_context: sig + val enable: bool -> unit + (** When contextual names are enabled, the mapping between identifiers + and names is ensured to be one-to-one. *) + + val reset: unit -> unit + (** Reset the naming context *) +end + +(** The [Conflicts] module keeps track of conflicts arising when attributing + names to identifiers and provides functions that can print explanations + for these conflict in error messages *) +module Conflicts: sig + val exists: unit -> bool + (** [exists()] returns true if the current naming context renamed + an identifier to avoid a name collision *) + + type explanation = + { kind: namespace; + name:string; location:Location.t} + + val take: unit -> explanation list + val pp: Format.formatter -> explanation list -> unit + val print: Format.formatter -> unit + val reset: unit -> unit +end + + val reset: unit -> unit val mark_loops: type_expr -> unit val reset_and_mark_loops: type_expr -> unit @@ -59,6 +105,7 @@ val tree_of_module: Ident.t -> ?ellipsis:bool -> module_type -> rec_status -> out_sig_item val modtype: formatter -> module_type -> unit val signature: formatter -> signature -> unit +val tree_of_modtype: module_type -> out_module_type val tree_of_modtype_declaration: Ident.t -> modtype_declaration -> out_sig_item val tree_of_signature: Types.signature -> out_sig_item list @@ -95,3 +142,7 @@ val print_items: (Env.t -> signature_item -> 'a option) -> (* Simple heuristic to rewrite Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias for Foo__bar. This pattern is used by the stdlib. *) val rewrite_double_underscore_paths: Env.t -> Path.t -> Path.t + +(** [printed_signature sourcefile ppf sg] print the signature [sg] of + [sourcefile] with potential warnings for name collisions *) +val printed_signature: string -> formatter -> signature -> unit diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 85a41bc5f..c7c0072f6 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -1887,9 +1887,9 @@ let report_error env ppf = function Printtyp.reset_and_mark_loops_list [abbrev; actual; expected]; fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \ but is used with type@ %a@]" - Printtyp.type_expr abbrev - Printtyp.type_expr actual - Printtyp.type_expr expected + !Oprint.out_type (Printtyp.tree_of_typexp false abbrev) + !Oprint.out_type (Printtyp.tree_of_typexp false actual) + !Oprint.out_type (Printtyp.tree_of_typexp false expected) | Constructor_type_mismatch (c, trace) -> Printtyp.report_unification_error ppf env trace (function ppf -> @@ -1929,7 +1929,9 @@ let report_error env ppf = function fprintf ppf "@[The abbreviation %a@ is used with parameters@ %a@ \ which are incompatible with constraints@ %a@]" - Printtyp.ident id Printtyp.type_expr params Printtyp.type_expr cstrs + Printtyp.ident id + !Oprint.out_type (Printtyp.tree_of_typexp false params) + !Oprint.out_type (Printtyp.tree_of_typexp false cstrs) | Class_match_failure error -> Includeclass.report_error ppf error | Unbound_val lab -> @@ -1941,7 +1943,9 @@ let report_error env ppf = function List.iter Printtyp.mark_loops [ty; ty1]; fprintf ppf "The %s %s@ has type@;<1 2>%a@ where@ %a@ is unbound" - kind lab Printtyp.type_expr ty Printtyp.type_expr ty0 + kind lab + !Oprint.out_type (Printtyp.tree_of_typexp false ty) + !Oprint.out_type (Printtyp.tree_of_typexp false ty0) in let print_reason ppf = function | Ctype.CC_Method (ty0, real, lab, ty) -> diff --git a/typing/typecore.ml b/typing/typecore.ml index 47af9f714..fd5e71d4c 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -719,7 +719,9 @@ end) = struct let tpaths = unique (compare_type_path env) [tpath] others in match tpaths with [_] -> [] - | _ -> List.map Printtyp.string_of_path tpaths + | _ -> let open Printtyp in + wrap_printing_env ~error:true env (fun () -> + reset(); strings_of_paths Type tpaths) let disambiguate_by_type env tpath lbls = let check_type (lbl, _) = @@ -736,11 +738,13 @@ end) = struct [] -> unbound_name_error env lid | (lbl, use) :: rest -> use (); + Printtyp.Conflicts.reset (); let paths = ambiguous_types env lbl rest in + let expansion = Format.asprintf "%t" Printtyp.Conflicts.print in if paths <> [] then warn lid.loc (Warnings.Ambiguous_name ([Longident.last lid.txt], - paths, false)); + paths, false, expansion)); lbl end | Some(tpath0, tpath, pr) -> @@ -761,11 +765,14 @@ end) = struct let lbl_tpath = get_type_path lbl' in if not (compare_type_path env tpath lbl_tpath) then warn_pr () else + Printtyp.Conflicts.reset (); let paths = ambiguous_types env lbl rest in + let expansion = + Format.asprintf "%t" Printtyp.Conflicts.print in if paths <> [] then warn lid.loc (Warnings.Ambiguous_name ([Longident.last lid.txt], - paths, false)) + paths, false, expansion)) end; lbl with Not_found -> try @@ -841,7 +848,7 @@ let disambiguate_lid_a_list loc closed env opath lid_a_list = let open Warnings in match msg with | Not_principal _ -> w_pr := true - | Ambiguous_name([s], l, _) -> w_amb := (s, l) :: !w_amb + | Ambiguous_name([s], l, _, ex) -> w_amb := (s, l, ex) :: !w_amb | Name_out_of_scope(ty, [s], _) -> w_scope := s :: !w_scope; w_scope_ty := ty | _ -> Location.prerr_warning loc msg @@ -875,17 +882,18 @@ let disambiguate_lid_a_list loc closed env opath lid_a_list = (Warnings.Not_principal "this type-based record disambiguation") else begin match List.rev !w_amb with - (_,types)::_ as amb -> + (_,types,ex)::_ as amb -> let paths = List.map (fun (_,lbl,_) -> Label.get_type_path lbl) lbl_a_list in let path = List.hd paths in + let fst3 (x,_,_) = x in if List.for_all (compare_type_path env path) (List.tl paths) then Location.prerr_warning loc - (Warnings.Ambiguous_name (List.map fst amb, types, true)) + (Warnings.Ambiguous_name (List.map fst3 amb, types, true, ex)) else List.iter - (fun (s,l) -> Location.prerr_warning loc - (Warnings.Ambiguous_name ([s],l,false))) + (fun (s,l,ex) -> Location.prerr_warning loc + (Warnings.Ambiguous_name ([s],l,false, ex))) amb | _ -> () end; diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 6a1a580a0..40fcd5ff6 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -2013,15 +2013,20 @@ let report_error ppf = function | Constraint_failed (ty, ty') -> Printtyp.reset_and_mark_loops ty; Printtyp.mark_loops ty'; + Printtyp.Naming_context.reset (); fprintf ppf "@[%s@ @[Type@ %a@ should be an instance of@ %a@]@]" "Constraints are not satisfied in this type." - Printtyp.type_expr ty Printtyp.type_expr ty' + !Oprint.out_type (Printtyp.tree_of_typexp false ty) + !Oprint.out_type (Printtyp.tree_of_typexp false ty') | Parameters_differ (path, ty, ty') -> Printtyp.reset_and_mark_loops ty; Printtyp.mark_loops ty'; + Printtyp.Naming_context.reset (); fprintf ppf "@[In the definition of %s, type@ %a@ should be@ %a@]" - (Path.name path) Printtyp.type_expr ty Printtyp.type_expr ty' + (Path.name path) + !Oprint.out_type (Printtyp.tree_of_typexp false ty) + !Oprint.out_type (Printtyp.tree_of_typexp false ty') | Inconsistent_constraint (env, trace) -> fprintf ppf "The type constraints are not consistent.@."; Printtyp.report_unification_error ppf env trace @@ -2050,7 +2055,7 @@ let report_error ppf = function ) "case" (fun ppf c -> fprintf ppf - "%s of %a" (Ident.name c.Types.cd_id) + "%a of %a" Printtyp.ident c.Types.cd_id Printtyp.constructor_arguments c.Types.cd_args) | Type_record (tl, _), _ -> explain_unbound ppf ty tl (fun l -> l.Types.ld_type) diff --git a/typing/typemod.ml b/typing/typemod.ml index 8590c9b0b..97fac0834 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -1862,7 +1862,9 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = if !Clflags.print_types then begin Typecore.force_delayed_checks (); Printtyp.wrap_printing_env ~error:false initial_env - (fun () -> fprintf std_formatter "%a@." Printtyp.signature simple_sg); + (fun () -> fprintf std_formatter "%a@." + (Printtyp.printed_signature sourcefile) simple_sg + ); (str, Tcoerce_none) (* result is ignored by Compile.implementation *) end else begin let sourceintf = diff --git a/typing/typetexp.ml b/typing/typetexp.ml index 025665ef3..1cb053002 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -922,9 +922,9 @@ let report_error env ppf = function Printtyp.reset_and_mark_loops_list [ty; ty']; fprintf ppf "@[%s %a@ %s@ %a@]" "This variant type contains a constructor" - Printtyp.type_expr ty + !Oprint.out_type (tree_of_typexp false ty) "which should be" - Printtyp.type_expr ty') + !Oprint.out_type (tree_of_typexp false ty')) | Not_a_variant ty -> Printtyp.reset_and_mark_loops ty; fprintf ppf diff --git a/utils/warnings.ml b/utils/warnings.ml index 46142677f..5307ef54f 100644 --- a/utils/warnings.ml +++ b/utils/warnings.ml @@ -67,7 +67,7 @@ type t = | Unused_extension of string * bool * bool * bool (* 38 *) | Unused_rec_flag (* 39 *) | Name_out_of_scope of string * string list * bool (* 40 *) - | Ambiguous_name of string list * string list * bool (* 41 *) + | Ambiguous_name of string list * string list * bool * string (* 41 *) | Disambiguated_name of string (* 42 *) | Nonoptional_label of string (* 43 *) | Open_shadow_identifier of string * string (* 44 *) @@ -89,6 +89,7 @@ type t = | Unused_module of string (* 60 *) | Unboxable_type_in_prim_decl of string (* 61 *) | Constraint_on_gadt (* 62 *) + | Erroneous_printed_signature of string (* 63 *) ;; (* If you remove a warning, leave a hole in the numbering. NEVER change @@ -160,9 +161,10 @@ let number = function | Unused_module _ -> 60 | Unboxable_type_in_prim_decl _ -> 61 | Constraint_on_gadt -> 62 + | Erroneous_printed_signature _ -> 63 ;; -let last_warning_number = 62 +let last_warning_number = 63 ;; (* Must be the max number returned by the [number] function. *) @@ -436,14 +438,16 @@ let message = function not visible in the current scope: " ^ String.concat " " slist ^ ".\n\ They will not be selected if the type becomes unknown." - | Ambiguous_name ([s], tl, false) -> + | Ambiguous_name ([s], tl, false, expansion) -> s ^ " belongs to several types: " ^ String.concat " " tl ^ "\nThe first one was selected. Please disambiguate if this is wrong." - | Ambiguous_name (_, _, false) -> assert false - | Ambiguous_name (_slist, tl, true) -> + ^ expansion + | Ambiguous_name (_, _, false, _ ) -> assert false + | Ambiguous_name (_slist, tl, true, expansion) -> "these field labels belong to several types: " ^ String.concat " " tl ^ "\nThe first one was selected. Please disambiguate if this is wrong." + ^ expansion | Disambiguated_name s -> "this use of " ^ s ^ " relies on type-directed disambiguation,\n\ it will not compile with OCaml 4.00 or earlier." @@ -521,6 +525,14 @@ let message = function or [@@unboxed]." t t | Constraint_on_gadt -> "Type constraints do not apply to GADT cases of variant types." + | Erroneous_printed_signature s -> + "The printed interface differs from the inferred interface.\n\ + The inferred interface contained items which could not be printed\n\ + properly due to name collisions between identifiers." + ^ s + ^ "\nBeware that this warning is purely informational and will not catch\n\ + all instances of erroneous printed interface." + ;; let sub_locs = function @@ -636,7 +648,8 @@ let descriptions = 59, "Assignment to non-mutable value"; 60, "Unused module declaration"; 61, "Unboxable type in primitive declaration"; - 62, "Type constraint on GADT type declaration" + 62, "Type constraint on GADT type declaration"; + 63, "Erroneous printed signature" ] ;; diff --git a/utils/warnings.mli b/utils/warnings.mli index 1171f8b3f..75144fdf9 100644 --- a/utils/warnings.mli +++ b/utils/warnings.mli @@ -60,7 +60,7 @@ type t = | Unused_extension of string * bool * bool * bool (* 38 *) | Unused_rec_flag (* 39 *) | Name_out_of_scope of string * string list * bool (* 40 *) - | Ambiguous_name of string list * string list * bool (* 41 *) + | Ambiguous_name of string list * string list * bool * string (* 41 *) | Disambiguated_name of string (* 42 *) | Nonoptional_label of string (* 43 *) | Open_shadow_identifier of string * string (* 44 *) @@ -82,6 +82,7 @@ type t = | Unused_module of string (* 60 *) | Unboxable_type_in_prim_decl of string (* 61 *) | Constraint_on_gadt (* 62 *) + | Erroneous_printed_signature of string (* 63 *) ;; val parse_options : bool -> string -> unit;;