diff options
| -rw-r--r-- | ocamldoc/odoc_sig.ml | 7 | ||||
| -rw-r--r-- | parsing/ast_iterator.ml | 4 | ||||
| -rw-r--r-- | parsing/ast_mapper.ml | 4 | ||||
| -rw-r--r-- | parsing/depend.ml | 2 | ||||
| -rw-r--r-- | parsing/parsetree.mli | 4 | ||||
| -rw-r--r-- | parsing/pprintast.ml | 41 | ||||
| -rw-r--r-- | parsing/printast.ml | 8 | ||||
| -rw-r--r-- | typing/includemod.ml | 3 | ||||
| -rw-r--r-- | typing/includemod.mli | 3 | ||||
| -rw-r--r-- | typing/printtyped.ml | 4 | ||||
| -rw-r--r-- | typing/tast_iterator.ml | 3 | ||||
| -rw-r--r-- | typing/tast_mapper.ml | 4 | ||||
| -rw-r--r-- | typing/typedtree.ml | 3 | ||||
| -rw-r--r-- | typing/typedtree.mli | 2 | ||||
| -rw-r--r-- | typing/typemod.ml | 56 | ||||
| -rw-r--r-- | typing/untypeast.ml | 4 |
16 files changed, 122 insertions, 30 deletions
diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index d52dee8930..529af8ef1c 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -451,11 +451,14 @@ module Analyser = let erased_names_of_constraints constraints acc = List.fold_right (fun constraint_ acc -> match constraint_ with - | Parsetree.Pwith_type _ | Parsetree.Pwith_module _ -> acc + | Parsetree.Pwith_type _ | Parsetree.Pwith_module _ | Parsetree.Pwith_module_type _ -> acc | Parsetree.Pwith_typesubst (s, typedecl) -> constraint_for_subitem acc s (fun s -> Parsetree.Pwith_typesubst (s, typedecl)) | Parsetree.Pwith_modsubst (s, modpath) -> - constraint_for_subitem acc s (fun s -> Parsetree.Pwith_modsubst (s, modpath))) + constraint_for_subitem acc s (fun s -> Parsetree.Pwith_modsubst (s, modpath)) + | Parsetree.Pwith_module_typesubst (s, modpath) -> + constraint_for_subitem acc s + (fun s -> Parsetree.Pwith_module_typesubst (s, modpath))) constraints acc let is_erased ident map = diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml index 10d575123b..1cdb95310a 100644 --- a/parsing/ast_iterator.ml +++ b/parsing/ast_iterator.ml @@ -263,10 +263,14 @@ module MT = struct iter_loc sub lid; sub.type_declaration sub d | Pwith_module (lid, lid2) -> iter_loc sub lid; iter_loc sub lid2 + | Pwith_module_type (lid, mty) -> + iter_loc sub lid; iter_loc sub mty | Pwith_typesubst (lid, d) -> iter_loc sub lid; sub.type_declaration sub d | Pwith_modsubst (s, lid) -> iter_loc sub s; iter_loc sub lid + | Pwith_module_typesubst (lid, mty) -> + iter_loc sub lid; iter_loc sub mty let iter_signature_item sub {psig_desc = desc; psig_loc = loc} = sub.location sub loc; diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index d9a77c952f..720c16af34 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -293,10 +293,14 @@ module MT = struct Pwith_type (map_loc sub lid, sub.type_declaration sub d) | Pwith_module (lid, lid2) -> Pwith_module (map_loc sub lid, map_loc sub lid2) + | Pwith_module_type (lid, mty) -> + Pwith_module_type (map_loc sub lid, map_loc sub mty) | Pwith_typesubst (lid, d) -> Pwith_typesubst (map_loc sub lid, sub.type_declaration sub d) | Pwith_modsubst (s, lid) -> Pwith_modsubst (map_loc sub s, map_loc sub lid) + | Pwith_module_typesubst (lid, mty) -> + Pwith_module_typesubst (map_loc sub lid, map_loc sub mty) let map_signature_item sub {psig_desc = desc; psig_loc = loc} = let open Sig in diff --git a/parsing/depend.ml b/parsing/depend.ml index d72bf63b35..f1a155c1ba 100644 --- a/parsing/depend.ml +++ b/parsing/depend.ml @@ -311,8 +311,10 @@ and add_modtype bv mty = (function | Pwith_type (_, td) -> add_type_declaration bv td | Pwith_module (_, lid) -> add_module_path bv lid + | Pwith_module_type (_, l) -> add bv l | Pwith_typesubst (_, td) -> add_type_declaration bv td | Pwith_modsubst (_, lid) -> add_module_path bv lid + | Pwith_module_typesubst (_, l) -> add bv l ) cstrl | Pmty_typeof m -> add_module_expr bv m diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 952920287a..8337c289b3 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -852,6 +852,10 @@ and with_constraint = the name of the type_declaration. *) | Pwith_module of Longident.t loc * Longident.t loc (* with module X.Y = Z *) + | Pwith_module_type of Longident.t loc * Longident.t loc + (* with module type X.Y = Z *) + | Pwith_module_typesubst of Longident.t loc * Longident.t loc + (* with module type X.Y := Z *) | Pwith_typesubst of Longident.t loc * type_declaration (* with type X.t := ..., same format as [Pwith_type] *) | Pwith_modsubst of Longident.t loc * Longident.t loc diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index aefd74c32c..29351cc02a 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -1059,26 +1059,33 @@ and module_type ctxt f x = end | Pmty_with (mt, []) -> module_type ctxt f mt | Pmty_with (mt, l) -> - let with_constraint f = function - | Pwith_type (li, ({ptype_params= ls ;_} as td)) -> - let ls = List.map fst ls in - pp f "type@ %a %a =@ %a" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") - ls longident_loc li (type_declaration ctxt) td - | Pwith_module (li, li2) -> - pp f "module %a =@ %a" longident_loc li longident_loc li2; - | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) -> - let ls = List.map fst ls in - pp f "type@ %a %a :=@ %a" - (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") - ls longident_loc li - (type_declaration ctxt) td - | Pwith_modsubst (li, li2) -> - pp f "module %a :=@ %a" longident_loc li longident_loc li2 in pp f "@[<hov2>%a@ with@ %a@]" - (module_type1 ctxt) mt (list with_constraint ~sep:"@ and@ ") l + (module_type1 ctxt) mt + (list (with_constraint ctxt) ~sep:"@ and@ ") l | _ -> module_type1 ctxt f x +and with_constraint ctxt f = function + | Pwith_type (li, ({ptype_params= ls ;_} as td)) -> + let ls = List.map fst ls in + pp f "type@ %a %a =@ %a" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") + ls longident_loc li (type_declaration ctxt) td + | Pwith_module (li, li2) -> + pp f "module %a =@ %a" longident_loc li longident_loc li2; + | Pwith_module_type (li, li2) -> + pp f "module type %a =@ %a" longident_loc li longident_loc li2 + | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) -> + let ls = List.map fst ls in + pp f "type@ %a %a :=@ %a" + (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") + ls longident_loc li + (type_declaration ctxt) td + | Pwith_modsubst (li, li2) -> + pp f "module %a :=@ %a" longident_loc li longident_loc li2 + | Pwith_module_typesubst (li, li2) -> + pp f "module type %a :=@ %a" longident_loc li longident_loc li2 + + and module_type1 ctxt f x = if x.pmty_attributes <> [] then module_type ctxt f x else match x.pmty_desc with diff --git a/parsing/printast.ml b/parsing/printast.ml index 031cd7b57c..c196256ecd 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -771,6 +771,14 @@ and with_constraint i ppf x = line i ppf "Pwith_modsubst %a = %a\n" fmt_longident_loc lid1 fmt_longident_loc lid2; + | Pwith_module_type (lid1, lid2) -> + line i ppf "Pwith_module_type %a = %a\n" + fmt_longident_loc lid1 + fmt_longident_loc lid2 + | Pwith_module_typesubst (lid1, lid2) -> + line i ppf "Pwith_module_typesubst %a = %a\n" + fmt_longident_loc lid1 + fmt_longident_loc lid2 and module_expr i ppf x = line i ppf "module_expr %a\n" fmt_location x.pmod_loc; diff --git a/typing/includemod.ml b/typing/includemod.ml index 87a5b8ff2e..d5d6e3da5f 100644 --- a/typing/includemod.ml +++ b/typing/includemod.ml @@ -568,6 +568,9 @@ let check_modtype_inclusion ~loc env mty1 path1 mty2 = (strengthened_modtypes ~loc ~aliasable env ~mark:Mark_both [] Subst.identity mty1 path1 mty2) +let check_modtype_equiv ~loc env mty1 mty2 = + check_modtype_equiv ~loc env ~mark:Mark_both [] mty1 mty2 + let () = Env.check_functor_application := (fun ~errors ~loc env mty1 path1 mty2 path2 -> diff --git a/typing/includemod.mli b/typing/includemod.mli index 855b7863c1..621d8d1861 100644 --- a/typing/includemod.mli +++ b/typing/includemod.mli @@ -46,6 +46,9 @@ val check_modtype_inclusion : functor application F(M) is well typed, where mty2 is the type of the argument of F and path1/mty1 is the path/unstrenghened type of M. *) +val check_modtype_equiv: + loc:Location.t -> Env.t -> module_type -> module_type -> unit + val signatures: Env.t -> mark:mark -> signature -> signature -> module_coercion diff --git a/typing/printtyped.ml b/typing/printtyped.ml index c9ae218a3f..f11dc3bdeb 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -780,6 +780,10 @@ and with_constraint i ppf x = type_declaration (i+1) ppf td; | Twith_module (li,_) -> line i ppf "Twith_module %a\n" fmt_path li; | Twith_modsubst (li,_) -> line i ppf "Twith_modsubst %a\n" fmt_path li; + | Twith_module_type (p,_) -> + line i ppf "Twith_module_type %a\n" fmt_path p + | Twith_module_typesubst (p,_) -> + line i ppf "Twith_module_typesubst %a\n" fmt_path p and module_expr i ppf x = line i ppf "module_expr %a\n" fmt_location x.mod_loc; diff --git a/typing/tast_iterator.ml b/typing/tast_iterator.ml index 640ad6b1e0..90ed15be1c 100644 --- a/typing/tast_iterator.ml +++ b/typing/tast_iterator.ml @@ -316,6 +316,9 @@ let with_constraint sub = function | Twith_typesubst decl -> sub.type_declaration sub decl | Twith_module _ -> () | Twith_modsubst _ -> () + | Twith_module_type _ -> () + | Twith_module_typesubst _ -> () + let open_description sub {open_env; _} = sub.env sub open_env diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml index 2c1d13ae77..555e09d7d3 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -458,7 +458,9 @@ let with_constraint sub = function | Twith_type decl -> Twith_type (sub.type_declaration sub decl) | Twith_typesubst decl -> Twith_typesubst (sub.type_declaration sub decl) | Twith_module _ - | Twith_modsubst _ as d -> d + | Twith_modsubst _ + | Twith_module_type _ + | Twith_module_typesubst _ as d -> d let open_description sub od = {od with open_env = sub.env sub od.open_env} diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 4364e91c3c..63ead794cb 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -419,8 +419,11 @@ and include_declaration = module_expr include_infos and with_constraint = Twith_type of type_declaration | Twith_module of Path.t * Longident.t loc + | Twith_module_type of Path.t * Longident.t loc | Twith_typesubst of type_declaration | Twith_modsubst of Path.t * Longident.t loc + | Twith_module_typesubst of Path.t * Longident.t loc + and core_type = (* mutable because of [Typeclass.declare_method] *) diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 1f23a5f7b3..dcd69610e7 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -559,8 +559,10 @@ and include_declaration = module_expr include_infos and with_constraint = Twith_type of type_declaration | Twith_module of Path.t * Longident.t loc + | Twith_module_type of Path.t * Longident.t loc | Twith_typesubst of type_declaration | Twith_modsubst of Path.t * Longident.t loc + | Twith_module_typesubst of Path.t * Longident.t loc and core_type = { mutable ctyp_desc : core_type_desc; diff --git a/typing/typemod.ml b/typing/typemod.ml index f3e35eef52..dacf2c4462 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -448,16 +448,21 @@ let params_are_constrained = loop ;; +let transl_modtype_longident loc env lid = + let (path, _info) = Env.lookup_modtype ~loc lid env in + path + let merge_constraint initial_env remove_aliases loc sg constr = let lid = match constr with - | Pwith_type (lid, _) | Pwith_module (lid, _) - | Pwith_typesubst (lid, _) | Pwith_modsubst (lid, _) -> lid + | Pwith_type (lid, _) | Pwith_module (lid, _) | Pwith_module_type (lid,_) + | Pwith_typesubst (lid, _) | Pwith_modsubst (lid, _) + | Pwith_module_typesubst (lid, _) -> lid in let destructive_substitution = match constr with - | Pwith_type _ | Pwith_module _ -> false - | Pwith_typesubst _ | Pwith_modsubst _ -> true + | Pwith_type _ | Pwith_module _ | Pwith_module_type _ -> false + | Pwith_typesubst _ | Pwith_modsubst _ | Pwith_module_typesubst _ -> true in let real_ids = ref [] in let rec merge sig_env sg namelist row_id = @@ -530,6 +535,33 @@ let merge_constraint initial_env remove_aliases loc sg constr = (Pident id, lid, Twith_typesubst tdecl), update_rec_next rs rem end + | (Sig_modtype(id, mtd, priv) :: rem, [s], + (Pwith_module_type (_, lmty) | Pwith_module_typesubst (_,lmty)) + ) + when Ident.name id = s -> + let path = transl_modtype_longident lmty.loc initial_env lmty.txt in + let () = match mtd.mtd_type with + | None -> () + | Some previous_mty -> + Includemod.check_modtype_equiv ~loc sig_env + previous_mty (Mty_ident path) + in + if not destructive_substitution then + let mtd': modtype_declaration = + { + mtd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + mtd_type = Some (Mty_ident path); + mtd_attributes = []; + mtd_loc = loc; + } + in + (Pident id, lid, Twith_module_type (path,lmty)), + Sig_modtype(id, mtd', priv) :: rem + else begin + real_ids := [Pident id]; + (Pident id, lid, Twith_module_typesubst (path,lmty)), + rem + end | (Sig_type(id, _, _, _) :: rem, [s], (Pwith_type _ | Pwith_typesubst _)) when Ident.name id = s ^ "#row" -> merge sig_env rem namelist (Some id) @@ -635,6 +667,12 @@ let merge_constraint initial_env remove_aliases loc sg constr = in (* See explanation in the [Twith_typesubst] case above. *) Subst.signature Make_local sub sg + | (_, _, Twith_module_typesubst (p,_)) -> + let add s = function + | Pident id -> Subst.add_modtype id (Mty_ident p) s + | _ -> s in + let sub = List.fold_left add Subst.identity !real_ids in + Subst.signature Make_local sub sg | _ -> sg in @@ -722,8 +760,10 @@ let rec approx_modtype env smty = List.iter (fun sdecl -> match sdecl with - | Pwith_type _ -> () - | Pwith_typesubst _ -> () + | Pwith_type _ + | Pwith_typesubst _ + | Pwith_module_type _ + | Pwith_module_typesubst _ -> () | Pwith_module (_, lid') -> (* Lookup the module to make sure that it is not recursive. (GPR#1626) *) @@ -1103,10 +1143,6 @@ let has_remove_aliases_attribute attr = (* Check and translate a module type expression *) -let transl_modtype_longident loc env lid = - let (path, _info) = Env.lookup_modtype ~loc lid env in - path - let transl_module_alias loc env lid = Env.lookup_module_path ~load:false ~loc lid env diff --git a/typing/untypeast.ml b/typing/untypeast.ml index 657ce517df..bff1e29a06 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -636,10 +636,14 @@ let with_constraint sub (_path, lid, cstr) = Pwith_type (map_loc sub lid, sub.type_declaration sub decl) | Twith_module (_path, lid2) -> Pwith_module (map_loc sub lid, map_loc sub lid2) + | Twith_module_type (_path,lid2) -> + Pwith_module_type (map_loc sub lid, map_loc sub lid2) | Twith_typesubst decl -> Pwith_typesubst (map_loc sub lid, sub.type_declaration sub decl) | Twith_modsubst (_path, lid2) -> Pwith_modsubst (map_loc sub lid, map_loc sub lid2) + | Twith_module_typesubst (_path, lid2) -> + Pwith_module_typesubst (map_loc sub lid, map_loc sub lid2) let module_expr (sub : mapper) mexpr = let loc = sub.location sub mexpr.mod_loc in |