Fix #7115: shadowing in a branch of a GADT match breaks unused variable warning.

Changes

@@ -416,6 +416,8 @@ Bug fixes:
 - PR#7108: ocamldoc, have -html preserve custom/extended html generators
   (Armaël Guéneau)
 - PR#7096: ocamldoc uses an incorrect subscript/superscript style
+- PR#7115: shadowing in a branch of a GADT match breaks unused variable
+  warning (Alain Frisch, report by Valentin Gatien-Baron)
 - GPR#205: Clear caml_backtrace_last_exn before registering as root
   (report and fix by Frederic Bour)
 - GPR#220: minor -dsource error on recursive modules

testsuite/tests/typing-warnings/pr7115.ml

@@ -0,0 +1,20 @@
+type t = A : t;;
+
+module X1 : sig end = struct
+  let _f ~x (* x unused argument *) = function
+    | A -> let x = () in x
+end;;
+
+module X2 : sig end = struct
+  let x = 42 (* unused value *)
+  let _f = function
+    | A -> let x = () in x
+end;;
+
+module X3 : sig end = struct
+  module O = struct let x = 42 (* unused *) end
+  open O (* unused open *)
+
+  let _f = function
+    | A -> let x = () in x
+end;;

testsuite/tests/typing-warnings/pr7115.ml.reference

@@ -0,0 +1,22 @@
+
+# type t = A : t
+#         Characters 40-41:
+    let _f ~x (* x unused argument *) = function
+            ^
+Warning 27: unused variable x.
+module X1 : sig  end
+#           Characters 36-37:
+    let x = 42 (* unused value *)
+        ^
+Warning 32: unused value x.
+module X2 : sig  end
+#               Characters 54-55:
+    module O = struct let x = 42 (* unused *) end
+                          ^
+Warning 32: unused value x.
+Characters 80-86:
+    open O (* unused open *)
+    ^^^^^^
+Warning 33: unused open O.
+module X3 : sig  end
+# 

typing/env.ml

@@ -922,6 +922,19 @@ and lookup_class =
 and lookup_cltype =
   lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
 
+let update_value s f env =
+  try
+    let ((p, vd), slot) = Ident.find_name s env.values in
+    match p with
+    | Pident id ->
+        let vd2 = f vd in
+        {env with values = Ident.add id ((p, vd2), slot) env.values;
+                  summary = Env_value(env.summary, id, vd2)}
+    | _ ->
+        env
+  with Not_found ->
+    env
+
 let mark_value_used env name vd =
   if not (is_implicit_coercion env) then
     try Hashtbl.find value_declarations (name, vd.val_loc) ()

typing/env.mli

@@ -107,6 +107,10 @@ val lookup_class:
 val lookup_cltype:
   ?loc:Location.t -> Longident.t -> t -> Path.t * class_type_declaration
 
+val update_value:
+  string -> (value_description -> value_description) -> t -> t
+  (* Used only in Typecore.duplicate_ident_types. *)
+
 exception Recmodule
   (* Raise by lookup_module when the identifier refers
      to one of the modules of a recursive definition

typing/typecore.ml

@@ -1861,19 +1861,10 @@ let duplicate_ident_types loc caselist env =
   let caselist =
     List.filter (fun {pc_lhs} -> contains_gadt env pc_lhs) caselist in
   let idents = all_idents_cases caselist in
-  List.fold_left
-    (fun env s ->
-      try
-        (* XXX This will mark the value as being used;
-           I don't think this is what we want *)
-        let (path, desc) = Env.lookup_value (Longident.Lident s) env in
-        match path with
-          Path.Pident id ->
-            let desc = {desc with val_type = correct_levels desc.val_type} in
-            Env.add_value id desc env
-        | _ -> env
-      with Not_found -> env)
-    env idents
+  let upd desc = {desc with val_type = correct_levels desc.val_type} in
+  (* Be careful not the mark the original value as being used, and
+     to keep the same internal 'slot' to track unused opens. *)
+  List.fold_left (fun env s -> Env.update_value s upd env) env idents
 
 (* Typing of expressions *)