Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Add label to bool parameter

master
Leo White 2016-07-21 17:38:28 +01:00
parent caadb9de8a
commit 55a21ff051
6 changed files with 38 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
typing/env.ml
View File

@ -324,8 +324,8 @@ let check_modtype_inclusion =
t -> module_type -> Path.t -> module_type -> unit)
let strengthen =
(* to be filled with Mtype.strengthen *)
ref ((fun _alias _env _mty _path -> assert false) :
bool -> t -> module_type -> Path.t -> module_type)
ref ((fun ~aliasable:_ _env _mty _path -> assert false) :
aliasable:bool -> t -> module_type -> Path.t -> module_type)
let md md_type =
{md_type; md_attributes=[]; md_loc=Location.none}
@ -1307,7 +1307,7 @@ let rec scrape_alias env ?path mty =
mty
end
| mty, Some path ->
!strengthen true env mty path
!strengthen ~aliasable:true env mty path
| _ -> mty
let scrape_alias env mty = scrape_alias env mty

3
typing/env.mli
View File

@ -268,7 +268,8 @@ val check_modtype_inclusion:
(* 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: (bool -> t -> module_type -> Path.t -> module_type) ref
val strengthen:
(aliasable:bool -> t -> module_type -> Path.t -> module_type) ref
(* Forward declaration to break mutual recursion with Ctype. *)
val same_constr: (t -> type_expr -> type_expr -> bool) ref

10
typing/includemod.ml
View File

@ -256,7 +256,8 @@ and try_modtypes env cxt subst mty1 mty2 =
raise (Error[cxt, env, Unbound_module_path path])
in
let mty1 =
Mtype.strengthen true env (expand_module_alias env cxt p1) p1
Mtype.strengthen ~aliasable:true env
(expand_module_alias env cxt p1) p1
in
let cc = modtypes env cxt subst mty1 mty2 in
match pres1 with
@ -412,7 +413,8 @@ and signature_components old_env env cxt subst paired =
Env.mark_module_used env (Ident.name id1) mty1.md_loc;
let cc =
modtypes env (Module id1::cxt) subst
(Mtype.strengthen true env mty1.md_type p1) mty2.md_type in
(Mtype.strengthen ~aliasable:true env mty1.md_type p1) mty2.md_type
in
(pos, cc) :: comps_rec rem
| (Sig_modtype(id1, info1), Sig_modtype(_id2, info2), _pos) :: rem ->
modtype_infos env cxt subst id1 info1 info2;
@ -466,9 +468,9 @@ let can_alias env path =
let check_modtype_inclusion env mty1 path1 mty2 =
try
let alias = can_alias env path1 in
let aliasable = can_alias env path1 in
ignore(modtypes env [] Subst.identity
(Mtype.strengthen alias env mty1 path1) mty2)
(Mtype.strengthen ~aliasable env mty1 path1) mty2)
with Error _ ->
raise Not_found

32
typing/mtype.ml
View File

@ -33,18 +33,18 @@ let rec scrape env mty =
let freshen mty =
Subst.modtype Subst.identity mty
let rec strengthen alias env mty p =
let rec strengthen ~aliasable env mty p =
match scrape env mty with
Mty_signature sg ->
Mty_signature(strengthen_sig alias env sg p 0)
Mty_signature(strengthen_sig ~aliasable env sg p 0)
| Mty_functor(param, arg, res)
when !Clflags.applicative_functors && Ident.name param <> "*" ->
Mty_functor(param, arg,
strengthen false env res (Papply(p, Pident param)))
strengthen ~aliasable:false env res (Papply(p, Pident param)))
| mty ->
mty
and strengthen_sig alias env sg p pos =
and strengthen_sig ~aliasable env sg p pos =
match sg with
[] -> []
| (Sig_value(_, desc) as sigelt) :: rem ->
@ -53,11 +53,11 @@ and strengthen_sig alias env sg p pos =
| Val_prim _ -> pos
| _ -> pos + 1
in
sigelt :: strengthen_sig alias env rem p nextpos
sigelt :: strengthen_sig ~aliasable env rem p nextpos
| Sig_type(id, {type_kind=Type_abstract}, _) ::
(Sig_type(id', {type_private=Private}, _) :: _ as rem)
when Ident.name id = Ident.name id' ^ "#row" ->
strengthen_sig alias env rem p pos
strengthen_sig ~aliasable env rem p pos
| Sig_type(id, decl, rs) :: rem ->
let newdecl =
match decl.type_manifest, decl.type_private, decl.type_kind with
@ -72,13 +72,13 @@ and strengthen_sig alias env sg p pos =
else
{ decl with type_manifest = manif }
in
Sig_type(id, newdecl, rs) :: strengthen_sig alias env rem p pos
Sig_type(id, newdecl, rs) :: strengthen_sig ~aliasable env rem p pos
| (Sig_typext _ as sigelt) :: rem ->
sigelt :: strengthen_sig alias env rem p (pos+1)
sigelt :: strengthen_sig ~aliasable env rem p (pos+1)
| Sig_module(id, md, rs) :: rem ->
let str = strengthen_decl alias env md (Pdot(p, Ident.name id, pos)) in
let str = strengthen_decl ~aliasable env md (Pdot(p, Ident.name id, pos)) in
Sig_module(id, str, rs)
:: strengthen_sig alias
:: strengthen_sig ~aliasable
(Env.add_module_declaration ~check:false id md env) rem p (pos+1)
(* Need to add the module in case it defines manifest module types *)
| Sig_modtype(id, decl) :: rem ->
@ -90,18 +90,18 @@ and strengthen_sig alias env sg p pos =
decl
in
Sig_modtype(id, newdecl) ::
strengthen_sig alias (Env.add_modtype id decl env) rem p pos
strengthen_sig ~aliasable (Env.add_modtype id decl env) rem p pos
(* Need to add the module type in case it is manifest *)
| (Sig_class _ as sigelt) :: rem ->
sigelt :: strengthen_sig alias env rem p (pos+1)
sigelt :: strengthen_sig ~aliasable env rem p (pos+1)
| (Sig_class_type _ as sigelt) :: rem ->
sigelt :: strengthen_sig alias env rem p pos
sigelt :: strengthen_sig ~aliasable env rem p pos
and strengthen_decl alias env md p =
and strengthen_decl ~aliasable env md p =
match md.md_type with
| Mty_alias _ -> md
| _ when alias -> {md with md_type = Mty_alias(Mta_present, p)}
| mty -> {md with md_type = strengthen alias env mty p}
| _ when aliasable -> {md with md_type = Mty_alias(Mta_present, p)}
| mty -> {md with md_type = strengthen ~aliasable env mty p}
let () = Env.strengthen := strengthen

4
typing/mtype.mli
View File

@ -24,11 +24,11 @@ val scrape: Env.t -> module_type -> module_type
val freshen: module_type -> module_type
(* Return an alpha-equivalent copy of the given module type
where bound identifiers are fresh. *)
val strengthen: bool -> Env.t -> module_type -> Path.t -> module_type
val strengthen: aliasable:bool -> Env.t -> module_type -> Path.t -> module_type
(* Strengthen abstract type components relative to the
given path. *)
val strengthen_decl:
bool -> Env.t -> module_declaration -> Path.t -> module_declaration
aliasable:bool -> Env.t -> module_declaration -> Path.t -> module_declaration
val nondep_supertype: Env.t -> Ident.t -> module_type -> module_type
(* Return the smallest supertype of the given type
in which the given ident does not appear.

15
typing/typemod.ml
View File

@ -222,14 +222,14 @@ let merge_constraint initial_env loc sg constr =
when Ident.name id = s ->
let path, md' = Typetexp.find_module initial_env loc lid'.txt in
let md'' = {md' with md_type = Mtype.remove_aliases env md'.md_type} in
let newmd = Mtype.strengthen_decl false env md'' path in
let newmd = Mtype.strengthen_decl ~aliasable:false env md'' path in
ignore(Includemod.modtypes env newmd.md_type md.md_type);
(Pident id, lid, Twith_module (path, lid')),
Sig_module(id, newmd, rs) :: rem
| (Sig_module(id, md, rs) :: rem, [s], Pwith_modsubst (_, lid'))
when Ident.name id = s ->
let path, md' = Typetexp.find_module initial_env loc lid'.txt in
let newmd = Mtype.strengthen_decl false env md' path in
let newmd = Mtype.strengthen_decl ~aliasable:false env md' path in
ignore(Includemod.modtypes env newmd.md_type md.md_type);
real_id := Some id;
(Pident id, lid, Twith_modsubst (path, lid')),
@ -930,8 +930,8 @@ let check_recmodule_inclusion env bindings =
the number of mutually recursive declarations. *)
let subst_and_strengthen env s id mty =
Mtype.strengthen false env (Subst.modtype s mty)
(Subst.module_path s (Pident id)) in
Mtype.strengthen ~aliasable:false env (Subst.modtype s mty)
(Subst.module_path s (Pident id)) in
let rec check_incl first_time n env s =
if n > 0 then begin
@ -1084,10 +1084,13 @@ let rec type_module ?(alias=false) sttn funct_body anchor env smod =
mod_desc = Tmod_constraint (md, mty, Tmodtype_implicit,
Tcoerce_alias (p1, Tcoerce_none));
mod_type =
if sttn then Mtype.strengthen true env mty p1 else mty }
if sttn then Mtype.strengthen ~aliasable:true env mty p1
else mty }
| mty ->
let mty =
if sttn then Mtype.strengthen true env mty path else mty in
if sttn then Mtype.strengthen ~aliasable:true env mty path
else mty
in
{ md with mod_type = mty }
in rm md
| Pmod_structure sstr ->