diff options
-rw-r--r-- | ocamldoc/odoc_sig.ml | 4 | ||||
-rw-r--r-- | parsing/ast_helper.ml | 1 | ||||
-rw-r--r-- | parsing/ast_helper.mli | 1 | ||||
-rw-r--r-- | parsing/ast_iterator.ml | 2 | ||||
-rw-r--r-- | parsing/ast_mapper.ml | 2 | ||||
-rw-r--r-- | parsing/depend.ml | 2 | ||||
-rw-r--r-- | parsing/parsetree.mli | 2 | ||||
-rw-r--r-- | parsing/pprintast.ml | 12 | ||||
-rw-r--r-- | parsing/printast.ml | 4 | ||||
-rw-r--r-- | typing/printtyped.ml | 4 | ||||
-rw-r--r-- | typing/tast_iterator.ml | 1 | ||||
-rw-r--r-- | typing/tast_mapper.ml | 4 | ||||
-rw-r--r-- | typing/typedtree.ml | 1 | ||||
-rw-r--r-- | typing/typedtree.mli | 1 | ||||
-rw-r--r-- | typing/typemod.ml | 92 | ||||
-rw-r--r-- | typing/typemod.mli | 1 | ||||
-rw-r--r-- | typing/untypeast.ml | 2 |
17 files changed, 122 insertions, 14 deletions
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index 529af8ef1c..29720e8c51 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -513,6 +513,7 @@ module Analyser = end | Parsetree.Psig_modtype {Parsetree.pmtd_name=name} as m -> if is_erased name.txt erased then acc else take_item m + | Parsetree.Psig_modtypesubst _ -> acc | Parsetree.Psig_recmodule mods -> (match List.filter (fun pmd -> @@ -1291,7 +1292,8 @@ module Analyser = let (maybe_more, mods) = f ~first: true 0 pos_start_ele decls in (maybe_more, new_env, mods) - | Parsetree.Psig_modtype {Parsetree.pmtd_name=name; pmtd_type=pmodtype_decl} -> + | Parsetree.Psig_modtype {Parsetree.pmtd_name=name; pmtd_type=pmodtype_decl} + | Parsetree.Psig_modtypesubst {Parsetree.pmtd_name=name; pmtd_type=pmodtype_decl} -> let complete_name = Name.concat current_module_name name.txt in let sig_mtype = try Signature_search.search_module_type table name.txt diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index 2d51dda743..41f5fb9b8d 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -271,6 +271,7 @@ module Sig = struct let mod_subst ?loc a = mk ?loc (Psig_modsubst a) let rec_module ?loc a = mk ?loc (Psig_recmodule a) let modtype ?loc a = mk ?loc (Psig_modtype a) + let modtype_subst ?loc a = mk ?loc (Psig_modtypesubst a) let open_ ?loc a = mk ?loc (Psig_open a) let include_ ?loc a = mk ?loc (Psig_include a) let class_ ?loc a = mk ?loc (Psig_class a) diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index a498ece07d..42ce9e2e98 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -288,6 +288,7 @@ module Sig: val mod_subst: ?loc:loc -> module_substitution -> signature_item val rec_module: ?loc:loc -> module_declaration list -> signature_item val modtype: ?loc:loc -> module_type_declaration -> signature_item + val modtype_subst: ?loc:loc -> module_type_declaration -> signature_item val open_: ?loc:loc -> open_description -> signature_item val include_: ?loc:loc -> include_description -> signature_item val class_: ?loc:loc -> class_description list -> signature_item diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml index 1cdb95310a..d1efda9782 100644 --- a/parsing/ast_iterator.ml +++ b/parsing/ast_iterator.ml @@ -285,7 +285,7 @@ module MT = struct | Psig_modsubst x -> sub.module_substitution sub x | Psig_recmodule l -> List.iter (sub.module_declaration sub) l - | Psig_modtype x -> sub.module_type_declaration sub x + | Psig_modtype x | Psig_modtypesubst x -> sub.module_type_declaration sub x | Psig_open x -> sub.open_description sub x | Psig_include x -> sub.include_description sub x | Psig_class l -> List.iter (sub.class_description sub) l diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 720c16af34..7575f47b0b 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -318,6 +318,8 @@ module MT = struct | Psig_recmodule l -> rec_module ~loc (List.map (sub.module_declaration sub) l) | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) + | Psig_modtypesubst x -> + modtype_subst ~loc (sub.module_type_declaration sub x) | Psig_open x -> open_ ~loc (sub.open_description sub x) | Psig_include x -> include_ ~loc (sub.include_description sub x) | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) diff --git a/parsing/depend.ml b/parsing/depend.ml index f1a155c1ba..d202ad3faf 100644 --- a/parsing/depend.ml +++ b/parsing/depend.ml @@ -382,7 +382,7 @@ and add_sig_item (bv, m) item = let bv' = add bv and m' = add m in List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls; (bv', m') - | Psig_modtype x -> + | Psig_modtype x | Psig_modtypesubst x-> begin match x.pmtd_type with None -> () | Some mty -> add_modtype bv mty diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 8337c289b3..8137de7470 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -769,6 +769,8 @@ and signature_item_desc = | Psig_modtype of module_type_declaration (* module type S = MT module type S *) + | Psig_modtypesubst of module_type_declaration + (* module type S := ... *) | Psig_open of open_description (* open X *) | Psig_include of include_description diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index 29351cc02a..d20ad646d4 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -1159,14 +1159,18 @@ and signature_item ctxt f x : unit = pp f "@[<hov2>include@ %a@]%a" (module_type ctxt) incl.pincl_mod (item_attributes ctxt) incl.pincl_attributes - | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> + | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} + | Psig_modtypesubst {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} as p -> pp f "@[<hov2>module@ type@ %s%a@]%a" s.txt - (fun f md -> match md with - | None -> () - | Some mt -> + (fun f md -> match md, p with + | None, _ -> () + | Some mt, Psig_modtype _ -> pp_print_space f () ; pp f "@ =@ %a" (module_type ctxt) mt + | Some mt, _ -> + pp_print_space f () ; + pp f "@ :=@ %a" (module_type ctxt) mt ) md (item_attributes ctxt) attrs | Psig_class_type (l) -> class_type_declaration_list ctxt f l diff --git a/parsing/printast.ml b/parsing/printast.ml index c196256ecd..9469bf1720 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -730,6 +730,10 @@ and signature_item i ppf x = line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name; attributes i ppf x.pmtd_attributes; modtype_declaration i ppf x.pmtd_type + | Psig_modtypesubst x -> + line i ppf "Psig_modtypesubst %a\n" fmt_string_loc x.pmtd_name; + attributes i ppf x.pmtd_attributes; + modtype_declaration i ppf x.pmtd_type | Psig_open od -> line i ppf "Psig_open %a %a\n" fmt_override_flag od.popen_override fmt_longident_loc od.popen_expr; diff --git a/typing/printtyped.ml b/typing/printtyped.ml index f11dc3bdeb..726cab337e 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -738,6 +738,10 @@ and signature_item i ppf x = line i ppf "Tsig_modtype \"%a\"\n" fmt_ident x.mtd_id; attributes i ppf x.mtd_attributes; modtype_declaration i ppf x.mtd_type + | Tsig_modtypesubst x -> + line i ppf "Tsig_modtypesubst \"%a\"\n" fmt_ident x.mtd_id; + attributes i ppf x.mtd_attributes; + modtype_declaration i ppf x.mtd_type | Tsig_open od -> line i ppf "Tsig_open %a %a\n" fmt_override_flag od.open_override diff --git a/typing/tast_iterator.ml b/typing/tast_iterator.ml index 90ed15be1c..eca7632f7d 100644 --- a/typing/tast_iterator.ml +++ b/typing/tast_iterator.ml @@ -284,6 +284,7 @@ let signature_item sub {sig_desc; sig_env; _} = | Tsig_modsubst x -> sub.module_substitution sub x | Tsig_recmodule list -> List.iter (sub.module_declaration sub) list | Tsig_modtype x -> sub.module_type_declaration sub x + | Tsig_modtypesubst x -> sub.module_type_declaration sub x | Tsig_include incl -> include_infos (sub.module_type sub) incl | Tsig_class list -> List.iter (sub.class_description sub) list | Tsig_class_type list -> List.iter (sub.class_type_declaration sub) list diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml index 555e09d7d3..d8241a7fe6 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -416,7 +416,9 @@ let signature_item sub x = Tsig_recmodule (List.map (sub.module_declaration sub) list) | Tsig_modtype x -> Tsig_modtype (sub.module_type_declaration sub x) - | Tsig_include incl -> + | Tsig_modtypesubst x -> + Tsig_modtypesubst (sub.module_type_declaration sub x) + | Tsig_include incl -> Tsig_include (include_infos (sub.module_type sub) incl) | Tsig_class list -> Tsig_class (List.map (sub.class_description sub) list) diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 63ead794cb..46bc3297f0 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -355,6 +355,7 @@ and signature_item_desc = | Tsig_modsubst of module_substitution | Tsig_recmodule of module_declaration list | Tsig_modtype of module_type_declaration + | Tsig_modtypesubst of module_type_declaration | Tsig_open of open_description | Tsig_include of include_description | Tsig_class of class_description list diff --git a/typing/typedtree.mli b/typing/typedtree.mli index dcd69610e7..a4363d518d 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -494,6 +494,7 @@ and signature_item_desc = | Tsig_modsubst of module_substitution | Tsig_recmodule of module_declaration list | Tsig_modtype of module_type_declaration + | Tsig_modtypesubst of module_type_declaration | Tsig_open of open_description | Tsig_include of include_description | Tsig_class of class_description list diff --git a/typing/typemod.ml b/typing/typemod.ml index a1d46d1a0d..2453c98ab3 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -102,6 +102,7 @@ type error = | Badly_formed_signature of string * Typedecl.error | Cannot_hide_id of hiding_error | Invalid_type_subst_rhs + | Unpackable_local_modtype_subst of Path.t exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -377,6 +378,20 @@ let check_usage_of_path_of_substituted_item paths env signature ~loc ~lid = iterator.Btype.it_signature iterator signature; Btype.unmark_iterators.Btype.it_signature Btype.unmark_iterators signature +(* When doing a module type destructive substitution [with module type T = RHS] + where RHS is not a module type path, we need to check that the module type + T was not used as a path for a packed module +*) +let check_usage_of_module_types ~error ~paths ~loc env super = + let it_do_type_expr it ty = match ty.desc with + | Tpackage (p, _, _) -> + begin match List.find_opt (Path.same p) paths with + | Some p -> raise (Error(loc,Lazy.force !env,error p)) + | _ -> super.Btype.it_do_type_expr it ty + end + | _ -> super.Btype.it_do_type_expr it ty in + { super with Btype.it_do_type_expr } + (* After substitution one also needs to re-check the well-foundedness of type declarations in recursive modules *) let rec extract_next_modules = function @@ -854,6 +869,13 @@ and approx_sig env ssg = Env.enter_modtype ~scope d.pmtd_name.txt info env in Sig_modtype(id, info, Exported) :: approx_sig newenv srem + | Psig_modtypesubst d -> + let info = approx_modtype_info env d in + let scope = Ctype.create_scope () in + let (_id, newenv) = + Env.enter_modtype ~scope d.pmtd_name.txt info env + in + approx_sig newenv srem | Psig_open sod -> let _, env = type_open_descr env sod in approx_sig env srem @@ -903,6 +925,7 @@ module Signature_names : sig | `From_open | `Shadowable of Ident.t * Location.t | `Substituted_away of Subst.t + | `Unpackable_modtype_substituted_away of Ident.t * Subst.t ] val create : unit -> t @@ -929,6 +952,7 @@ end = struct type info = [ | `From_open | `Substituted_away of Subst.t + | `Unpackable_modtype_substituted_away of Ident.t * Subst.t | bound_info ] @@ -939,6 +963,7 @@ end = struct type to_be_removed = { mutable subst: Subst.t; mutable hide: (Sig_component_kind.t * Location.t * hide_reason) Ident.Map.t; + mutable unpackable_modtypes: Ident.Set.t; } type names_infos = (string, bound_info) Hashtbl.t @@ -973,6 +998,7 @@ end = struct to_be_removed = { subst = Subst.identity; hide = Ident.Map.empty; + unpackable_modtypes = Ident.Set.empty; }; } @@ -991,7 +1017,11 @@ end = struct let to_be_removed = t.to_be_removed in match info with | `Substituted_away s -> - to_be_removed.subst <- Subst.compose s to_be_removed.subst + to_be_removed.subst <- Subst.compose s to_be_removed.subst; + | `Unpackable_modtype_substituted_away (id,s) -> + to_be_removed.subst <- Subst.compose s to_be_removed.subst; + to_be_removed.unpackable_modtypes <- + Ident.Set.add id to_be_removed.unpackable_modtypes | `From_open -> to_be_removed.hide <- Ident.Map.add id (cl, loc, From_open) to_be_removed.hide @@ -1048,6 +1078,30 @@ end = struct in check component_kind names loc id info + (* + Before applying local module type substitutions where the + right-hand side is not a path, we need to check that those module types + where never used to pack modules. For instance + {[ + module type T := sig end + val x: (module T) + ]} + should raise an error. + *) + let check_unpackable_modtypes ~loc ~env to_remove component = + if not (Ident.Set.is_empty to_remove.unpackable_modtypes) then + let iterator = + let error p = Unpackable_local_modtype_subst p in + let paths = + List.map (fun id -> Pident id) + (Ident.Set.elements to_remove.unpackable_modtypes) + in + check_usage_of_module_types ~loc ~error ~paths + (ref (lazy env)) Btype.type_iterators + in + iterator.Btype.it_signature_item iterator component; + Btype.(unmark_iterators.it_signature_item unmark_iterators) component + (* We usually require name uniqueness of signature components (e.g. types, modules, etc), however in some situation reusing the name is allowed: if the component is a value or an extension, or if the name is introduced by @@ -1088,7 +1142,10 @@ end = struct if to_remove.subst == Subst.identity then component else - Subst.signature_item Keep to_remove.subst component + begin + check_unpackable_modtypes ~loc:user_loc ~env to_remove component; + Subst.signature_item Keep to_remove.subst component + end in let component = match ids_to_remove with @@ -1432,6 +1489,22 @@ and transl_signature env sg = mksig (Tsig_modtype mtd) env loc :: trem, sg :: rem, final_env + | Psig_modtypesubst pmtd -> + let info id tmty = + let mty = match tmty with + | Some tmty -> tmty.mty_type + | None -> assert false (* unparsable *) + in + let subst = Subst.add_modtype id mty Subst.identity in + match mty with + | Mty_ident _ -> `Substituted_away subst + | _ -> `Unpackable_modtype_substituted_away (id,subst) + in + let newenv, mtd, _sg = transl_modtype_decl ~info names env pmtd in + let (trem, rem, final_env) = transl_sig newenv srem in + mksig (Tsig_modtypesubst mtd) env loc :: trem, + rem, + final_env | Psig_open sod -> let (od, newenv) = type_open_descr env sod in let (trem, rem, final_env) = transl_sig newenv srem in @@ -1537,11 +1610,11 @@ and transl_signature env sg = sg ) -and transl_modtype_decl names env pmtd = +and transl_modtype_decl ?info names env pmtd = Builtin_attributes.warning_scope pmtd.pmtd_attributes - (fun () -> transl_modtype_decl_aux names env pmtd) + (fun () -> transl_modtype_decl_aux ?info names env pmtd) -and transl_modtype_decl_aux names env +and transl_modtype_decl_aux ?info names env {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} = let tmty = Option.map (transl_modtype (Env.in_signature true env)) pmtd_type @@ -1556,7 +1629,8 @@ and transl_modtype_decl_aux names env in let scope = Ctype.create_scope () in let (id, newenv) = Env.enter_modtype ~scope pmtd_name.txt decl env in - Signature_names.check_modtype names pmtd_loc id; + let info = Option.map (fun info -> info id tmty) info in + Signature_names.check_modtype ?info names pmtd_loc id; let mtd = { mtd_id=id; @@ -2962,6 +3036,12 @@ let report_error ppf = function Ident.print opened_item_id | Invalid_type_subst_rhs -> fprintf ppf "Only type synonyms are allowed on the right of :=" + | Unpackable_local_modtype_subst p -> + fprintf ppf + "The module type@ %s@ is not a valid type for a packed module:@ \ + it is defined as a local substitution for a non-path module type." + (Path.name p) + let report_error env ppf err = Printtyp.wrap_printing_env ~error:true env (fun () -> report_error ppf err) diff --git a/typing/typemod.mli b/typing/typemod.mli index 87ebd8f1fe..6f79637d87 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -131,6 +131,7 @@ type error = | Badly_formed_signature of string * Typedecl.error | Cannot_hide_id of hiding_error | Invalid_type_subst_rhs + | Unpackable_local_modtype_subst of Path.t exception Error of Location.t * Env.t * error exception Error_forward of Location.error diff --git a/typing/untypeast.ml b/typing/untypeast.ml index bff1e29a06..3cc2b34023 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -559,6 +559,8 @@ let signature_item sub item = Psig_recmodule (List.map (sub.module_declaration sub) list) | Tsig_modtype mtd -> Psig_modtype (sub.module_type_declaration sub mtd) + | Tsig_modtypesubst mtd -> + Psig_modtypesubst (sub.module_type_declaration sub mtd) | Tsig_open od -> Psig_open (sub.open_description sub od) | Tsig_include incl -> |