Add `remove_aliases` parameter to `scrape_for_type_of`
parent
414b300b4d
commit
2b412c8ab8
|
@ -401,14 +401,14 @@ let collect_arg_paths mty =
|
||||||
PathSet.fold (fun p -> Ident.Set.union (collect_ids !subst !bindings p))
|
PathSet.fold (fun p -> Ident.Set.union (collect_ids !subst !bindings p))
|
||||||
!paths Ident.Set.empty
|
!paths Ident.Set.empty
|
||||||
|
|
||||||
let rec remove_aliases env excl mty =
|
let rec remove_aliases_mty env excl mty =
|
||||||
match mty with
|
match mty with
|
||||||
Mty_signature sg ->
|
Mty_signature sg ->
|
||||||
Mty_signature (remove_aliases_sig env excl sg)
|
Mty_signature (remove_aliases_sig env excl sg)
|
||||||
| Mty_alias _ ->
|
| Mty_alias _ ->
|
||||||
let mty' = Env.scrape_alias env mty in
|
let mty' = Env.scrape_alias env mty in
|
||||||
if mty' = mty then mty else
|
if mty' = mty then mty else
|
||||||
remove_aliases env excl mty'
|
remove_aliases_mty env excl mty'
|
||||||
| mty ->
|
| mty ->
|
||||||
mty
|
mty
|
||||||
|
|
||||||
|
@ -421,7 +421,7 @@ and remove_aliases_sig env excl sg =
|
||||||
Mty_alias _ when Ident.Set.mem id excl ->
|
Mty_alias _ when Ident.Set.mem id excl ->
|
||||||
md.md_type
|
md.md_type
|
||||||
| mty ->
|
| mty ->
|
||||||
remove_aliases env excl mty
|
remove_aliases_mty env excl mty
|
||||||
in
|
in
|
||||||
Sig_module(id, {md with md_type = mty} , rs) ::
|
Sig_module(id, {md with md_type = mty} , rs) ::
|
||||||
remove_aliases_sig (Env.add_module id mty env) excl rem
|
remove_aliases_sig (Env.add_module id mty env) excl rem
|
||||||
|
@ -431,12 +431,14 @@ and remove_aliases_sig env excl sg =
|
||||||
| it :: rem ->
|
| it :: rem ->
|
||||||
it :: remove_aliases_sig env excl rem
|
it :: remove_aliases_sig env excl rem
|
||||||
|
|
||||||
let remove_aliases env sg =
|
|
||||||
let excl = collect_arg_paths sg in
|
|
||||||
(* PathSet.iter (fun p -> Format.eprintf "%a@ " Printtyp.path p) excl;
|
|
||||||
Format.eprintf "@."; *)
|
|
||||||
remove_aliases env excl sg
|
|
||||||
|
|
||||||
|
let scrape_for_type_of ~remove_aliases env mty =
|
||||||
|
if remove_aliases then begin
|
||||||
|
let excl = collect_arg_paths mty in
|
||||||
|
remove_aliases_mty env excl mty
|
||||||
|
end else begin
|
||||||
|
scrape_for_type_of env mty
|
||||||
|
end
|
||||||
|
|
||||||
(* Lower non-generalizable type variables *)
|
(* Lower non-generalizable type variables *)
|
||||||
|
|
||||||
|
|
|
@ -21,7 +21,8 @@ val scrape: Env.t -> module_type -> module_type
|
||||||
(* Expand toplevel module type abbreviations
|
(* Expand toplevel module type abbreviations
|
||||||
till hitting a "hard" module type (signature, functor,
|
till hitting a "hard" module type (signature, functor,
|
||||||
or abstract module type ident. *)
|
or abstract module type ident. *)
|
||||||
val scrape_for_type_of: Env.t -> module_type -> module_type
|
val scrape_for_type_of:
|
||||||
|
remove_aliases:bool -> Env.t -> module_type -> module_type
|
||||||
(* Expand module aliases *)
|
(* Expand module aliases *)
|
||||||
val freshen: module_type -> module_type
|
val freshen: module_type -> module_type
|
||||||
(* Return an alpha-equivalent copy of the given module type
|
(* Return an alpha-equivalent copy of the given module type
|
||||||
|
@ -44,5 +45,4 @@ val enrich_typedecl: Env.t -> Path.t -> Ident.t -> type_declaration ->
|
||||||
type_declaration
|
type_declaration
|
||||||
val type_paths: Env.t -> Path.t -> module_type -> Path.t list
|
val type_paths: Env.t -> Path.t -> module_type -> Path.t list
|
||||||
val contains_type: Env.t -> module_type -> bool
|
val contains_type: Env.t -> module_type -> bool
|
||||||
val remove_aliases: Env.t -> module_type -> module_type
|
|
||||||
val lower_nongen: int -> module_type -> unit
|
val lower_nongen: int -> module_type -> unit
|
||||||
|
|
|
@ -401,12 +401,7 @@ let merge_constraint initial_env remove_aliases loc sg constr =
|
||||||
when Ident.name id = s ->
|
when Ident.name id = s ->
|
||||||
let path, md' = Typetexp.find_module initial_env loc lid'.txt in
|
let path, md' = Typetexp.find_module initial_env loc lid'.txt in
|
||||||
let mty = md'.md_type in
|
let mty = md'.md_type in
|
||||||
let mty =
|
let mty = Mtype.scrape_for_type_of ~remove_aliases env mty in
|
||||||
if remove_aliases then
|
|
||||||
Mtype.remove_aliases env mty
|
|
||||||
else
|
|
||||||
Mtype.scrape_for_type_of env mty
|
|
||||||
in
|
|
||||||
let md'' = { md' with md_type = mty } in
|
let md'' = { md' with md_type = mty } in
|
||||||
let newmd = Mtype.strengthen_decl ~aliasable:false env md'' path in
|
let newmd = Mtype.strengthen_decl ~aliasable:false env md'' path in
|
||||||
ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type);
|
ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type);
|
||||||
|
@ -1769,13 +1764,7 @@ let type_module_type_of env smod =
|
||||||
| _ -> type_module env smod
|
| _ -> type_module env smod
|
||||||
in
|
in
|
||||||
let mty = tmty.mod_type in
|
let mty = tmty.mod_type in
|
||||||
let mty =
|
let mty = Mtype.scrape_for_type_of ~remove_aliases env mty in
|
||||||
if remove_aliases then
|
|
||||||
(* PR#6307: expand aliases at root and submodules *)
|
|
||||||
Mtype.remove_aliases env mty
|
|
||||||
else
|
|
||||||
Mtype.scrape_for_type_of env mty
|
|
||||||
in
|
|
||||||
(* PR#5036: must not contain non-generalized type variables *)
|
(* PR#5036: must not contain non-generalized type variables *)
|
||||||
if not (closed_modtype env mty) then
|
if not (closed_modtype env mty) then
|
||||||
raise(Error(smod.pmod_loc, env, Non_generalizable_module mty));
|
raise(Error(smod.pmod_loc, env, Non_generalizable_module mty));
|
||||||
|
|
Loading…
Reference in New Issue