typemod: improve error message illegal shadowing of included items

parsing/location.ml

@@ -333,11 +333,6 @@ let print_compact ppf loc =
   end
 ;;
 
-let show_loc msg ppf loc =
-  let pos = loc.loc_start in
-  if List.mem pos.Lexing.pos_fname [""; "_none_"; "//toplevel//"] then ()
-  else Format.fprintf ppf "@\n@[<2>%a:@ %s@]" print_loc loc msg
-
 let print_error ppf loc =
   Format.fprintf ppf "%a%t:" print loc print_error_prefix
 

parsing/location.mli

@@ -57,7 +57,6 @@ val input_lexbuf: Lexing.lexbuf option ref
 
 val get_pos_info: Lexing.position -> string * int * int (* file, line, char *)
 val print_loc: formatter -> t -> unit
-val show_loc: string -> formatter -> t -> unit
 val print_error_prefix: formatter -> unit
 val print_error: formatter -> t -> unit
 val print_error_cur_file: formatter -> unit -> unit

testsuite/tests/shadow_include/cannot_shadow_error.compilers.reference

@@ -1,5 +1,6 @@
-File "cannot_shadow_error.ml", line 22, characters 2-19:
-Error: The type name t coming from this include cannot be shadowed as it is used later on by value print
-
 File "cannot_shadow_error.ml", line 23, characters 2-36:
-  Shadowing of type name t
+Error: Illegal shadowing of included type t/1141 by t/1145
+       File "cannot_shadow_error.ml", line 22, characters 2-19:
+         Type t/1141 came from this include
+       File "cannot_shadow_error.ml", line 13, characters 2-43:
+         The value print has no valid type if t/1141 is shadowed

testsuite/tests/shadow_include/shadow_all.ml

@@ -99,8 +99,11 @@ end
 Line _, characters 2-11:
     include S
     ^^^^^^^^^
-Error: The type name t coming from this include cannot be shadowed as it is used later on by value ignore
-
+Error: Illegal shadowing of included type t/1155 by t/1172
+       File "", line 2, characters 2-11:
+         Type t/1155 came from this include
+       File "", line 3, characters 2-24:
+         The value ignore has no valid type if t/1155 is shadowed
 |}]
 
 module type Module = sig
@@ -136,8 +139,11 @@ end
 Line _, characters 2-11:
     include S
     ^^^^^^^^^
-Error: The module name M coming from this include cannot be shadowed as it is used later on by value ignore
-
+Error: Illegal shadowing of included module M/1247 by M/1264
+       File "", line 2, characters 2-11:
+         Module M/1247 came from this include
+       File "", line 3, characters 2-26:
+         The value ignore has no valid type if M/1247 is shadowed
 |}]
 
 
@@ -174,8 +180,11 @@ end
 Line _, characters 2-11:
     include S
     ^^^^^^^^^
-Error: The module type name T coming from this include cannot be shadowed as it is used later on by module F
-
+Error: Illegal shadowing of included module type T/1336 by T/1354
+       File "", line 2, characters 2-11:
+         Module type T/1336 came from this include
+       File "", line 3, characters 2-39:
+         The module F has no valid type if T/1336 is shadowed
 |}]
 
 module type Extension = sig
@@ -188,8 +197,11 @@ end
 Line _, characters 2-11:
     include S
     ^^^^^^^^^
-Error: The type name ext coming from this include cannot be shadowed as it is used later on by extension constructor C2
-
+Error: Illegal shadowing of included type ext/1372 by ext/1389
+       File "", line 2, characters 2-11:
+         Type ext/1372 came from this include
+       File "", line 3, characters 14-16:
+         The extension constructor C2 has no valid type if ext/1372 is shadowed
 |}]
 
 module type Class = sig

testsuite/tests/typing-sigsubst/sigsubst.ml

@@ -22,11 +22,14 @@ module type PrintableComparable = sig
   include Comparable with type t = t
 end
 [%%expect {|
-Line _, characters 2-19:
-    include Printable
-    ^^^^^^^^^^^^^^^^^
-Error: The type name t coming from this include cannot be shadowed as it is used later on by value print
-
+Line _, characters 2-36:
+    include Comparable with type t = t
+    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+Error: Illegal shadowing of included type t/1152 by t/1156
+       File "", line 2, characters 2-19:
+         Type t/1152 came from this include
+       File "", line 3, characters 2-43:
+         The value print has no valid type if t/1152 is shadowed
 |}]
 
 module type Sunderscore = sig

typing/includemod.ml

@@ -558,15 +558,20 @@ let modtypes env m1 m2 =
 
 open Format
 
+let show_loc msg ppf loc =
+  let pos = loc.Location.loc_start in
+  if List.mem pos.Lexing.pos_fname [""; "_none_"; "//toplevel//"] then ()
+  else fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg
+
 let show_locs ppf (loc1, loc2) =
-  Location.show_loc "Expected declaration" ppf loc2;
-  Location.show_loc "Actual declaration" ppf loc1
+  show_loc "Expected declaration" ppf loc2;
+  show_loc "Actual declaration" ppf loc1
 
 let include_err ppf = function
   | Missing_field (id, loc, kind) ->
       fprintf ppf "The %s `%a' is required but not provided"
         kind Printtyp.ident id;
-      Location.show_loc "Expected declaration" ppf loc
+      show_loc "Expected declaration" ppf loc
   | Value_descriptions(id, d1, d2) ->
       fprintf ppf
         "@[<hv 2>Values do not match:@ %a@;<1 -2>is not included in@ %a@]"

typing/typemod.ml

@@ -41,6 +41,16 @@ module Kind = struct
     | Class_type -> "class type"
 end
 
+type hidding_error = {
+  shadowed_item_id: Ident.t;
+  shadowed_item_kind: Kind.t;
+  shadowed_item_loc: Location.t;
+  shadower_id: Ident.t;
+  user_id: Ident.t;
+  user_kind: Kind.t;
+  user_loc: Location.t;
+}
+
 type error =
     Cannot_apply of module_type
   | Not_included of Includemod.error list
@@ -66,7 +76,7 @@ type error =
   | Recursive_module_require_explicit_type
   | Apply_generative
   | Cannot_scrape_alias of Path.t
-  | Cannot_hide_id of Kind.t * Ident.t * Kind.t * Ident.t * Location.t
+  | Cannot_hide_id of hidding_error
 
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error
@@ -684,7 +694,7 @@ let check cl loc tbl id info =
       None
   | Some (Shadowable (shadowed_id, shadowed_loc)) ->
       Hashtbl.replace tbl name info;
-      Some (shadowed_id, (cl, shadowed_loc, loc))
+      Some (shadowed_id, (cl, shadowed_loc, id, loc))
   | Some Exported ->
       raise(Error(loc, Env.empty, Repeated_name(cl, name)))
 
@@ -755,39 +765,44 @@ let check_sig_item names loc = function
    keep only the last (rightmost) one. *)
 
 type signature_simplification_info =
-  (Kind.t * Location.t * Location.t) Ident.Map.t
+  (Kind.t * Location.t * Ident.t * Location.t) Ident.Map.t
 
 let simplify_signature env to_remove sg =
   let ids_to_remove =
-    Ident.Map.fold (fun id (kind, _, _) lst ->
+    Ident.Map.fold (fun id (kind, _, _, _) lst ->
       match kind with
       | Kind.Value
       | Kind.Extension_constructor -> lst
       | _ -> id :: lst
     ) to_remove []
   in
   let aux component sg =
-    let item_kind, id =
+    let user_kind, user_id, user_loc =
       match component with
-      | Sig_value(id, _) -> Kind.Value, id
-      | Sig_type (id, _, _) -> Kind.Type, id
-      | Sig_typext (id, _, _) -> Kind.Extension_constructor, id
-      | Sig_module (id, _, _) -> Kind.Module, id
-      | Sig_modtype (id, _) -> Kind.Module_type, id
-      | Sig_class (id, _, _) -> Kind.Class, id
-      | Sig_class_type (id, _, _) -> Kind.Class_type, id
+      | Sig_value(id, v) -> Kind.Value, id, v.val_loc
+      | Sig_type (id, td, _) -> Kind.Type, id, td.type_loc
+      | Sig_typext (id, te, _) -> Kind.Extension_constructor, id, te.ext_loc
+      | Sig_module (id, md, _) -> Kind.Module, id, md.md_loc
+      | Sig_modtype (id, mtd) -> Kind.Module_type, id, mtd.mtd_loc
+      | Sig_class (id, c, _) -> Kind.Class, id, c.cty_loc
+      | Sig_class_type (id, ct, _) -> Kind.Class_type, id, ct.clty_loc
     in
-    if Ident.Map.mem id to_remove then sg
+    if Ident.Map.mem user_id to_remove then sg
     else
       let component =
         match ids_to_remove with
         | [] -> component
         | ids ->
-          try Mtype.nondep_sig_item env ids component
-          with Ctype.Nondep_cannot_erase id' ->
-            let (kind, def_loc, shadow_loc) = Ident.Map.find id' to_remove in
-            raise (Error(def_loc, env,
-                         Cannot_hide_id (item_kind, id, kind, id', shadow_loc)))
+          try Mtype.nondep_sig_item env ids component with
+          | Ctype.Nondep_cannot_erase shadowed_item_id ->
+            let (shadowed_item_kind, shadowed_item_loc, ser_id, ser_loc) =
+              Ident.Map.find shadowed_item_id to_remove
+            in
+            let hidding_error =
+              { shadowed_item_kind; shadowed_item_id; shadowed_item_loc;
+                shadower_id = ser_id; user_id; user_kind; user_loc }
+            in
+            raise (Error(ser_loc, env, Cannot_hide_id hidding_error))
       in
       component :: sg
   in
@@ -2224,34 +2239,20 @@ let report_error ppf = function
       fprintf ppf
         "This is an alias for module %a, which is missing"
         path p
-  | Cannot_hide_id (item_kind, id, kind, id', shadow_loc) ->
-      fprintf ppf
-        "The %s name %s coming from this include cannot be shadowed as it is \
-         used later on by %s %s@ %a"
-        (Kind.to_string kind) (Ident.name id')
-        (Kind.to_string item_kind) (Ident.name id)
-        (Location.show_loc
-           (Printf.sprintf "Shadowing of %s name %s"
-              (Kind.to_string kind) (Ident.name id')))
-        shadow_loc
-
-        (*
-let show_locs ppf (loc1, loc2) =
-  show_loc "Expected declaration" ppf loc2;
-  show_loc "Actual declaration" ppf loc1
-
-let include_err ppf = function
-  | Missing_field (id, loc, kind) ->
-      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) ->
+  | Cannot_hide_id { shadowed_item_kind; shadowed_item_id; shadowed_item_loc;
+                     shadower_id; user_id; user_kind; user_loc } ->
+      let shadowed_item_kind = Kind.to_string shadowed_item_kind in
       fprintf ppf
-        "@[<hv 2>Values do not match:@ %a@;<1 -2>is not included in@ %a@]"
-        !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)
-           *)
+        "@[<v>Illegal shadowing of included %s %a by %a@ \
+         %a:@;<1 2>%s %a came from this include@ \
+         %a:@;<1 2>The %s %s has no valid type if %a is shadowed@]"
+        shadowed_item_kind Ident.print shadowed_item_id Ident.print shadower_id
+        Location.print_loc shadowed_item_loc
+        (String.capitalize_ascii shadowed_item_kind)
+        Ident.print shadowed_item_id
+        Location.print_loc user_loc
+        (Kind.to_string user_kind) (Ident.name user_id)
+        Ident.print shadowed_item_id
 
 let report_error env ppf err =
   Printtyp.wrap_printing_env ~error:true env (fun () -> report_error ppf err)

typing/typemod.mli

@@ -75,6 +75,16 @@ module Kind : sig
   val to_string : t -> string
 end
 
+type hidding_error = {
+  shadowed_item_id: Ident.t;
+  shadowed_item_kind: Kind.t;
+  shadowed_item_loc: Location.t;
+  shadower_id: Ident.t;
+  user_id: Ident.t;
+  user_kind: Kind.t;
+  user_loc: Location.t;
+}
+
 type error =
     Cannot_apply of module_type
   | Not_included of Includemod.error list
@@ -100,7 +110,7 @@ type error =
   | Recursive_module_require_explicit_type
   | Apply_generative
   | Cannot_scrape_alias of Path.t
-  | Cannot_hide_id of Kind.t * Ident.t * Kind.t * Ident.t * Location.t
+  | Cannot_hide_id of hidding_error
 
 exception Error of Location.t * Env.t * error
 exception Error_forward of Location.error