Implement type-checking of open by copying 'components' instead of recreating them from the signature.

typing/env.ml

@@ -1777,43 +1777,81 @@ let rec add_signature sg env =
 
 (* Open a signature path *)
 
-let open_signature slot root sg env0 =
+let open_signature slot root env0 =
-  (* First build the paths and substitution *)
+  let comps =
-  let (pl, _sub, sg) = prefix_idents_and_subst root Subst.identity sg in
+    match get_components (find_module_descr root env0) with
-  let sg = Lazy.force sg in
+    | Structure_comps c -> c
+    | Functor_comps _ -> assert false
+  in
 
-  (* Then enter the components in the environment after substitution *)
+  let add_l w comps env0 =
-
+    Tbl.fold
-  let newenv =
+      (fun name ->
-    List.fold_left2
+         List.fold_right
-      (fun env item p ->
+           (fun (c, _) acc ->
-        match item with
+              EnvTbl.add slot w (Ident.hide (Ident.create name)) c acc env0
-          Sig_value(id, decl) ->
+           )
-            store_value slot (Ident.hide id) p decl env env0
-        | Sig_type(id, decl, _) ->
-            store_type ~check:false slot (Ident.hide id) p decl env env0
-        | Sig_typext(id, ext, _) ->
-            store_extension ~check:false slot (Ident.hide id) p ext env env0
-        | Sig_module(id, mty, _) ->
-            store_module ~check:false slot (Ident.hide id) p mty env env0
-        | Sig_modtype(id, decl) ->
-            store_modtype slot (Ident.hide id) p decl env env0
-        | Sig_class(id, decl, _) ->
-            store_class slot (Ident.hide id) p decl env env0
-        | Sig_class_type(id, decl, _) ->
-            store_cltype slot (Ident.hide id) p decl env env0
       )
-      env0 sg pl in
+      comps env0
-  { newenv with summary = Env_open(env0.summary, root) }
+  in
+  let add_map w comps env0 f =
+    Tbl.fold
+      (fun name (c, pos) acc ->
+         EnvTbl.add slot w (Ident.hide (Ident.create name))
+           (Pdot (root, name, pos), f c) acc env0
+      )
+      comps env0
+  in
+  let add w comps env0 = add_map w comps env0 (fun x -> x) in
+  let constrs =
+    add_l (fun x -> `Constructor x) comps.comp_constrs env0.constrs
+  in
+  let labels =
+    add_l (fun x -> `Label x) comps.comp_labels env0.labels
+  in
+  let values =
+    add (fun x -> `Value x) comps.comp_values env0.values
+  in
+  let types =
+    add (fun x -> `Type x) comps.comp_types env0.types
+  in
+  let modtypes =
+    add (fun x -> `Module_type x) comps.comp_modtypes env0.modtypes
+  in
+  let classes =
+    add (fun x -> `Class x) comps.comp_classes env0.classes
+  in
+  let cltypes =
+    add (fun x -> `Class_type x) comps.comp_cltypes env0.cltypes
+  in
+  let components =
+    add (fun x -> `Component x) comps.comp_components env0.components
+  in
+  let modules =
+    (* one should avoid this force, by allowing lazy in env as well *)
+    add_map (fun x -> `Module x) comps.comp_modules env0.modules
+      (fun data -> md (EnvLazy.force subst_modtype_maker data))
+  in
+
+  { env0 with
+    summary = Env_open(env0.summary, root);
+    constrs;
+    labels;
+    values;
+    types;
+    modtypes;
+    classes;
+    cltypes;
+    components;
+    modules;
+  }
 
 (* Open a signature from a file *)
 
 let open_pers_signature name env =
-  let ps = find_pers_struct name in
+  open_signature None (Pident(Ident.create_persistent name)) env
-  open_signature None (Pident(Ident.create_persistent name))
-    (Lazy.force ps.ps_sig) env
 
-let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env =
+let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root env =
   if not toplevel && ovf = Asttypes.Fresh && not loc.Location.loc_ghost
      && (Warnings.is_active (Warnings.Unused_open "")
          || Warnings.is_active (Warnings.Open_shadow_identifier ("", ""))
@@ -1841,9 +1879,9 @@ let open_signature ?(loc = Location.none) ?(toplevel = false) ovf root sg env =
       end;
       used := true
     in
-    open_signature (Some slot) root sg env
+    open_signature (Some slot) root env
   end
-  else open_signature None root sg env
+  else open_signature None root env
 
 (* Read a signature from a file *)
 

typing/env.mli

@@ -157,7 +157,7 @@ val add_signature: signature -> t -> t
 
 val open_signature:
     ?loc:Location.t -> ?toplevel:bool -> Asttypes.override_flag -> Path.t ->
-      signature -> t -> t
+      t -> t
 val open_pers_signature: string -> t -> t
 
 (* Insertion by name *)

typing/envaux.ml

@@ -14,8 +14,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open Misc
-open Types
 open Env
 
 type error =
@@ -30,11 +28,6 @@ let reset_cache () =
   Hashtbl.clear env_cache;
   Env.reset_cache()
 
-let extract_sig env mty =
-  match Env.scrape_alias env mty with
-    Mty_signature sg -> sg
-  | _ -> fatal_error "Envaux.extract_sig"
-
 let rec env_from_summary sum subst =
   try
     Hashtbl.find env_cache (sum, subst)
@@ -70,14 +63,7 @@ let rec env_from_summary sum subst =
       | Env_open(s, path) ->
           let env = env_from_summary s subst in
           let path' = Subst.module_path subst path in
-          let md =
+          Env.open_signature Asttypes.Override path' env
-            try
-              Env.find_module path' env
-            with Not_found ->
-              raise (Error (Module_not_found path'))
-          in
-          Env.open_signature Asttypes.Override path'
-            (extract_sig env md.md_type) env
       | Env_functor_arg(Env_module(s, id, desc), id') when Ident.same id id' ->
           Env.add_module_declaration ~check:false
             id (Subst.module_declaration subst desc)

typing/typemod.ml

@@ -83,9 +83,9 @@ let extract_sig_open env loc mty =
 (* Compute the environment after opening a module *)
 
 let type_open_ ?toplevel ovf env loc lid =
-  let path, md = Typetexp.find_module env lid.loc lid.txt in
+  let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in
-  let sg = extract_sig_open env lid.loc md.md_type in
+  (* TODO: handle same errors as in extract_sig_open *)
-  path, Env.open_signature ~loc ?toplevel ovf path sg env
+  path, Env.open_signature ~loc ?toplevel ovf path env
 
 let type_open ?toplevel env sod =
   let (path, newenv) =