Expose a more explicit 'copy types' operation in Env (with a representation in summary), instead of a more generic 'update_value'.

Author: alainfrisch

typing/env.ml

@@ -120,6 +120,7 @@ type summary =
   | Env_open of summary * Path.t
   | Env_functor_arg of summary * Ident.t
   | Env_constraints of summary * type_declaration PathMap.t
+  | Env_copy_types of summary * string list
 
 module EnvTbl =
   struct
@@ -315,29 +316,25 @@ module EnvTbl2 =
 
     let find_name name tbl = find_name true name tbl
 
-    let rec update name f tbl summary =
+    let rec update name f tbl =
       try
         let (id, desc) = Ident.find_name name tbl.current in
         let new_desc = f desc in
-        {tbl with current = Ident.add id new_desc tbl.current},
-        Env_value (summary, id, new_desc)
+        {tbl with current = Ident.add id new_desc tbl.current}
       with Not_found ->
         begin match tbl.opened with
         | Some {root; using; next; components} ->
             begin try
               let (desc, pos) = Tbl.find_str name components in
               let new_desc = f desc in
               let components = Tbl.add name (new_desc, pos) components in
-              {tbl with opened = Some {root; using; next; components}},
-              summary (* ?? *)
+              {tbl with opened = Some {root; using; next; components}}
             with Not_found ->
-              let next, summary = update name f next summary in
-              {tbl with opened = Some {root; using; next; components}},
-              summary
+              let next = update name f next in
+              {tbl with opened = Some {root; using; next; components}}
             end
         | None ->
-            tbl,
-            summary
+            tbl
         end
 
 
@@ -1204,9 +1201,10 @@ let lookup_class =
 let lookup_cltype =
   lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
 
-let update_value s f env =
-  let values, summary = EnvTbl2.update s f env.values env.summary in
-  {env with values; summary}
+let copy_types l env =
+  let f desc = {desc with val_type = Subst.type_expr Subst.identity desc.val_type} in
+  let values = List.fold_left (fun env s -> EnvTbl2.update s f env) env.values l in
+  {env with values; summary = Env_copy_types (env.summary, l)}
 
 let mark_value_used env name vd =
   if not (is_implicit_coercion env) then

typing/env.mli

@@ -32,6 +32,7 @@ type summary =
   | Env_open of summary * Path.t
   | Env_functor_arg of summary * Ident.t
   | Env_constraints of summary * type_declaration PathMap.t
+  | Env_copy_types of summary * string list
 
 type t
 
@@ -123,8 +124,7 @@ 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
+val copy_types: string list -> t -> t
   (* Used only in Typecore.duplicate_ident_types. *)
 
 exception Recmodule

typing/envaux.ml

@@ -78,6 +78,8 @@ let rec env_from_summary sum subst =
               Env.add_local_type (Subst.type_path subst path)
                 (Subst.type_declaration subst info))
             map (env_from_summary s subst)
+      | Env_copy_types (s, sl) ->
+          Env.copy_types sl (env_from_summary s subst)
     in
       Hashtbl.add env_cache (sum, subst) env;
       env

typing/typecore.ml

@@ -1883,12 +1883,7 @@ let check_absent_variant env =
 let duplicate_ident_types caselist env =
   let caselist =
     List.filter (fun {pc_lhs} -> contains_gadt env pc_lhs) caselist in
-  let idents = all_idents_cases caselist in
-  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
-
+  Env.copy_types (all_idents_cases caselist) env
 
 (* Getting proper location of already typed expressions.