diff options
Diffstat (limited to 'typing/mtype.ml')
| -rw-r--r-- | typing/mtype.ml | 158 |
1 files changed, 154 insertions, 4 deletions
diff --git a/typing/mtype.ml b/typing/mtype.ml index 53850d962a..a5e0d811dd 100644 --- a/typing/mtype.ml +++ b/typing/mtype.ml @@ -34,7 +34,8 @@ let rec strengthen env mty p = match scrape env mty with Mty_signature sg -> Mty_signature(strengthen_sig env sg p) - | Mty_functor(param, arg, res) when !Clflags.applicative_functors -> + | Mty_functor(param, arg, res) + when !Clflags.applicative_functors && Ident.name param <> "*" -> Mty_functor(param, arg, strengthen env res (Papply(p, Pident param))) | mty -> mty @@ -85,6 +86,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 @@ -100,13 +102,19 @@ let nondep_supertype env mid mty = if Path.isfree mid p then nondep_mty env va (Env.find_modtype_expansion p env) else mty + | Mty_alias p -> + if Path.isfree mid p then + nondep_mty env va (Env.find_module p env).md_type + else mty | Mty_signature sg -> Mty_signature(nondep_sig env va sg) | Mty_functor(param, arg, res) -> let var_inv = match va with Co -> Contra | Contra -> Co | Strict -> Strict in - Mty_functor(param, nondep_mty env var_inv arg, - nondep_mty (Env.add_module param arg env) va res) + Mty_functor(param, Misc.may_map (nondep_mty env var_inv) arg, + nondep_mty + (Env.add_module ~arg:true param + (Btype.default_mty arg) env) va res) and nondep_sig env va = function [] -> [] @@ -135,7 +143,8 @@ let nondep_supertype env mid mty = Sig_modtype(id, nondep_modtype_decl env d) :: rem' with Not_found -> match va with - Co -> Sig_modtype(id, {mtd_type=None; mtd_attributes=[]}) :: rem' + Co -> Sig_modtype(id, {mtd_type=None; mtd_loc=Location.none; + mtd_attributes=[]}) :: rem' | _ -> raise Not_found end | Sig_class(id, d, rs) -> @@ -186,6 +195,7 @@ and enrich_item env p = function let rec type_paths env p mty = match scrape env mty with Mty_ident p -> [] + | Mty_alias p -> [] | Mty_signature sg -> type_paths_sig env p 0 sg | Mty_functor(param, arg, res) -> [] @@ -212,6 +222,7 @@ let rec no_code_needed env mty = Mty_ident p -> false | Mty_signature sg -> no_code_needed_sig env sg | Mty_functor(_, _, _) -> false + | Mty_alias p -> true and no_code_needed_sig env sg = match sg with @@ -228,3 +239,142 @@ and no_code_needed_sig env sg = no_code_needed_sig env rem | (Sig_exception _ | Sig_class _) :: rem -> false + + +(* Check whether a module type may return types *) + +let rec contains_type env = function + Mty_ident path -> + (try Misc.may (contains_type env) (Env.find_modtype path env).mtd_type + with Not_found -> raise Exit) + | Mty_signature sg -> + contains_type_sig env sg + | Mty_functor (_, _, body) -> + contains_type env body + | Mty_alias _ -> + () + +and contains_type_sig env = List.iter (contains_type_item env) + +and contains_type_item env = function + Sig_type (_,({type_manifest = None} | + {type_kind = Type_abstract; type_private = Private}),_) + | Sig_modtype _ -> + raise Exit + | Sig_module (_, {md_type = mty}, _) -> + contains_type env mty + | Sig_value _ + | Sig_type _ + | Sig_exception _ + | Sig_class _ + | Sig_class_type _ -> + () + +let contains_type env mty = + try contains_type env mty; false with Exit -> true + + +(* Remove module aliases from a signature *) + +module P = struct + type t = Path.t + let compare p1 p2 = + if Path.same p1 p2 then 0 else compare p1 p2 +end +module PathSet = Set.Make (P) +module PathMap = Map.Make (P) +module IdentSet = Set.Make (struct type t = Ident.t let compare = compare end) + +let rec get_prefixes = function + Pident _ -> PathSet.empty + | Pdot (p, _, _) + | Papply (p, _) -> PathSet.add p (get_prefixes p) + +let rec get_arg_paths = function + Pident _ -> PathSet.empty + | Pdot (p, _, _) -> get_arg_paths p + | Papply (p1, p2) -> + PathSet.add p2 + (PathSet.union (get_prefixes p2) + (PathSet.union (get_arg_paths p1) (get_arg_paths p2))) + +let rec rollback_path subst p = + try Pident (PathMap.find p subst) + with Not_found -> + match p with + Pident _ | Papply _ -> p + | Pdot (p1, s, n) -> + let p1' = rollback_path subst p1 in + if Path.same p1 p1' then p else rollback_path subst (Pdot (p1', s, n)) + +let rec collect_ids subst bindings p = + begin match rollback_path subst p with + Pident id -> + let ids = + try collect_ids subst bindings (Ident.find_same id bindings) + with Not_found -> IdentSet.empty + in + IdentSet.add id ids + | _ -> IdentSet.empty + end + +let collect_arg_paths mty = + let open Btype in + let paths = ref PathSet.empty + and subst = ref PathMap.empty + and bindings = ref Ident.empty in + (* let rt = Ident.create "Root" in + and prefix = ref (Path.Pident rt) in *) + let it_path p = paths := PathSet.union (get_arg_paths p) !paths + and it_signature_item it si = + type_iterators.it_signature_item it si; + match si with + Sig_module (id, {md_type=Mty_alias p}, _) -> + bindings := Ident.add id p !bindings + | Sig_module (id, {md_type=Mty_signature sg}, _) -> + List.iter + (function Sig_module (id', _, _) -> + subst := + PathMap.add (Pdot (Pident id, Ident.name id', -1)) id' !subst + | _ -> ()) + sg + | _ -> () + in + let it = {type_iterators with it_path; it_signature_item} in + it.it_module_type it mty; + PathSet.fold (fun p -> IdentSet.union (collect_ids !subst !bindings p)) + !paths IdentSet.empty + +let rec remove_aliases env excl mty = + match mty with + Mty_signature sg -> + Mty_signature (remove_aliases_sig env excl sg) + | Mty_alias _ -> + remove_aliases env excl (Env.scrape_alias env mty) + | mty -> + mty + +and remove_aliases_sig env excl sg = + match sg with + [] -> [] + | Sig_module(id, md, rs) :: rem -> + let mty = + match md.md_type with + Mty_alias _ when IdentSet.mem id excl -> + md.md_type + | mty -> + remove_aliases env excl mty + in + Sig_module(id, {md with md_type = mty} , rs) :: + remove_aliases_sig (Env.add_module id mty env) excl rem + | Sig_modtype(id, mtd) :: rem -> + Sig_modtype(id, mtd) :: + remove_aliases_sig (Env.add_modtype id mtd env) excl rem + | it :: 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 |