diff options
-rw-r--r-- | testsuite/tests/typing-modules-bugs/gatien_baron_20131019_ok.ml | 7 | ||||
-rw-r--r-- | typing/env.ml | 18 | ||||
-rw-r--r-- | typing/env.mli | 5 | ||||
-rw-r--r-- | typing/mtype.ml | 1 | ||||
-rw-r--r-- | typing/typemod.ml | 27 |
5 files changed, 29 insertions, 29 deletions
diff --git a/testsuite/tests/typing-modules-bugs/gatien_baron_20131019_ok.ml b/testsuite/tests/typing-modules-bugs/gatien_baron_20131019_ok.ml index 702789651..588744549 100644 --- a/testsuite/tests/typing-modules-bugs/gatien_baron_20131019_ok.ml +++ b/testsuite/tests/typing-modules-bugs/gatien_baron_20131019_ok.ml @@ -6,6 +6,13 @@ module Hash2 : sig include (module type of Hash) end = Hash;; let f1 (x : (_,_) Hash1.t) = (x : (_,_) Hashtbl.t);; let f2 (x : (_,_) Hash2.t) = (x : (_,_) Hashtbl.t);; +(* Another case, not using include *) + +module Std2 = struct module M = struct type t end end;; +module Std' = Std2;; +module M' : module type of Std'.M = Std2.M;; +let f3 (x : M'.t) = (x : Std2.M.t);; + (* original report required Core_kernel: module type S = sig open Core_kernel.Std diff --git a/typing/env.ml b/typing/env.ml index 5f1d8141f..cd98b3104 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -266,6 +266,10 @@ let check_modtype_inclusion = (* to be filled with Includemod.check_modtype_inclusion *) ref ((fun env mty1 path1 mty2 -> assert false) : t -> module_type -> Path.t -> module_type -> unit) +let strengthen = + (* to be filled with Mtype.strengthen *) + ref ((fun env mty path -> assert false) : + t -> module_type -> Path.t -> module_type) let md md_type = {md_type; md_attributes=[]} @@ -972,25 +976,29 @@ let add_gadt_instance_chain env lv t = (* Expand manifest module type names at the top of the given module type *) -let rec scrape_alias env mty = - match mty with - Mty_ident path -> +let rec scrape_alias env ?path mty = + match mty, path with + Mty_ident path, _ -> begin try scrape_alias env (find_modtype_expansion path env) with Not_found -> mty end - | Mty_alias path -> + | Mty_alias path, _ -> begin try - scrape_alias env (find_module path env).md_type + scrape_alias env (find_module path env).md_type ~path with Not_found -> Location.prerr_warning Location.none (Warnings.Deprecated ("module " ^ Path.name path ^ " cannot be accessed")); mty end + | mty, Some path -> + !strengthen env mty path | _ -> mty +let scrape_alias env mty = scrape_alias env mty + (* Compute constructor descriptions *) let constructors_of_type ty_path decl = diff --git a/typing/env.mli b/typing/env.mli index 397ed8f63..5abf11a44 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -214,6 +214,8 @@ val check_modtype_inclusion: (t -> module_type -> Path.t -> module_type -> unit) ref (* Forward declaration to break mutual recursion with Typecore. *) val add_delayed_check_forward: ((unit -> unit) -> unit) ref +(* Forward declaration to break mutual recursion with Mtype. *) +val strengthen: (t -> module_type -> Path.t -> module_type) ref (** Folding over all identifiers (for analysis purpose) *) @@ -244,3 +246,6 @@ val fold_classs: val fold_cltypes: (string -> Path.t -> class_type_declaration -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a + +(** Utilities *) +val scrape_alias: t -> module_type -> module_type diff --git a/typing/mtype.ml b/typing/mtype.ml index c30d8d63c..b185242ba 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -85,6 +85,7 @@ and strengthen_sig env sg p = and strengthen_decl env md p = {md with md_type = strengthen env md.md_type p} +let () = Env.strengthen := strengthen (* In nondep_supertype, env is only used for the type it assigns to id. Hence there is no need to keep env up-to-date by adding the bindings diff --git a/typing/typemod.ml b/typing/typemod.ml index aadbcdc23..7e3860703 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -54,34 +54,13 @@ let rec path_concat head p = (* Extract a signature from a module type *) -(* see also Env.scrape_alias *) -let rec scrape_alias_sttn env ?path mty = - match mty, path with - Mty_ident path, _ -> - begin try - scrape_alias_sttn env (Env.find_modtype_expansion path env) - with Not_found -> mty - end - | Mty_alias path, _ -> - begin try - scrape_alias_sttn env (Env.find_module path env).md_type ~path - with Not_found -> - Location.prerr_warning Location.none - (Warnings.Deprecated - ("module " ^ Path.name path ^ " cannot be accessed")); - mty - end - | mty, Some path -> - Mtype.strengthen env mty path - | _ -> mty - let extract_sig env loc mty = - match scrape_alias_sttn env mty with + match Env.scrape_alias env mty with Mty_signature sg -> sg | _ -> raise(Error(loc, env, Signature_expected)) let extract_sig_open env loc mty = - match scrape_alias_sttn env mty with + match Env.scrape_alias env mty with Mty_signature sg -> sg | _ -> raise(Error(loc, env, Structure_expected mty)) @@ -1018,7 +997,7 @@ let rec type_module ?(alias=false) sttn funct_body anchor env smod = let path = try Some (path_of_module arg) with Not_a_path -> None in let funct = type_module (sttn && path <> None) funct_body None env sfunct in - begin match scrape_alias_sttn env funct.mod_type with + begin match Env.scrape_alias env funct.mod_type with Mty_functor(param, mty_param, mty_res) as mty_functor -> let coercion = try |