Implement type-checking of open by copying 'components' instead of recreating them from the signature.
alainfrisch
parent
55808123c3
commit
3d037367a2
102
typing/env.ml
102
typing/env.ml
|
|
@ -1777,43 +1777,81 @@ let rec add_signature sg env =
|
|||
|
||||
(* Open a signature path *)
|
||||
|
||||
let open_signature slot root sg env0 =
|
||||
(* First build the paths and substitution *)
|
||||
let (pl, _sub, sg) = prefix_idents_and_subst root Subst.identity sg in
|
||||
let sg = Lazy.force sg in
|
||||
let open_signature slot root env0 =
|
||||
let comps =
|
||||
match get_components (find_module_descr root env0) with
|
||||
| Structure_comps c -> c
|
||||
| Functor_comps _ -> assert false
|
||||
in
|
||||
|
||||
(* Then enter the components in the environment after substitution *)
|
||||
|
||||
let newenv =
|
||||
List.fold_left2
|
||||
(fun env item p ->
|
||||
match item with
|
||||
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
|
||||
let add_l w comps env0 =
|
||||
Tbl.fold
|
||||
(fun name ->
|
||||
List.fold_right
|
||||
(fun (c, _) acc ->
|
||||
EnvTbl.add slot w (Ident.hide (Ident.create name)) c acc env0
|
||||
)
|
||||
)
|
||||
env0 sg pl in
|
||||
{ newenv with summary = Env_open(env0.summary, root) }
|
||||
comps env0
|
||||
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))
|
||||
(Lazy.force ps.ps_sig) env
|
||||
open_signature None (Pident(Ident.create_persistent name)) 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 *)
|
||||
|
||||
|
|
|
|||
|
|
@ -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 *)
|
||||
|
|
|
|||
|
|
@ -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 =
|
||||
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.open_signature Asttypes.Override path' 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)
|
||||
|
|
|
|||
|
|
@ -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 sg = extract_sig_open env lid.loc md.md_type in
|
||||
path, Env.open_signature ~loc ?toplevel ovf path sg env
|
||||
let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in
|
||||
(* TODO: handle same errors as in extract_sig_open *)
|
||||
path, Env.open_signature ~loc ?toplevel ovf path env
|
||||
|
||||
let type_open ?toplevel env sod =
|
||||
let (path, newenv) =
|
||||
|
|
|
|||
Loading…
Reference in New Issue