Short circuit simple inclusion checks
parent
1fd6dc077d
commit
ecfaffe9de
|
@ -1118,6 +1118,15 @@ let normalize_type_path oloc env path =
|
||||||
| Papply _ ->
|
| Papply _ ->
|
||||||
assert false
|
assert false
|
||||||
|
|
||||||
|
let rec normalize_modtype_path env path =
|
||||||
|
let path = normalize_path_prefix None env path in
|
||||||
|
expand_modtype_path env path
|
||||||
|
|
||||||
|
and expand_modtype_path env path =
|
||||||
|
match (find_modtype path env).mtd_type with
|
||||||
|
| Some (Mty_ident path) -> normalize_modtype_path env path
|
||||||
|
| _ | exception Not_found -> path
|
||||||
|
|
||||||
let find_module path env =
|
let find_module path env =
|
||||||
find_module ~alias:false path env
|
find_module ~alias:false path env
|
||||||
|
|
||||||
|
|
|
@ -119,6 +119,8 @@ val normalize_path_prefix: Location.t option -> t -> Path.t -> Path.t
|
||||||
(* Normalize the prefix part of other kinds of paths
|
(* Normalize the prefix part of other kinds of paths
|
||||||
(value/modtype/etc) *)
|
(value/modtype/etc) *)
|
||||||
|
|
||||||
|
val normalize_modtype_path: t -> Path.t -> Path.t
|
||||||
|
(* Normalize a module type path *)
|
||||||
|
|
||||||
val reset_required_globals: unit -> unit
|
val reset_required_globals: unit -> unit
|
||||||
val get_required_globals: unit -> Ident.t list
|
val get_required_globals: unit -> Ident.t list
|
||||||
|
|
|
@ -128,28 +128,16 @@ let class_declarations ~old_env:_ env cxt subst id decl1 decl2 =
|
||||||
|
|
||||||
exception Dont_match
|
exception Dont_match
|
||||||
|
|
||||||
let may_expand_module_path env path =
|
let try_expand_modtype_path env path =
|
||||||
try ignore (Env.find_modtype_expansion path env); true
|
|
||||||
with Not_found -> false
|
|
||||||
|
|
||||||
let expand_module_path env cxt path =
|
|
||||||
try
|
try
|
||||||
Env.find_modtype_expansion path env
|
Env.find_modtype_expansion path env
|
||||||
with Not_found ->
|
with Not_found -> raise Dont_match
|
||||||
raise(Error[cxt, env, Unbound_modtype_path path])
|
|
||||||
|
|
||||||
let expand_module_alias env cxt path =
|
let expand_module_alias env cxt path =
|
||||||
try (Env.find_module path env).md_type
|
try (Env.find_module path env).md_type
|
||||||
with Not_found ->
|
with Not_found ->
|
||||||
raise(Error[cxt, env, Unbound_module_path path])
|
raise(Error[cxt, env, Unbound_module_path path])
|
||||||
|
|
||||||
(*
|
|
||||||
let rec normalize_module_path env cxt path =
|
|
||||||
match expand_module_alias env cxt path with
|
|
||||||
Mty_alias path' -> normalize_module_path env cxt path'
|
|
||||||
| _ -> path
|
|
||||||
*)
|
|
||||||
|
|
||||||
(* Extract name, kind and ident from a signature item *)
|
(* Extract name, kind and ident from a signature item *)
|
||||||
|
|
||||||
type field_desc =
|
type field_desc =
|
||||||
|
@ -243,6 +231,18 @@ and print_coercion3 ppf (i, n, c) =
|
||||||
|
|
||||||
(* Simplify a structure coercion *)
|
(* Simplify a structure coercion *)
|
||||||
|
|
||||||
|
let equal_module_paths env p1 subst p2 =
|
||||||
|
Path.same p1 p2
|
||||||
|
|| Path.same (Env.normalize_module_path None env p1)
|
||||||
|
(Env.normalize_module_path None env
|
||||||
|
(Subst.module_path subst p2))
|
||||||
|
|
||||||
|
let equal_modtype_paths env p1 subst p2 =
|
||||||
|
Path.same p1 p2
|
||||||
|
|| Path.same (Env.normalize_modtype_path env p1)
|
||||||
|
(Env.normalize_modtype_path env
|
||||||
|
(Subst.modtype_path subst p2))
|
||||||
|
|
||||||
let simplify_structure_coercion cc id_pos_list =
|
let simplify_structure_coercion cc id_pos_list =
|
||||||
let rec is_identity_coercion pos = function
|
let rec is_identity_coercion pos = function
|
||||||
| [] ->
|
| [] ->
|
||||||
|
@ -275,34 +275,37 @@ let rec modtypes ~loc env ~mark cxt subst mty1 mty2 =
|
||||||
|
|
||||||
and try_modtypes ~loc env ~mark cxt subst mty1 mty2 =
|
and try_modtypes ~loc env ~mark cxt subst mty1 mty2 =
|
||||||
match mty1, mty2 with
|
match mty1, mty2 with
|
||||||
| Mty_alias p1, Mty_alias p2 ->
|
| (Mty_alias p1, Mty_alias p2) ->
|
||||||
if Env.is_functor_arg p2 env then
|
if Env.is_functor_arg p2 env then
|
||||||
raise (Error[cxt, env, Invalid_module_alias p2]);
|
raise (Error[cxt, env, Invalid_module_alias p2]);
|
||||||
if not (Path.same p1 p2) then begin
|
if not (equal_module_paths env p1 subst p2) then
|
||||||
let p1 = Env.normalize_module_path None env p1
|
raise Dont_match;
|
||||||
and p2 = Env.normalize_module_path None env
|
|
||||||
(Subst.module_path subst p2)
|
|
||||||
in
|
|
||||||
if not (Path.same p1 p2) then raise Dont_match
|
|
||||||
end;
|
|
||||||
Tcoerce_none
|
Tcoerce_none
|
||||||
| (Mty_alias p1, _) -> begin
|
| (Mty_alias p1, _) ->
|
||||||
let p1 = try
|
let p1 = try
|
||||||
Env.normalize_module_path (Some Location.none) env p1
|
Env.normalize_module_path (Some Location.none) env p1
|
||||||
with Env.Error (Env.Missing_module (_, _, path)) ->
|
with Env.Error (Env.Missing_module (_, _, path)) ->
|
||||||
raise (Error[cxt, env, Unbound_module_path path])
|
raise (Error[cxt, env, Unbound_module_path path])
|
||||||
in
|
in
|
||||||
let mty1 =
|
let mty1 = expand_module_alias env cxt p1 in
|
||||||
Mtype.strengthen ~aliasable:true env
|
strengthened_modtypes ~loc ~aliasable:true env ~mark cxt
|
||||||
(expand_module_alias env cxt p1) p1
|
subst mty1 p1 mty2
|
||||||
in
|
| (Mty_ident p1, Mty_ident p2) ->
|
||||||
modtypes ~loc env ~mark cxt subst mty1 mty2
|
let p1 = Env.normalize_modtype_path env p1 in
|
||||||
end
|
let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in
|
||||||
| (Mty_ident p1, _) when may_expand_module_path env p1 ->
|
if Path.same p1 p2 then Tcoerce_none
|
||||||
|
else
|
||||||
|
try_modtypes ~loc env ~mark cxt subst
|
||||||
|
(try_expand_modtype_path env p1)
|
||||||
|
(try_expand_modtype_path env p2)
|
||||||
|
| (Mty_ident p1, _) ->
|
||||||
|
let p1 = Env.normalize_modtype_path env p1 in
|
||||||
try_modtypes ~loc env ~mark cxt subst
|
try_modtypes ~loc env ~mark cxt subst
|
||||||
(expand_module_path env cxt p1) mty2
|
(try_expand_modtype_path env p1) mty2
|
||||||
| (_, Mty_ident _) ->
|
| (_, Mty_ident p2) ->
|
||||||
try_modtypes2 ~loc env ~mark cxt mty1 (Subst.modtype Keep subst mty2)
|
let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in
|
||||||
|
try_modtypes ~loc env ~mark cxt subst mty1
|
||||||
|
(try_expand_modtype_path env p2)
|
||||||
| (Mty_signature sig1, Mty_signature sig2) ->
|
| (Mty_signature sig1, Mty_signature sig2) ->
|
||||||
signatures ~loc env ~mark cxt subst sig1 sig2
|
signatures ~loc env ~mark cxt subst sig1 sig2
|
||||||
| (Mty_functor(Unit, res1), Mty_functor(Unit, res2)) ->
|
| (Mty_functor(Unit, res1), Mty_functor(Unit, res2)) ->
|
||||||
|
@ -338,18 +341,21 @@ and try_modtypes ~loc env ~mark cxt subst mty1 mty2 =
|
||||||
| (_, _) ->
|
| (_, _) ->
|
||||||
raise Dont_match
|
raise Dont_match
|
||||||
|
|
||||||
and try_modtypes2 ~loc env ~mark cxt mty1 mty2 =
|
and strengthened_modtypes ~loc ~aliasable env ~mark cxt subst mty1 path1 mty2 =
|
||||||
(* mty2 is an identifier *)
|
match mty1, mty2 with
|
||||||
match (mty1, mty2) with
|
| Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 ->
|
||||||
(Mty_ident p1, Mty_ident p2)
|
|
||||||
when Path.same (Env.normalize_path_prefix None env p1)
|
|
||||||
(Env.normalize_path_prefix None env p2) ->
|
|
||||||
Tcoerce_none
|
Tcoerce_none
|
||||||
| (_, Mty_ident p2) when may_expand_module_path env p2 ->
|
| _, _ ->
|
||||||
try_modtypes ~loc env ~mark cxt Subst.identity
|
let mty1 = Mtype.strengthen ~aliasable env mty1 path1 in
|
||||||
mty1 (expand_module_path env cxt p2)
|
modtypes ~loc env ~mark cxt subst mty1 mty2
|
||||||
| (_, _) ->
|
|
||||||
raise Dont_match
|
and strengthened_module_decl ~loc ~aliasable env ~mark cxt subst md1 path1 md2 =
|
||||||
|
match md1.md_type, md2.md_type with
|
||||||
|
| Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 ->
|
||||||
|
Tcoerce_none
|
||||||
|
| _, _ ->
|
||||||
|
let md1 = Mtype.strengthen_decl ~aliasable env md1 path1 in
|
||||||
|
modtypes ~loc env ~mark cxt subst md1.md_type md2.md_type
|
||||||
|
|
||||||
(* Inclusion between signatures *)
|
(* Inclusion between signatures *)
|
||||||
|
|
||||||
|
@ -510,8 +516,8 @@ and module_declarations ~loc env ~mark cxt subst id1 md1 md2 =
|
||||||
let p1 = Path.Pident id1 in
|
let p1 = Path.Pident id1 in
|
||||||
if mark_positive mark then
|
if mark_positive mark then
|
||||||
Env.mark_module_used (Ident.name id1) md1.md_loc;
|
Env.mark_module_used (Ident.name id1) md1.md_loc;
|
||||||
modtypes ~loc env ~mark (Module id1::cxt) subst
|
strengthened_modtypes ~loc ~aliasable:true env ~mark (Module id1::cxt) subst
|
||||||
(Mtype.strengthen ~aliasable:true env md1.md_type p1) md2.md_type
|
md1.md_type p1 md2.md_type
|
||||||
|
|
||||||
(* Inclusion between module type specifications *)
|
(* Inclusion between module type specifications *)
|
||||||
|
|
||||||
|
@ -558,8 +564,9 @@ let can_alias env path =
|
||||||
|
|
||||||
let check_modtype_inclusion ~loc env mty1 path1 mty2 =
|
let check_modtype_inclusion ~loc env mty1 path1 mty2 =
|
||||||
let aliasable = can_alias env path1 in
|
let aliasable = can_alias env path1 in
|
||||||
ignore(modtypes ~loc env ~mark:Mark_both [] Subst.identity
|
ignore
|
||||||
(Mtype.strengthen ~aliasable env mty1 path1) mty2)
|
(strengthened_modtypes ~loc ~aliasable env ~mark:Mark_both []
|
||||||
|
Subst.identity mty1 path1 mty2)
|
||||||
|
|
||||||
let () =
|
let () =
|
||||||
Env.check_functor_application :=
|
Env.check_functor_application :=
|
||||||
|
@ -591,6 +598,10 @@ let signatures env ?(mark=Mark_both) sig1 sig2 =
|
||||||
signatures ~loc:Location.none env ~mark [] Subst.identity sig1 sig2
|
signatures ~loc:Location.none env ~mark [] Subst.identity sig1 sig2
|
||||||
let type_declarations ~loc env ?(mark=Mark_both) id decl1 decl2 =
|
let type_declarations ~loc env ?(mark=Mark_both) id decl1 decl2 =
|
||||||
type_declarations ~loc env ~mark [] Subst.identity id decl1 decl2
|
type_declarations ~loc env ~mark [] Subst.identity id decl1 decl2
|
||||||
|
let strengthened_module_decl ~loc ~aliasable env ?(mark=Mark_both)
|
||||||
|
md1 path1 md2 =
|
||||||
|
strengthened_module_decl ~loc ~aliasable env ~mark [] Subst.identity
|
||||||
|
md1 path1 md2
|
||||||
|
|
||||||
(*
|
(*
|
||||||
let modtypes env m1 m2 =
|
let modtypes env m1 m2 =
|
||||||
|
|
|
@ -35,6 +35,10 @@ val modtypes:
|
||||||
loc:Location.t -> Env.t -> ?mark:mark ->
|
loc:Location.t -> Env.t -> ?mark:mark ->
|
||||||
module_type -> module_type -> module_coercion
|
module_type -> module_type -> module_coercion
|
||||||
|
|
||||||
|
val strengthened_module_decl:
|
||||||
|
loc:Location.t -> aliasable:bool -> Env.t -> ?mark:mark ->
|
||||||
|
module_declaration -> Path.t -> module_declaration -> module_coercion
|
||||||
|
|
||||||
val check_modtype_inclusion :
|
val check_modtype_inclusion :
|
||||||
loc:Location.t -> Env.t -> Types.module_type -> Path.t -> Types.module_type ->
|
loc:Location.t -> Env.t -> Types.module_type -> Path.t -> Types.module_type ->
|
||||||
unit
|
unit
|
||||||
|
|
|
@ -45,6 +45,7 @@ val reset_for_saving: unit -> unit
|
||||||
|
|
||||||
val module_path: t -> Path.t -> Path.t
|
val module_path: t -> Path.t -> Path.t
|
||||||
val type_path: t -> Path.t -> Path.t
|
val type_path: t -> Path.t -> Path.t
|
||||||
|
val modtype_path: t -> Path.t -> Path.t
|
||||||
|
|
||||||
val type_expr: t -> type_expr -> type_expr
|
val type_expr: t -> type_expr -> type_expr
|
||||||
val class_type: t -> class_type -> class_type
|
val class_type: t -> class_type -> class_type
|
||||||
|
|
|
@ -550,8 +550,9 @@ let merge_constraint initial_env remove_aliases loc sg constr =
|
||||||
when Ident.name id = s ->
|
when Ident.name id = s ->
|
||||||
let path, md' = Env.lookup_module ~loc lid'.txt initial_env in
|
let path, md' = Env.lookup_module ~loc lid'.txt initial_env in
|
||||||
let aliasable = not (Env.is_functor_arg path env) in
|
let aliasable = not (Env.is_functor_arg path env) in
|
||||||
let newmd = Mtype.strengthen_decl ~aliasable env md' path in
|
ignore
|
||||||
ignore(Includemod.modtypes ~loc env newmd.md_type md.md_type);
|
(Includemod.strengthened_module_decl ~loc ~aliasable env
|
||||||
|
md' path md);
|
||||||
real_ids := [Pident id];
|
real_ids := [Pident id];
|
||||||
(Pident id, lid, Twith_modsubst (path, lid')),
|
(Pident id, lid, Twith_modsubst (path, lid')),
|
||||||
update_rec_next rs rem
|
update_rec_next rs rem
|
||||||
|
|
Loading…
Reference in New Issue