summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--testsuite/tests/typing-modules-bugs/gatien_baron_20131019_ok.ml7
-rw-r--r--typing/env.ml18
-rw-r--r--typing/env.mli5
-rw-r--r--typing/mtype.ml1
-rw-r--r--typing/typemod.ml27
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