diff --git a/Changes b/Changes index 13d60f339a46..4e554713eb8b 100644 --- a/Changes +++ b/Changes @@ -13,6 +13,9 @@ Working version (Nicolás Ojeda Bär, review by Gabriel Radanne, Damien Doligez, Gabriel Scherer) +- GPR#1506: Extending `open` to accept arbitrary module expression + (Runhang Li, review by Alain Frisch, Florian Angeletti, Jeremy Yallop) + - GPR#1546: Allow empty variants (Runhang Li, review by Gabriel Radanne and Jacques Garrigue) diff --git a/bytecomp/translclass.ml b/bytecomp/translclass.ml index 95c56da7a89e..a10c6d4520b4 100644 --- a/bytecomp/translclass.ml +++ b/bytecomp/translclass.ml @@ -195,7 +195,7 @@ let rec build_object_init cl_table obj params inh_init obj_init cl = build_object_init cl_table obj (vals @ params) inh_init obj_init cl in (inh_init, Translcore.transl_let rec_flag defs obj_init) - | Tcl_open (_, _, _, _, cl) + | Tcl_open (_, cl) | Tcl_constraint (cl, _, _, _, _) -> build_object_init cl_table obj params inh_init obj_init cl @@ -387,7 +387,7 @@ let rec build_class_init cla cstr super inh_init cl_init msubst top cl = Lsequence(mkappl (oo_prim "narrow", narrow_args), cl_init)) end - | Tcl_open (_, _, _, _, cl) -> + | Tcl_open (_, cl) -> build_class_init cla cstr super inh_init cl_init msubst top cl let rec build_class_lets cl = @@ -407,7 +407,7 @@ let rec get_class_meths cl = | Tcl_fun (_, _, _, cl, _) | Tcl_let (_, _, _, cl) | Tcl_apply (cl, _) - | Tcl_open (_, _, _, _, cl) + | Tcl_open (_, cl) | Tcl_constraint (cl, _, _, _, _) -> get_class_meths cl (* @@ -453,7 +453,7 @@ let rec transl_class_rebind obj_init cl vf = in check_constraint cl.cl_type; (path, obj_init) - | Tcl_open (_, _, _, _, cl) -> + | Tcl_open (_, cl) -> transl_class_rebind obj_init cl vf let rec transl_class_rebind_0 self obj_init cl vf = diff --git a/parsing/ast_helper.ml b/parsing/ast_helper.ml index 2c28493395f1..71914c8707ed 100644 --- a/parsing/ast_helper.ml +++ b/parsing/ast_helper.ml @@ -414,9 +414,9 @@ end module Opn = struct let mk ?(loc = !default_loc) ?(attrs = []) ?(docs = empty_docs) - ?(override = Fresh) lid = + ?(override = Fresh) expr = { - popen_lid = lid; + popen_expr = expr; popen_override = override; popen_loc = loc; popen_attributes = add_docs_attrs docs attrs; diff --git a/parsing/ast_helper.mli b/parsing/ast_helper.mli index efc1dfcad5cd..d9978be15fe9 100644 --- a/parsing/ast_helper.mli +++ b/parsing/ast_helper.mli @@ -168,8 +168,8 @@ module Exp: val object_: ?loc:loc -> ?attrs:attrs -> class_structure -> expression val newtype: ?loc:loc -> ?attrs:attrs -> str -> expression -> expression val pack: ?loc:loc -> ?attrs:attrs -> module_expr -> expression - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression - -> expression + val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> module_expr + -> expression -> expression val extension: ?loc:loc -> ?attrs:attrs -> extension -> expression val unreachable: ?loc:loc -> ?attrs:attrs -> unit -> expression @@ -322,7 +322,7 @@ module Mb: module Opn: sig val mk: ?loc: loc -> ?attrs:attrs -> ?docs:docs -> - ?override:override_flag -> lid -> open_description + ?override:override_flag -> module_expr -> open_description end (** Includes *) @@ -352,7 +352,7 @@ module Cty: val arrow: ?loc:loc -> ?attrs:attrs -> arg_label -> core_type -> class_type -> class_type val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_type - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_type + val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> module_expr -> class_type -> class_type end @@ -392,7 +392,7 @@ module Cl: val constraint_: ?loc:loc -> ?attrs:attrs -> class_expr -> class_type -> class_expr val extension: ?loc:loc -> ?attrs:attrs -> extension -> class_expr - val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> class_expr + val open_: ?loc:loc -> ?attrs:attrs -> override_flag -> module_expr -> class_expr -> class_expr end diff --git a/parsing/ast_invariants.ml b/parsing/ast_invariants.ml index 32e5f8fcfd19..8b0e156478e3 100644 --- a/parsing/ast_invariants.ml +++ b/parsing/ast_invariants.ml @@ -67,6 +67,7 @@ let iterator = | Ppat_construct (id, _) -> simple_longident id | Ppat_record (fields, _) -> List.iter (fun (id, _) -> simple_longident id) fields + | Ppat_open (id, _) -> simple_longident id | _ -> () in let expr self exp = @@ -87,8 +88,7 @@ let iterator = | Pexp_construct (id, _) | Pexp_field (_, id) | Pexp_setfield (_, id, _) - | Pexp_new id - | Pexp_open (_, id, _) -> simple_longident id + | Pexp_new id -> simple_longident id | Pexp_record (fields, _) -> List.iter (fun (id, _) -> simple_longident id) fields | _ -> () @@ -114,8 +114,7 @@ let iterator = | _ -> () in let open_description self opn = - super.open_description self opn; - simple_longident opn.popen_lid + super.open_description self opn in let with_constraint self wc = super.with_constraint self wc; diff --git a/parsing/ast_iterator.ml b/parsing/ast_iterator.ml index aa601e6419b4..90e37764fac2 100755 --- a/parsing/ast_iterator.ml +++ b/parsing/ast_iterator.ml @@ -186,8 +186,8 @@ module CT = struct | Pcty_arrow (_lab, t, ct) -> sub.typ sub t; sub.class_type sub ct | Pcty_extension x -> sub.extension sub x - | Pcty_open (_ovf, lid, e) -> - iter_loc sub lid; sub.class_type sub e + | Pcty_open (_ovf, me, e) -> + sub.module_expr sub me; sub.class_type sub e let iter_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} = @@ -372,8 +372,8 @@ module E = struct | Pexp_object cls -> sub.class_structure sub cls | Pexp_newtype (_s, e) -> sub.expr sub e | Pexp_pack me -> sub.module_expr sub me - | Pexp_open (_ovf, lid, e) -> - iter_loc sub lid; sub.expr sub e + | Pexp_open (_ovf, me, e) -> + sub.module_expr sub me; sub.expr sub e | Pexp_extension x -> sub.extension sub x | Pexp_unreachable -> () end @@ -434,8 +434,8 @@ module CE = struct | Pcl_constraint (ce, ct) -> sub.class_expr sub ce; sub.class_type sub ct | Pcl_extension x -> sub.extension sub x - | Pcl_open (_ovf, lid, e) -> - iter_loc sub lid; sub.class_expr sub e + | Pcl_open (_ovf, me, e) -> + sub.module_expr sub me; sub.class_expr sub e let iter_kind sub = function | Cfk_concrete (_o, e) -> sub.expr sub e @@ -535,8 +535,8 @@ let default_iterator = open_description = - (fun this {popen_lid; popen_override = _; popen_attributes; popen_loc} -> - iter_loc this popen_lid; + (fun this {popen_expr; popen_override = _; popen_attributes; popen_loc} -> + this.module_expr this popen_expr; this.location this popen_loc; this.attributes this popen_attributes ); diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 783d0e2eea50..4d70a3c6fd92 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -195,8 +195,8 @@ module CT = struct | Pcty_arrow (lab, t, ct) -> arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcty_open (ovf, lid, ct) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_type sub ct) + | Pcty_open (ovf, me, ct) -> + open_ ~loc ~attrs ovf (sub.module_expr sub me) (sub.class_type sub ct) let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} = @@ -394,8 +394,8 @@ module E = struct | Pexp_newtype (s, e) -> newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) - | Pexp_open (ovf, lid, e) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) + | Pexp_open (ovf, me, e) -> + open_ ~loc ~attrs ovf (sub.module_expr sub me) (sub.expr sub e) | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) | Pexp_unreachable -> unreachable ~loc ~attrs () end @@ -458,8 +458,8 @@ module CE = struct | Pcl_constraint (ce, ct) -> constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) - | Pcl_open (ovf, lid, ce) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (sub.class_expr sub ce) + | Pcl_open (ovf, me, ce) -> + open_ ~loc ~attrs ovf (sub.module_expr sub me) (sub.class_expr sub ce) let map_kind sub = function | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) @@ -570,8 +570,8 @@ let default_mapper = open_description = - (fun this {popen_lid; popen_override; popen_attributes; popen_loc} -> - Opn.mk (map_loc this popen_lid) + (fun this {popen_expr; popen_override; popen_attributes; popen_loc} -> + Opn.mk (this.module_expr this popen_expr) ~override:popen_override ~loc:(this.location this popen_loc) ~attrs:(this.attributes this popen_attributes) diff --git a/parsing/depend.ml b/parsing/depend.ml index 9e872fbc4066..0cca08c5f8d1 100644 --- a/parsing/depend.ml +++ b/parsing/depend.ml @@ -160,32 +160,6 @@ let add_type_extension bv te = add bv te.ptyext_path; List.iter (add_extension_constructor bv) te.ptyext_constructors -let rec add_class_type bv cty = - match cty.pcty_desc with - Pcty_constr(l, tyl) -> - add bv l; List.iter (add_type bv) tyl - | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } -> - add_type bv ty; - List.iter (add_class_type_field bv) fieldl - | Pcty_arrow(_, ty1, cty2) -> - add_type bv ty1; add_class_type bv cty2 - | Pcty_extension e -> handle_extension e - | Pcty_open (_ovf, m, e) -> - let bv = open_module bv m.txt in add_class_type bv e - -and add_class_type_field bv pctf = - match pctf.pctf_desc with - Pctf_inherit cty -> add_class_type bv cty - | Pctf_val(_, _, _, ty) -> add_type bv ty - | Pctf_method(_, _, _, ty) -> add_type bv ty - | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2 - | Pctf_attribute _ -> () - | Pctf_extension e -> handle_extension e - -let add_class_description bv infos = - add_class_type bv infos.pci_expr - -let add_class_type_declaration = add_class_description let pattern_bv = ref StringMap.empty @@ -268,7 +242,10 @@ let rec add_expr bv exp = | Pexp_newtype (_, e) -> add_expr bv e | Pexp_pack m -> add_module_expr bv m | Pexp_open (_ovf, m, e) -> - let bv = open_module bv m.txt in add_expr bv e + let Node(s, m') = add_module_binding bv m in + add_names s; + let bv = StringMap.fold StringMap.add m' bv in + add_expr bv e | Pexp_extension (({ txt = ("ocaml.extension_constructor"| "extension_constructor"); _ }, PStr [item]) as e) -> @@ -371,7 +348,10 @@ and add_sig_item (bv, m) item = end; (bv, m) | Psig_open od -> - (open_module bv od.popen_lid.txt, m) + let Node (s, m') = add_module_binding bv od.popen_expr in + add_names s; + let add = StringMap.fold StringMap.add m' in + (add bv, add m) | Psig_include incl -> let Node (s, m') = add_modtype_binding bv incl.pincl_mod in add_names s; @@ -380,7 +360,7 @@ and add_sig_item (bv, m) item = | Psig_class cdl -> List.iter (add_class_description bv) cdl; (bv, m) | Psig_class_type cdtl -> - List.iter (add_class_type_declaration bv) cdtl; (bv, m) + List.iter (add_class_type_declaration () bv) cdtl; (bv, m) | Psig_attribute _ -> (bv, m) | Psig_extension (e, _) -> handle_extension e; @@ -409,6 +389,36 @@ and add_module_expr bv modl = | Pmod_extension e -> handle_extension e +and add_class_type bv cty = + match cty.pcty_desc with + Pcty_constr(l, tyl) -> + add bv l; List.iter (add_type bv) tyl + | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } -> + add_type bv ty; + List.iter (add_class_type_field bv) fieldl + | Pcty_arrow(_, ty1, cty2) -> + add_type bv ty1; add_class_type bv cty2 + | Pcty_extension e -> handle_extension e + | Pcty_open (_ovf, m, e) -> + let Node(s, m') = add_module_binding bv m in + add_names s; + let bv = StringMap.fold StringMap.add m' bv in + add_class_type bv e + +and add_class_type_field bv pctf = + match pctf.pctf_desc with + Pctf_inherit cty -> add_class_type bv cty + | Pctf_val(_, _, _, ty) -> add_type bv ty + | Pctf_method(_, _, _, ty) -> add_type bv ty + | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2 + | Pctf_attribute _ -> () + | Pctf_extension e -> handle_extension e + +and add_class_description bv infos = + add_class_type bv infos.pci_expr + +and add_class_type_declaration () = add_class_description + and add_structure bv item_list = let (bv, m) = add_structure_binding bv item_list in add_names (collect_free (make_node m)); @@ -452,11 +462,14 @@ and add_struct_item (bv, m) item : _ StringMap.t * _ StringMap.t = end; (bv, m) | Pstr_open od -> - (open_module bv od.popen_lid.txt, m) + let Node (s, m') = add_module_binding bv od.popen_expr in + add_names s; + let add = StringMap.fold StringMap.add m' in + (add bv, add m) | Pstr_class cdl -> List.iter (add_class_declaration bv) cdl; (bv, m) | Pstr_class_type cdtl -> - List.iter (add_class_type_declaration bv) cdtl; (bv, m) + List.iter (add_class_type_declaration () bv) cdtl; (bv, m) | Pstr_include incl -> let Node (s, m') as n = add_module_binding bv incl.pincl_mod in if !Clflags.transparent_modules then @@ -502,7 +515,10 @@ and add_class_expr bv ce = add_class_expr bv ce; add_class_type bv ct | Pcl_extension e -> handle_extension e | Pcl_open (_ovf, m, e) -> - let bv = open_module bv m.txt in add_class_expr bv e + let Node(s, m') = add_module_binding bv m in + add_names s; + let bv = StringMap.fold StringMap.add m' bv in + add_class_expr bv e and add_class_field bv pcf = match pcf.pcf_desc with diff --git a/parsing/parser.mly b/parsing/parser.mly index 9ed25badac78..6206d87dd6d1 100644 --- a/parsing/parser.mly +++ b/parsing/parser.mly @@ -49,6 +49,9 @@ let mkoperator name pos = let mkpatvar name pos = Pat.mk ~loc:(rhs_loc pos) (Ppat_var (mkrhs name pos)) +let mkmodexpr name pos = + Mod.ident ~loc:(rhs_loc pos) (mkrhs name pos) + (* Ghost expressions and patterns: expressions and patterns that do not appear explicitly in the @@ -920,9 +923,9 @@ signature_item: mksig(Psig_attribute $1) } ; open_statement: - | OPEN override_flag ext_attributes mod_longident post_item_attributes + | OPEN override_flag ext_attributes module_expr post_item_attributes { let (ext, attrs) = $3 in - Opn.mk (mkrhs $4 4) ~override:$2 ~attrs:(attrs@$5) + Opn.mk $4 ~override:$2 ~attrs:(attrs@$5) ~loc:(symbol_rloc()) ~docs:(symbol_docs ()) , ext} ; @@ -1036,8 +1039,8 @@ class_expr: { mkclass(Pcl_apply($1, List.rev $2)) } | let_bindings IN class_expr { class_of_let_bindings $1 $3 } - | LET OPEN override_flag attributes mod_longident IN class_expr - { wrap_class_attrs (mkclass(Pcl_open($3, mkrhs $5 5, $7))) $4 } + | LET OPEN override_flag attributes module_expr IN class_expr + { wrap_class_attrs (mkclass(Pcl_open($3, $5, $7))) $4 } | class_expr attribute { Cl.attr $1 $2 } | extension @@ -1170,8 +1173,8 @@ class_signature: { Cty.attr $1 $2 } | extension { mkcty(Pcty_extension $1) } - | LET OPEN override_flag attributes mod_longident IN class_signature - { wrap_class_type_attrs (mkcty(Pcty_open($3, mkrhs $5 5, $7))) $4 } + | LET OPEN override_flag attributes module_expr IN class_signature + { wrap_class_type_attrs (mkcty(Pcty_open($3, $5, $7))) $4 } ; class_sig_body: class_self_type class_sig_fields @@ -1326,8 +1329,8 @@ expr: { mkexp_attrs (Pexp_letmodule(mkrhs $4 4, $5, $7)) $3 } | LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr { mkexp_attrs (Pexp_letexception($4, $6)) $3 } - | LET OPEN override_flag ext_attributes mod_longident IN seq_expr - { mkexp_attrs (Pexp_open($3, mkrhs $5 5, $7)) $4 } + | LET OPEN override_flag ext_attributes module_expr IN seq_expr + { mkexp_attrs (Pexp_open($3, $5, $7)) $4 } | FUNCTION ext_attributes opt_bar match_cases { mkexp_attrs (Pexp_function(List.rev $4)) $2 } | FUN ext_attributes labeled_simple_pattern fun_def @@ -1470,9 +1473,9 @@ simple_expr: | simple_expr DOT label_longident { mkexp(Pexp_field($1, mkrhs $3 3)) } | mod_longident DOT LPAREN seq_expr RPAREN - { mkexp(Pexp_open(Fresh, mkrhs $1 1, $4)) } + { mkexp(Pexp_open(Fresh, mkmodexpr $1 1, $4)) } | mod_longident DOT LPAREN RPAREN - { mkexp(Pexp_open(Fresh, mkrhs $1 1, + { mkexp(Pexp_open(Fresh, mkmodexpr $1 1, mkexp(Pexp_construct(mkrhs (Lident "()") 1, None)))) } | mod_longident DOT LPAREN seq_expr error { unclosed "(" 3 ")" 5 } @@ -1527,7 +1530,7 @@ simple_expr: | mod_longident DOT LBRACE record_expr RBRACE { let (exten, fields) = $4 in let rec_exp = mkexp(Pexp_record(fields, exten)) in - mkexp(Pexp_open(Fresh, mkrhs $1 1, rec_exp)) } + mkexp(Pexp_open(Fresh, mkmodexpr $1 1, rec_exp)) } | mod_longident DOT LBRACE record_expr error { unclosed "{" 3 "}" 5 } | LBRACKETBAR expr_semi_list opt_semi BARRBRACKET @@ -1537,9 +1540,9 @@ simple_expr: | LBRACKETBAR BARRBRACKET { mkexp (Pexp_array []) } | mod_longident DOT LBRACKETBAR expr_semi_list opt_semi BARRBRACKET - { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp(Pexp_array(List.rev $4)))) } + { mkexp(Pexp_open(Fresh, mkmodexpr $1 1, mkexp(Pexp_array(List.rev $4)))) } | mod_longident DOT LBRACKETBAR BARRBRACKET - { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp(Pexp_array []))) } + { mkexp(Pexp_open(Fresh, mkmodexpr $1 1, mkexp(Pexp_array []))) } | mod_longident DOT LBRACKETBAR expr_semi_list opt_semi error { unclosed "[|" 3 "|]" 6 } | LBRACKET expr_semi_list opt_semi RBRACKET @@ -1548,9 +1551,9 @@ simple_expr: { unclosed "[" 1 "]" 4 } | mod_longident DOT LBRACKET expr_semi_list opt_semi RBRACKET { let list_exp = reloc_exp (mktailexp (rhs_loc 6) (List.rev $4)) in - mkexp(Pexp_open(Fresh, mkrhs $1 1, list_exp)) } + mkexp(Pexp_open(Fresh, mkmodexpr $1 1, list_exp)) } | mod_longident DOT LBRACKET RBRACKET - { mkexp(Pexp_open(Fresh, mkrhs $1 1, + { mkexp(Pexp_open(Fresh, mkmodexpr $1 1, mkexp(Pexp_construct(mkrhs (Lident "[]") 1, None)))) } | mod_longident DOT LBRACKET expr_semi_list opt_semi error { unclosed "[" 3 "]" 6 } @@ -1567,9 +1570,9 @@ simple_expr: | LBRACELESS GREATERRBRACE { mkexp (Pexp_override [])} | mod_longident DOT LBRACELESS field_expr_list GREATERRBRACE - { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp (Pexp_override $4)))} + { mkexp(Pexp_open(Fresh, mkmodexpr $1 1, mkexp (Pexp_override $4)))} | mod_longident DOT LBRACELESS GREATERRBRACE - { mkexp(Pexp_open(Fresh, mkrhs $1 1, mkexp (Pexp_override [])))} + { mkexp(Pexp_open(Fresh, mkmodexpr $1 1, mkexp (Pexp_override [])))} | mod_longident DOT LBRACELESS field_expr_list error { unclosed "{<" 3 ">}" 5 } | simple_expr HASH label @@ -1586,7 +1589,7 @@ simple_expr: { unclosed "(" 1 ")" 6 } | mod_longident DOT LPAREN MODULE ext_attributes module_expr COLON package_type RPAREN - { mkexp(Pexp_open(Fresh, mkrhs $1 1, + { mkexp(Pexp_open(Fresh, mkmodexpr $1 1, mkexp_attrs (Pexp_constraint (ghexp (Pexp_pack $6), ghtyp (Ptyp_package $8))) $5 )) } diff --git a/parsing/parsetree.mli b/parsing/parsetree.mli index 9f5de197b321..b3af00522679 100644 --- a/parsing/parsetree.mli +++ b/parsing/parsetree.mli @@ -346,7 +346,7 @@ and expression_desc = (module ME : S) is represented as Pexp_constraint(Pexp_pack, Ptyp_package S) *) - | Pexp_open of override_flag * Longident.t loc * expression + | Pexp_open of override_flag * module_expr * expression (* M.(E) let open M in E let! open M in E *) @@ -504,7 +504,7 @@ and class_type_desc = *) | Pcty_extension of extension (* [%id] *) - | Pcty_open of override_flag * Longident.t loc * class_type + | Pcty_open of override_flag * module_expr * class_type (* let open M in CT *) and class_signature = @@ -596,7 +596,7 @@ and class_expr_desc = (* (CE : CT) *) | Pcl_extension of extension (* [%id] *) - | Pcl_open of override_flag * Longident.t loc * class_expr + | Pcl_open of override_flag * module_expr * class_expr (* let open M in CE *) @@ -735,7 +735,7 @@ and module_type_declaration = and open_description = { - popen_lid: Longident.t loc; + popen_expr: module_expr; popen_override: override_flag; popen_loc: Location.t; popen_attributes: attributes; diff --git a/parsing/pprintast.ml b/parsing/pprintast.ml index e9e0de28e4fe..1749baf17916 100644 --- a/parsing/pprintast.ml +++ b/parsing/pprintast.ml @@ -666,8 +666,8 @@ and expression ctxt f x = | Pexp_poly (e, Some ct) -> pp f "@[(!poly!@ %a@ : %a)@]" (simple_expr ctxt) e (core_type ctxt) ct - | Pexp_open (ovf, lid, e) -> - pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid + | Pexp_open (ovf, m, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) (module_expr ctxt) m (expression ctxt) e | Pexp_variant (l,Some eo) -> pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo @@ -830,8 +830,8 @@ and class_type ctxt f x = | Pcty_extension e -> extension ctxt f e; attributes ctxt f x.pcty_attributes - | Pcty_open (ovf, lid, e) -> - pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid + | Pcty_open (ovf, m, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) (module_expr ctxt) m (class_type ctxt) e (* [class type a = object end] *) @@ -949,8 +949,8 @@ and class_expr ctxt f x = (class_expr ctxt) ce (class_type ctxt) ct | Pcl_extension e -> extension ctxt f e - | Pcl_open (ovf, lid, e) -> - pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid + | Pcl_open (ovf, m, e) -> + pp f "@[<2>let open%s %a in@;%a@]" (override ovf) (module_expr ctxt) m (class_expr ctxt) e and module_type ctxt f x = @@ -1045,7 +1045,7 @@ and signature_item ctxt f x : unit = | Psig_open od -> pp f "@[open%s@ %a@]%a" (override od.popen_override) - longident_loc od.popen_lid + (module_expr ctxt) od.popen_expr (item_attributes ctxt) od.popen_attributes | Psig_include incl -> pp f "@[include@ %a@]%a" @@ -1247,7 +1247,7 @@ and structure_item ctxt f x = | Pstr_open od -> pp f "@[<2>open%s@;%a@]%a" (override od.popen_override) - longident_loc od.popen_lid + (module_expr ctxt) od.popen_expr (item_attributes ctxt) od.popen_attributes | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> pp f "@[module@ type@ %s%a@]%a" diff --git a/parsing/printast.ml b/parsing/printast.ml index 62ccc04b0ae9..3fd8bd6c1aab 100644 --- a/parsing/printast.ml +++ b/parsing/printast.ml @@ -371,8 +371,8 @@ and expression i ppf x = line i ppf "Pexp_pack\n"; module_expr i ppf me | Pexp_open (ovf, m, e) -> - line i ppf "Pexp_open %a \"%a\"\n" fmt_override_flag ovf - fmt_longident_loc m; + line i ppf "Pexp_open %a\n%a\n" fmt_override_flag ovf + (module_expr i) m; expression i ppf e | Pexp_extension (s, arg) -> line i ppf "Pexp_extension \"%s\"\n" s.txt; @@ -487,7 +487,7 @@ and class_type i ppf x = payload i ppf arg | Pcty_open (ovf, m, e) -> line i ppf "Pcty_open %a \"%a\"\n" fmt_override_flag ovf - fmt_longident_loc m; + (module_expr i) m; class_type i ppf e and class_signature i ppf cs = @@ -578,7 +578,7 @@ and class_expr i ppf x = payload i ppf arg | Pcl_open (ovf, m, e) -> line i ppf "Pcl_open %a \"%a\"\n" fmt_override_flag ovf - fmt_longident_loc m; + (module_expr i) m; class_expr i ppf e and class_structure i ppf { pcstr_self = p; pcstr_fields = l } = @@ -691,9 +691,9 @@ and signature_item i ppf x = attributes i ppf x.pmtd_attributes; modtype_declaration i ppf x.pmtd_type | Psig_open od -> - line i ppf "Psig_open %a %a\n" + line i ppf "Psig_open %a\n%a\n" fmt_override_flag od.popen_override - fmt_longident_loc od.popen_lid; + (module_expr i) od.popen_expr; attributes i ppf od.popen_attributes | Psig_include incl -> line i ppf "Psig_include\n"; @@ -798,9 +798,9 @@ and structure_item i ppf x = attributes i ppf x.pmtd_attributes; modtype_declaration i ppf x.pmtd_type | Pstr_open od -> - line i ppf "Pstr_open %a %a\n" + line i ppf "Pstr_open %a\n%a\n" fmt_override_flag od.popen_override - fmt_longident_loc od.popen_lid; + (module_expr i) od.popen_expr; attributes i ppf od.popen_attributes | Pstr_class (l) -> line i ppf "Pstr_class\n"; diff --git a/testsuite/tests/parsetree/source.ml b/testsuite/tests/parsetree/source.ml index 97103dd38365..c25fc1f157ef 100644 --- a/testsuite/tests/parsetree/source.ml +++ b/testsuite/tests/parsetree/source.ml @@ -7341,4 +7341,75 @@ module Indexop = struct let x,y,z = Def.(h.%["one"], h.%("two"), h.%{"three"}) end +type t = A + +module M = struct + open struct type t' = t end + type t = B of t * t' | C +end + +(* test *) +include struct + open M + let test = B (B (C, A), A) +end + +include struct + open struct let aux x y = x / y end + let f x = aux x 2 + let g y = aux 3 y +end + +include struct + open struct exception Interrupt end + let run () = + raise Interrupt + let () = + match run() with exception Interrupt -> () | _ -> assert false +end + +module type S = sig + open struct + open struct + type t' = char + end + type t = t' -> int end + val x : t +end + +module M : S = struct + let x = Char.code +end + +open struct + open struct let counter = ref 0 end + let inc () = incr counter + let dec () = decr counter + let current () = !counter +end + +let () = + inc(); inc(); dec (); + assert (current () = 1) + +include struct open struct type t = T end let x = T end + +module type S = sig open struct assert false end end;; + +module type S = sig open struct type t = int end val x : t end;; + +module type S = sig + open struct type t = int end + type s = t +end + +module type T = sig type s = int end +module F(X:S) : T = X +module G(X:T) : S = X type t = | + +let x = let open struct type t = int let x = 1 end in x +let y = + let + open ((functor (X: sig val x : int end) -> struct X.x end)(struct let x = 1 end)) + in x diff --git a/testsuite/tests/parsing/shortcut_ext_attr.compilers.reference b/testsuite/tests/parsing/shortcut_ext_attr.compilers.reference index d8ceb058b223..d9becdf0ac50 100644 --- a/testsuite/tests/parsing/shortcut_ext_attr.compilers.reference +++ b/testsuite/tests/parsing/shortcut_ext_attr.compilers.reference @@ -56,7 +56,10 @@ expression (shortcut_ext_attr.ml[13,261+3]..[13,261+29]) attribute "foo" [] - Pexp_open Fresh ""M" (shortcut_ext_attr.ml[13,261+22]..[13,261+23])" + Pexp_open Fresh + module_expr (shortcut_ext_attr.ml[13,261+22]..[13,261+23]) + Pmod_ident "M" (shortcut_ext_attr.ml[13,261+22]..[13,261+23]) + expression (shortcut_ext_attr.ml[13,261+27]..[13,261+29]) Pexp_construct "()" (shortcut_ext_attr.ml[13,261+27]..[13,261+29]) None @@ -756,7 +759,10 @@ Pstr_extension "foo" [ structure_item (shortcut_ext_attr.ml[94,1905+0]..[94,1905+16]) - Pstr_open Fresh "M" (shortcut_ext_attr.ml[94,1905+15]..[94,1905+16]) + Pstr_open Fresh + module_expr (shortcut_ext_attr.ml[94,1905+15]..[94,1905+16]) + Pmod_ident "M" (shortcut_ext_attr.ml[94,1905+15]..[94,1905+16]) + attribute "foo" [] ] @@ -929,7 +935,10 @@ Psig_extension "foo" [ signature_item (shortcut_ext_attr.ml[115,2267+2]..[115,2267+18]) - Psig_open Fresh "M" (shortcut_ext_attr.ml[115,2267+17]..[115,2267+18]) + Psig_open Fresh + module_expr (shortcut_ext_attr.ml[115,2267+17]..[115,2267+18]) + Pmod_ident "M" (shortcut_ext_attr.ml[115,2267+17]..[115,2267+18]) + attribute "foo" [] ] diff --git a/testsuite/tests/typing-modules/ocamltests b/testsuite/tests/typing-modules/ocamltests index f8c9fcdb51fc..9c7c19a334b4 100644 --- a/testsuite/tests/typing-modules/ocamltests +++ b/testsuite/tests/typing-modules/ocamltests @@ -2,6 +2,7 @@ aliases.ml applicative_functor_type.ml firstclass.ml generative.ml +open_struct.ml pr5911.ml pr6394.ml pr7207.ml diff --git a/testsuite/tests/typing-modules/open_struct.ml b/testsuite/tests/typing-modules/open_struct.ml new file mode 100644 index 000000000000..5dd95a1fecef --- /dev/null +++ b/testsuite/tests/typing-modules/open_struct.ml @@ -0,0 +1,342 @@ +(* TEST + * expect +*) + +type t = A +[%%expect{| +type t = A +|}] + +module M = struct + open struct type t' = t end + type t = B of t * t' | C +end +[%%expect{| +module M : sig type t = B of t * t | C end +|}] + +(* test *) +include struct + open M + let test = B (B (C, A), A) +end +[%%expect{| +val test : M.t = M.B (M.B (M.C, A), A) +|}] + +include struct + open struct let aux x y = x / y end + let f x = aux x 2 + let g y = aux 3 y +end +[%%expect{| +val f : int -> int = +val g : int -> int = +|}];; + +include struct + open struct exception Interrupt end + let run () = + raise Interrupt + let () = + match run() with exception Interrupt -> () | _ -> assert false +end +[%%expect{| +val run : unit -> 'a = +|}];; + +module type S = sig + open struct + open struct + type t' = char + end + type t = t' -> int + end + val x : t +end +[%%expect{| +module type S = sig val x : char -> int end +|}];; + +module M : S = struct + let x = Char.code +end +[%%expect{| +module M : S +|}];; + +module M = struct + module M (F: sig end) (X: sig end) = struct end + open M(struct end) +end +[%%expect{| +Line _, characters 7-20: + open M(struct end) + ^^^^^^^^^^^^^ +Error: This module is not a structure; it has type + functor (X : sig end) -> sig end +|}] + +open struct + open struct let counter = ref 0 end + let inc () = incr counter + let dec () = decr counter + let current () = !counter +end +[%%expect{| +|}] + +let () = + inc(); inc(); dec (); + assert (current () = 1) +[%%expect{| +|}];; + +include struct open struct type t = T end let x = T end +[%%expect{| +Line _, characters 15-41: + include struct open struct type t = T end let x = T end + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The module identifier M#8 cannot be eliminated from val x : M#8.t +|}];; + +module A = struct + open struct + open struct + type t = T + let x = T + end + let y = x + end +end +[%%expect{| +module A : sig end +|}];; + +module A = struct + open struct + open struct + type t = T + end + let y = T + end + let g = y +end +[%%expect{| +Line _, characters 2-74: + ..open struct + open struct + type t = T + end + let y = T + end +Error: The module identifier M#11 cannot be eliminated from val g : + M#11.M#12.t +|}] + +module type S = sig open struct type t = T end val x : t end +[%%expect{| +Line _, characters 20-46: + module type S = sig open struct type t = T end val x : t end + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The module identifier M#13 cannot be eliminated from val x : M#13.t +|}];; + + +module type S = sig + open struct + type t = int + open struct + type s = T | A of t + end + val x : char + end + val y : t +end +[%%expect{| +module type S = sig val y : int end +|}] + +module type S = sig open struct assert false end end;; +[%%expect{| +module type S = sig end +|}];; + +module type S = sig open struct type t = int end val x : t end;; +[%%expect{| +module type S = sig val x : int end +|}];; + +module type S = sig + open struct type t = int end + type s = t +end +[%%expect{| +module type S = sig type s = int end +|}] + +module type T = sig type s = int end +module F(X:S) : T = X +module G(X:T) : S = X +[%%expect{| +module type T = sig type s = int end +module F : functor (X : S) -> T +module G : functor (X : T) -> S +|}] + +module Counter : sig val inc : unit -> unit val current : unit -> int val z : int val zz : int end = struct + open struct let counter = ref 0 end + let x = 1 + let y = 2 + let dec () = decr counter + + open struct + module A : sig val z : int end = struct + open struct + let n = 3 + module A = struct + open struct + let x = 1 + end + let y = x + end + let h = A.y + let g = A.y + n + end + let z = h + g + end + + let z = 12 + + module B : sig val z : int end = struct + open struct + module A = struct + open struct let x = 1 end + let y = x + open struct let x = 1 end + let z = y + x + end + let h = A.y + let g = A.z + 1 + end + let z = h + g + end + + let h = A.z + B.z + end + + let z = z + h + let g = 1 + let ggg = 2 + let inc () = incr counter + let zz = 5 + let current () = !counter +end +[%%expect{| +module Counter : + sig + val inc : unit -> unit + val current : unit -> int + val z : int + val zz : int + end +|}] + +let () = begin + assert (Counter.z = 21) +end +[%%expect{| +|}] + +module N = struct + open (functor + (N: sig open struct type t = int end val x : t end) -> + (struct let y = N.x end))(struct let x = 1 end) + + let () = + assert(y = 1) +end +[%%expect{| +module N : sig end +|}] + +module M = struct + open struct + open struct + module type S = sig open struct type t = int end val x : t end + module M : S = struct let x = 1 end + end + end +end +[%%expect{| +module M : sig end +|}] + +module N = struct + open struct + module type S = sig open struct type t = T end val x : t end + end +end +[%%expect{| +Line _, characters 24-50: + module type S = sig open struct type t = T end val x : t end + ^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The module identifier M#32 cannot be eliminated from val x : M#32.t +|}] + +let x = let open struct open struct let y = 1 end let x = y + 1 end in x +[%%expect{| +val x : int = 2 +|}] + +let y = + let + open ((functor (X: sig val x : int end) -> struct X.x end)(struct let x = 1 end)) + in x + +[%%expect{| +val y : int = 2 +|}] + +let x = let open struct type t = T end in T + +[%%expect{| +Line _, characters 42-43: + let x = let open struct type t = T end in T + ^ +Error: This expression has type M#36.t but an expression was expected of type + 'a + The type constructor M#36.t would escape its scope +|}] + +module type Print = sig + type t + val print: t -> unit +end + +module Print_int: Print with type t = int = struct + type t = int let print = print_int +end +module Print_list(P: Print): Print with type t = P.t list = struct + type t = P.t list + let print = List.iter P.print +end +let print_list_of_int = let open Print_list(Print_int) in print + +[%%expect{| +module type Print = sig type t val print : t -> unit end +module Print_int : sig type t = int val print : t -> unit end +module Print_list : + functor (P : Print) -> sig type t = P.t list val print : t -> unit end +val print_list_of_int : Print_int.t list -> unit = +|}] + +let f () = let open functor(X: sig end) -> struct end in ();; + +[%%expect{| +Line _, characters 20-53: + let f () = let open functor(X: sig end) -> struct end in ();; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This module is not a structure; it has type + functor (X : sig end) -> sig end +|}] diff --git a/typing/printtyped.ml b/typing/printtyped.ml index 1d06ad9b922c..caf412abb0ad 100644 --- a/typing/printtyped.ml +++ b/typing/printtyped.ml @@ -233,8 +233,8 @@ and pattern i ppf x = line i ppf "Tpat_type %a\n" fmt_path id; attributes i ppf attrs; pattern i ppf { x with pat_extra = rem } - | (Tpat_open (id,_,_), _, attrs)::rem -> - line i ppf "Tpat_open \"%a\"\n" fmt_path id; + | (Tpat_open (id,_), _, attrs)::rem -> + line i ppf "Tpat_open \"%a\"\n" fmt_longident id; attributes i ppf attrs; pattern i ppf { x with pat_extra = rem } | [] -> @@ -279,9 +279,10 @@ and expression_extra i ppf x attrs = attributes i ppf attrs; option i core_type ppf cto1; core_type i ppf cto2; - | Texp_open (ovf, m, _, _) -> - line i ppf "Texp_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m; + | Texp_open od -> + line i ppf "Texp_open %a\n" fmt_override_flag od.open_override; attributes i ppf attrs; + module_expr i ppf od.open_expr | Texp_poly cto -> line i ppf "Texp_poly\n"; attributes i ppf attrs; @@ -493,8 +494,9 @@ and class_type i ppf x = arg_label i ppf l; core_type i ppf co; class_type i ppf cl; - | Tcty_open (ovf, m, _, _, e) -> - line i ppf "Tcty_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m; + | Tcty_open (od, e) -> + line i ppf "Tcty_open %a\n" fmt_override_flag od.open_override; + module_expr i ppf od.open_expr; class_type i ppf e and class_signature i ppf { csig_self = ct; csig_fields = l } = @@ -577,8 +579,9 @@ and class_expr i ppf x = class_expr i ppf ce; class_type i ppf ct | Tcl_constraint (ce, None, _, _, _) -> class_expr i ppf ce - | Tcl_open (ovf, m, _, _, e) -> - line i ppf "Tcty_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m; + | Tcl_open (od, e) -> + line i ppf "Tcty_open %a \n" fmt_override_flag od.open_override; + module_expr i ppf od.open_expr; class_expr i ppf e and class_structure i ppf { cstr_self = p; cstr_fields = l } = @@ -682,9 +685,8 @@ and signature_item i ppf x = 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 - fmt_path od.open_path; + line i ppf "Tsig_open %a\n" + fmt_override_flag od.open_override; attributes i ppf od.open_attributes | Tsig_include incl -> line i ppf "Tsig_include\n"; @@ -787,9 +789,8 @@ and structure_item i ppf x = attributes i ppf x.mtd_attributes; modtype_declaration i ppf x.mtd_type | Tstr_open od -> - line i ppf "Tstr_open %a %a\n" - fmt_override_flag od.open_override - fmt_path od.open_path; + line i ppf "Tstr_open %a\n" + fmt_override_flag od.open_override; attributes i ppf od.open_attributes | Tstr_class (l) -> line i ppf "Tstr_class\n"; diff --git a/typing/tast_mapper.ml b/typing/tast_mapper.ml index 36e33e3f2fbd..58beec7576c6 100644 --- a/typing/tast_mapper.ml +++ b/typing/tast_mapper.ml @@ -17,7 +17,7 @@ open Asttypes open Typedtree (* TODO: add 'methods' for location, attribute, extension, - open_description, include_declaration, include_description *) + include_declaration, include_description *) type mapper = { @@ -63,6 +63,7 @@ type mapper = (rec_flag * value_binding list); value_description: mapper -> value_description -> value_description; with_constraint: mapper -> with_constraint -> with_constraint; + open_description: mapper -> open_description -> open_description } let id x = x @@ -125,7 +126,7 @@ let structure_item sub {str_desc; str_loc; str_env} = (List.map (tuple3 id id (sub.class_type_declaration sub)) list) | Tstr_include incl -> Tstr_include (include_infos (sub.module_expr sub) incl) - | Tstr_open _ + | Tstr_open od -> Tstr_open (sub.open_description sub od) | Tstr_attribute _ as d -> d in {str_desc; str_env; str_loc} @@ -187,7 +188,7 @@ let pat sub x = let extra = function | Tpat_type _ | Tpat_unpack as d -> d - | Tpat_open (path,loc,env) -> Tpat_open (path, loc, sub.env sub env) + | Tpat_open (loc,env) -> Tpat_open (loc, sub.env sub env) | Tpat_constraint ct -> Tpat_constraint (sub.typ sub ct) in let pat_env = sub.env sub x.pat_env in @@ -217,8 +218,7 @@ let expr sub x = Texp_constraint (sub.typ sub cty) | Texp_coerce (cty1, cty2) -> Texp_coerce (opt (sub.typ sub) cty1, sub.typ sub cty2) - | Texp_open (ovf, path, loc, env) -> - Texp_open (ovf, path, loc, sub.env sub env) + | Texp_open od -> Texp_open (sub.open_description sub od) | Texp_newtype _ as d -> d | Texp_poly cto -> Texp_poly (opt (sub.typ sub) cto) in @@ -388,7 +388,7 @@ let signature_item sub x = | Tsig_class_type list -> Tsig_class_type (List.map (sub.class_type_declaration sub) list) - | Tsig_open _ + | Tsig_open od -> Tsig_open (sub.open_description sub od) | Tsig_attribute _ as d -> d in {x with sig_desc; sig_env} @@ -426,6 +426,11 @@ let with_constraint sub = function | Twith_module _ | Twith_modsubst _ as d -> d +let open_description sub od = + {od with + open_expr = sub.module_expr sub od.open_expr; + open_env = sub.env sub od.open_env} + let module_coercion sub = function | Tcoerce_none -> Tcoerce_none | Tcoerce_functor (c1,c2) -> @@ -522,8 +527,8 @@ let class_expr sub x = ) | Tcl_ident (path, lid, tyl) -> Tcl_ident (path, lid, List.map (sub.typ sub) tyl) - | Tcl_open (ovf, p, lid, env, e) -> - Tcl_open (ovf, p, lid, sub.env sub env, sub.class_expr sub e) + | Tcl_open (od, e) -> + Tcl_open (sub.open_description sub od, sub.class_expr sub e) in {x with cl_desc; cl_env} @@ -544,8 +549,8 @@ let class_type sub x = sub.typ sub ct, sub.class_type sub cl ) - | Tcty_open (ovf, p, lid, env, e) -> - Tcty_open (ovf, p, lid, sub.env sub env, sub.class_type sub e) + | Tcty_open (od, e) -> + Tcty_open (sub.open_description sub od, sub.class_type sub e) in {x with cltyp_desc; cltyp_env} @@ -697,4 +702,5 @@ let default = value_bindings; value_description; with_constraint; + open_description; } diff --git a/typing/tast_mapper.mli b/typing/tast_mapper.mli index 2251fa570941..8eb48cd06722 100644 --- a/typing/tast_mapper.mli +++ b/typing/tast_mapper.mli @@ -62,6 +62,7 @@ type mapper = (rec_flag * value_binding list); value_description: mapper -> value_description -> value_description; with_constraint: mapper -> with_constraint -> with_constraint; + open_description: mapper -> open_description -> open_description; } diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 935e4092c76d..6e884d20e11f 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -553,10 +553,13 @@ and class_type_aux env scty = let typ = Cty_arrow (l, ty, clty.cltyp_type) in cltyp (Tcty_arrow (l, cty, clty)) typ - | Pcty_open (ovf, lid, e) -> - let (path, newenv) = !Typecore.type_open ovf env scty.pcty_loc lid in + | Pcty_open (ovf, me, e) -> + let (_id, tme, newenv) = !Typecore.type_open ovf env scty.pcty_loc me in let clty = class_type newenv e in - cltyp (Tcty_open (ovf, path, lid, newenv, clty)) clty.cltyp_type + let od = { + open_expr=tme; open_override=ovf; open_loc=scty.pcty_loc; + open_env=newenv; open_attributes=scty.pcty_attributes} in + cltyp (Tcty_open (od, clty)) clty.cltyp_type | Pcty_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) @@ -1234,12 +1237,21 @@ and class_expr_aux cl_num val_env met_env scl = cl_env = val_env; cl_attributes = scl.pcl_attributes; } - | Pcl_open (ovf, lid, e) -> + | Pcl_open (ovf, me, e) -> let used_slot = ref false in - let (path, new_val_env) = !Typecore.type_open ~used_slot ovf val_env scl.pcl_loc lid in - let (_path, new_met_env) = !Typecore.type_open ~used_slot ovf met_env scl.pcl_loc lid in + let (_, _, new_val_env) = + !Typecore.type_open ~used_slot ovf val_env scl.pcl_loc me in + let (_id, tme, new_met_env) = + !Typecore.type_open ~used_slot ovf met_env scl.pcl_loc me in let cl = class_expr cl_num new_val_env new_met_env e in - rc {cl_desc = Tcl_open (ovf, path, lid, new_val_env, cl); + let od = { + open_expr = tme; + open_override = ovf; + open_loc = scl.pcl_loc; + open_env = new_val_env; + open_attributes = me.pmod_attributes + } in + rc {cl_desc = Tcl_open (od, cl); cl_loc = scl.pcl_loc; cl_type = cl.cl_type; cl_env = val_env; @@ -1804,7 +1816,7 @@ let rec unify_parents env ty cl = | _exn -> assert false end | Tcl_structure st -> unify_parents_struct env ty st - | Tcl_open (_, _, _, _, cl) + | Tcl_open (_, cl) | Tcl_fun (_, _, _, cl, _) | Tcl_apply (cl, _) | Tcl_let (_, _, _, cl) diff --git a/typing/typecore.ml b/typing/typecore.ml index 30f0eadc7a1d..9fa54c0dcd2d 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -107,11 +107,15 @@ let type_module = ref ((fun _env _md -> assert false) : Env.t -> Parsetree.module_expr -> Typedtree.module_expr) +let gen_mod_ident : (Parsetree.module_expr -> Ident.t option) ref = ref (fun _ -> assert false) + (* Forward declaration, to be filled in by Typemod.type_open *) let type_open : (?used_slot:bool ref -> override_flag -> Env.t -> Location.t -> - Longident.t loc -> Path.t * Env.t) + Parsetree.module_expr -> + (Ident.t * Types.module_declaration * Env.t) option * + Typedtree.module_expr * Env.t) ref = ref (fun ?used_slot:_ _ -> assert false) @@ -1410,14 +1414,19 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env k { p with pat_extra = (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra } | Ppat_open (lid,p) -> - let path, new_env = - !type_open Asttypes.Fresh !env sp.ppat_loc lid in - let new_env = ref new_env in - type_pat ~env:new_env p expected_ty ( fun p -> - env := Env.copy_local !env ~from:!new_env; - k { p with pat_extra =( Tpat_open (path,lid,!new_env), - loc, sp.ppat_attributes) :: p.pat_extra } - ) + let me = Ast_helper.Mod.ident ~loc:lid.loc ~attrs:[] lid in + let id, _tme, new_env = + !type_open Asttypes.Fresh !env sp.ppat_loc me in begin + match id with + | Some _ -> assert false (* not possible due to syntactic restriction *) + | None -> + let new_env = ref new_env in + type_pat ~env:new_env p expected_ty ( fun p -> + env := Env.copy_local !env ~from:!new_env; + k { p with pat_extra =( Tpat_open (lid,!new_env), + loc, sp.ppat_attributes) :: p.pat_extra } + ) + end | Ppat_exception _ -> raise (Error (loc, !env, Exception_pattern_below_toplevel)) | Ppat_extension ext -> @@ -2239,7 +2248,7 @@ struct Use.(inspect (join ty (class_expr env ce))) | Tcl_constraint (ce, _, _, _, _) -> class_expr env ce - | Tcl_open (_, _, _, _, ce) -> + | Tcl_open (_, ce) -> class_expr env ce and case : Env.env -> Typedtree.case -> scrutinee:Use.t -> Use.t = fun env { Typedtree.c_lhs; c_guard; c_rhs } ~scrutinee:ty -> @@ -2339,7 +2348,7 @@ struct Use.join ty (class_expr env ce) | Tcl_constraint (ce, _, _, _, _) -> class_expr env ce - | Tcl_open (_, _, _, _, ce) -> + | Tcl_open (_, ce) -> class_expr env ce in match Use.unguarded (class_expr (build_unguarded_env idlist) ce) with @@ -3721,15 +3730,28 @@ and type_expect_ exp_type = newty (Tpackage (p, nl, tl')); exp_attributes = sexp.pexp_attributes; exp_env = env } - | Pexp_open (ovf, lid, e) -> - let (path, newenv) = !type_open ovf env sexp.pexp_loc lid in - let exp = type_expect newenv e ty_expected_explained in - { exp with - exp_extra = (Texp_open (ovf, path, lid, newenv), loc, - sexp.pexp_attributes) :: - exp.exp_extra; - } - + | Pexp_open (ovf, me, e) -> begin + match !gen_mod_ident me with + | None -> + let (_id, tme, newenv) = !type_open ovf env loc me in + let exp = type_expect newenv e ty_expected_explained in + let od = { open_expr=tme; open_override=ovf; + open_loc=loc; open_env=newenv; + open_attributes=sexp.pexp_attributes } in + { exp with + exp_extra = (Texp_open od, loc, + sexp.pexp_attributes) :: + exp.exp_extra; + } + | Some {Ident.name} -> + let pmod = Pmod_ident ({txt=Longident.Lident name; loc}) in + let popen = Pexp_open (ovf, {me with pmod_desc = pmod}, e) in + let pexp_desc = Pexp_letmodule ({txt=name;loc}, me, + {sexp with pexp_desc=popen}) in + let sexp = {pexp_desc; pexp_loc=loc; + pexp_attributes=sexp.pexp_attributes} in + type_expect env sexp ty_expected_explained + end | Pexp_extension ({ txt = ("ocaml.extension_constructor" |"extension_constructor"); _ }, payload) -> diff --git a/typing/typecore.mli b/typing/typecore.mli index b7e1b716dd4b..30b65b54ddd3 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -174,8 +174,10 @@ val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref (* Forward declaration, to be filled in by Typemod.type_open *) val type_open: (?used_slot:bool ref -> override_flag -> Env.t -> Location.t -> - Longident.t loc -> Path.t * Env.t) - ref + Parsetree.module_expr -> + (Ident.t * Types.module_declaration * Env.t) option * + Typedtree.module_expr * Env.t) + ref (* Forward declaration, to be filled in by Typeclass.class_structure *) val type_object: (Env.t -> Location.t -> Parsetree.class_structure -> @@ -183,6 +185,7 @@ val type_object: val type_package: (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list -> Typedtree.module_expr * type_expr list) ref +val gen_mod_ident : (Parsetree.module_expr -> Ident.t option) ref val create_package_type : Location.t -> Env.t -> Longident.t * (Longident.t * Parsetree.core_type) list -> diff --git a/typing/typedtree.ml b/typing/typedtree.ml index 4cc996432413..f624ca198280 100644 --- a/typing/typedtree.ml +++ b/typing/typedtree.ml @@ -38,7 +38,7 @@ type pattern = and pat_extra = | Tpat_constraint of core_type | Tpat_type of Path.t * Longident.t loc - | Tpat_open of Path.t * Longident.t loc * Env.t + | Tpat_open of Longident.t loc * Env.t | Tpat_unpack and pattern_desc = @@ -69,7 +69,7 @@ and expression = and exp_extra = | Texp_constraint of core_type | Texp_coerce of core_type option * core_type - | Texp_open of override_flag * Path.t * Longident.t loc * Env.t + | Texp_open of open_description | Texp_poly of core_type option | Texp_newtype of string @@ -153,7 +153,7 @@ and class_expr_desc = | Tcl_constraint of class_expr * class_type option * string list * string list * Concr.t (* Visible instance variables, methods and concrete methods *) - | Tcl_open of override_flag * Path.t * Longident.t loc * Env.t * class_expr + | Tcl_open of open_description * class_expr and class_structure = { @@ -331,10 +331,10 @@ and module_type_declaration = and open_description = { - open_path: Path.t; - open_txt: Longident.t loc; + open_expr: module_expr; open_override: override_flag; open_loc: Location.t; + open_env: Env.t; open_attributes: attribute list; } @@ -483,7 +483,7 @@ and class_type_desc = Tcty_constr of Path.t * Longident.t loc * core_type list | Tcty_signature of class_signature | Tcty_arrow of arg_label * core_type * class_type - | Tcty_open of override_flag * Path.t * Longident.t loc * Env.t * class_type + | Tcty_open of open_description * class_type and class_signature = { csig_self: core_type; diff --git a/typing/typedtree.mli b/typing/typedtree.mli index 2e89ed52330f..cc810e2706cb 100644 --- a/typing/typedtree.mli +++ b/typing/typedtree.mli @@ -56,7 +56,7 @@ and pat_extra = where [disjunction] is a [Tpat_or _] representing the branches of [tconst]. *) - | Tpat_open of Path.t * Longident.t loc * Env.t + | Tpat_open of Longident.t loc * Env.t | Tpat_unpack (** (module P) { pat_desc = Tpat_var "P" ; pat_extra = (Tpat_unpack, _, _) :: ... } @@ -123,7 +123,7 @@ and exp_extra = (** E :> T [Texp_coerce (None, T)] E : T0 :> T [Texp_coerce (Some T0, T)] *) - | Texp_open of override_flag * Path.t * Longident.t loc * Env.t + | Texp_open of open_description (** let open[!] M in [Texp_open (!, P, M, env)] where [env] is the environment after opening [P] *) @@ -268,7 +268,7 @@ and class_expr_desc = | Tcl_constraint of class_expr * class_type option * string list * string list * Concr.t (* Visible instance variables, methods and concrete methods *) - | Tcl_open of override_flag * Path.t * Longident.t loc * Env.t * class_expr + | Tcl_open of open_description * class_expr and class_structure = { @@ -451,10 +451,10 @@ and module_type_declaration = and open_description = { - open_path: Path.t; - open_txt: Longident.t loc; + open_expr: module_expr; open_override: override_flag; open_loc: Location.t; + open_env: Env.t; open_attributes: attribute list; } @@ -605,7 +605,7 @@ and class_type_desc = Tcty_constr of Path.t * Longident.t loc * core_type list | Tcty_signature of class_signature | Tcty_arrow of arg_label * core_type * class_type - | Tcty_open of override_flag * Path.t * Longident.t loc * Env.t * class_type + | Tcty_open of open_description * class_type and class_signature = { csig_self : core_type; diff --git a/typing/typedtreeIter.ml b/typing/typedtreeIter.ml index a3be8d3be547..86563575d4cf 100644 --- a/typing/typedtreeIter.ml +++ b/typing/typedtreeIter.ml @@ -145,7 +145,7 @@ module MakeIterator(Iter : IteratorArgument) : sig | Tstr_module x -> iter_module_binding x | Tstr_recmodule list -> List.iter iter_module_binding list | Tstr_modtype mtd -> iter_module_type_declaration mtd - | Tstr_open _ -> () + | Tstr_open od -> iter_module_expr od.open_expr | Tstr_class list -> List.iter (fun (ci, _) -> iter_class_declaration ci) list | Tstr_class_type list -> @@ -390,7 +390,7 @@ module MakeIterator(Iter : IteratorArgument) : sig List.iter (fun md -> iter_module_type md.md_type) list | Tsig_modtype mtd -> iter_module_type_declaration mtd - | Tsig_open _ -> () + | Tsig_open od -> iter_module_expr od.open_expr | Tsig_include incl -> iter_module_type incl.incl_mod | Tsig_class list -> List.iter iter_class_description list @@ -512,7 +512,8 @@ module MakeIterator(Iter : IteratorArgument) : sig | Tcl_ident (_, _, tyl) -> List.iter iter_core_type tyl - | Tcl_open (_, _, _, _, e) -> + | Tcl_open (od, e) -> + iter_module_expr od.open_expr; iter_class_expr e end; Iter.leave_class_expr cexpr; @@ -527,7 +528,8 @@ module MakeIterator(Iter : IteratorArgument) : sig | Tcty_arrow (_label, ct, cl) -> iter_core_type ct; iter_class_type cl - | Tcty_open (_, _, _, _, e) -> + | Tcty_open (od, e) -> + iter_module_expr od.open_expr; iter_class_type e end; Iter.leave_class_type ct; diff --git a/typing/typedtreeMap.ml b/typing/typedtreeMap.ml index ccde8c03a4b5..b1e549bc26b9 100644 --- a/typing/typedtreeMap.ml +++ b/typing/typedtreeMap.ml @@ -129,7 +129,8 @@ module MakeMap(Map : MapArgument) = struct Tstr_recmodule list | Tstr_modtype mtd -> Tstr_modtype (map_module_type_declaration mtd) - | Tstr_open od -> Tstr_open od + | Tstr_open od -> + Tstr_open {od with open_expr = map_module_expr od.open_expr} | Tstr_class list -> let list = List.map @@ -567,8 +568,10 @@ module MakeMap(Map : MapArgument) = struct | Tcl_ident (id, name, tyl) -> Tcl_ident (id, name, List.map map_core_type tyl) - | Tcl_open (ovf, p, lid, env, e) -> - Tcl_open (ovf, p, lid, env, map_class_expr e) + | Tcl_open (od, e) -> + Tcl_open ( + {od with open_expr = map_module_expr od.open_expr}, + map_class_expr e) in Map.leave_class_expr { cexpr with cl_desc = cl_desc } @@ -581,8 +584,8 @@ module MakeMap(Map : MapArgument) = struct Tcty_constr (path, lid, List.map map_core_type list) | Tcty_arrow (label, ct, cl) -> Tcty_arrow (label, map_core_type ct, map_class_type cl) - | Tcty_open (ovf, p, lid, env, e) -> - Tcty_open (ovf, p, lid, env, map_class_type e) + | Tcty_open (od, e) -> + Tcty_open ({od with open_expr = od.open_expr}, map_class_type e) in Map.leave_class_type { ct with cltyp_desc = cltyp_desc } diff --git a/typing/typemod.ml b/typing/typemod.ml index 1812e0899f81..de478bbeb6c6 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -46,6 +46,7 @@ type error = | Recursive_module_require_explicit_type | Apply_generative | Cannot_scrape_alias of Path.t + | Cannot_eliminate_anon_module of Ident.t * signature exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -85,14 +86,64 @@ let extract_sig_open env loc mty = (* Compute the environment after opening a module *) -let type_open_ ?used_slot ?toplevel ovf env loc lid = - let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in - match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with - | Some env -> path, env - | None -> - let md = Env.find_module path env in - ignore (extract_sig_open env lid.loc md.md_type); - assert false +let type_module_fwd : (Env.t -> Parsetree.module_expr -> + Typedtree.module_expr) ref = + ref (fun _ _ -> assert false) + +let mod_ident_counter = ref 0 + +let gen_mod_ident () = + let n = !mod_ident_counter in + incr mod_ident_counter; + Ident.create (Printf.sprintf "M#%d" n) + +let open_struct_level = ref 0 +let in_nested_struct () = !open_struct_level <> 0 +let enter_struct () = incr open_struct_level +let leave_struct () = decr open_struct_level + +let open_generated s = String.contains s '#' + +let type_open_ ?used_slot ?toplevel ovf env loc me = + let report_illegal_mt mt loc env = + ignore (extract_sig_open env loc mt); + assert false + in + match me.pmod_desc with + | Pmod_ident lid -> + let path = Typetexp.lookup_module ~load:true env lid.loc lid.txt in + begin + match Env.open_signature ~loc ?used_slot ?toplevel ovf path env with + | Some env -> + let tme = + { + mod_desc=Tmod_ident (path, lid); + mod_loc=lid.loc; + mod_type=Mty_ident path; + mod_env=env; + mod_attributes=me.pmod_attributes + } in + None, tme, env + | None -> + let mt = (Env.find_module path env).md_type in + report_illegal_mt mt lid.loc env + end + | Pmod_structure _ | Pmod_apply _ | Pmod_constraint _ | Pmod_unpack _ | + Pmod_functor _ | Pmod_extension _ -> + enter_struct (); + let ident = gen_mod_ident () in + let tme = !type_module_fwd env me in + leave_struct (); + let md = { + md_type = tme.mod_type; + md_loc = me.pmod_loc; + md_attributes = me.pmod_attributes; + } in + let newenv = Env.enter_module_declaration ident md env in + let root = Pident ident in + match Env.open_signature ~loc ?used_slot ?toplevel ovf root newenv with + | None -> report_illegal_mt tme.mod_type me.pmod_loc env + | Some opened_env -> Some (ident, md, newenv), tme, opened_env let type_initially_opened_module env module_name = let loc = Location.in_file "compiler internals" in @@ -121,29 +172,30 @@ let initial_env ~loc ~safe_string ~initially_opened_module in let open_implicit_module env m = let open Asttypes in - let lid = {loc; txt = Longident.parse m } in - snd (type_open_ Override env lid.loc lid) + let me = Ast_helper.Mod.ident ~loc ~attrs:[] + {loc; txt = Longident.parse m } in + let _, _, env = type_open_ Override env loc me in env in List.fold_left open_implicit_module env open_implicit_modules let type_open ?toplevel env sod = - let (path, newenv) = + let (inserted_md, tme, open_env) = Builtin_attributes.warning_scope sod.popen_attributes (fun () -> type_open_ ?toplevel sod.popen_override env sod.popen_loc - sod.popen_lid + sod.popen_expr ) in let od = { open_override = sod.popen_override; - open_path = path; - open_txt = sod.popen_lid; + open_expr = tme; open_attributes = sod.popen_attributes; open_loc = sod.popen_loc; + open_env; } in - (path, newenv, od) + inserted_md, od (* Record a module type *) let rm node = @@ -597,8 +649,8 @@ and approx_sig env ssg = let (id, newenv) = Env.enter_modtype d.pmtd_name.txt info env in Sig_modtype(id, info) :: approx_sig newenv srem | Psig_open sod -> - let (_path, mty, _od) = type_open env sod in - approx_sig mty srem + let (_id, od) = type_open env sod in + approx_sig od.open_env srem | Psig_include sincl -> let smty = sincl.pincl_mod in let mty = approx_modtype env smty in @@ -707,6 +759,24 @@ let simplify_signature sg = let (sg, _) = aux sg in sg +let remove_inserted_modtype mty = + let rec aux = function + | Mty_signature sg -> + let sg = + List.filter ( + function + | Sig_module({Ident.name}, _, _) when open_generated name -> false + | _ -> true) sg in + Mty_signature sg + | Mty_functor (id, mty_arg, mty_res) -> + Mty_functor (id, + (match mty_arg with + | None -> None + | Some mty -> Some (aux mty)), + (aux mty_res)) + | (Mty_ident _ | Mty_alias _) as mty -> mty in + aux mty + let has_remove_aliases_attribute attr = let remove_aliases = Attr_helper.get_no_payload_attribute @@ -741,6 +811,11 @@ let mksig desc env loc = Cmt_format.add_saved_type (Cmt_format.Partial_signature_item sg); sg +let mkstr str env loc = + let str = { str_desc = str; str_loc = loc; str_env = env } in + Cmt_format.add_saved_type (Cmt_format.Partial_structure_item str); + str + (* let signature sg = List.map (fun item -> item.sig_type) sg *) let rec transl_modtype env smty = @@ -890,10 +965,22 @@ and transl_signature env sg = sg :: rem, final_env | Psig_open sod -> - let (_path, newenv, od) = type_open env sod in - let (trem, rem, final_env) = transl_sig newenv srem in - mksig (Tsig_open od) env loc :: trem, - rem, final_env + let id, od = type_open env sod in + let open_env = od.open_env in + let (trem, rem, final_env) = transl_sig open_env srem in + let rem = + begin match id with + | None -> rem + | Some (id, _md, _env) -> + let s_rem = Mty_signature rem in + match Mtype.nondep_supertype open_env id s_rem with + | Mty_signature rem' -> rem' + | exception Not_found -> + raise(Error(sod.popen_loc, env, + Cannot_eliminate_anon_module(id, rem))) + | Mty_ident _ | Mty_functor _ | Mty_alias _ -> assert false + end in + mksig (Tsig_open od) env loc :: trem, rem, final_env | Psig_include sincl -> let smty = sincl.pincl_mod in let tmty = @@ -1449,262 +1536,301 @@ and type_module_aux ~alias sttn funct_body anchor env smod = and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let names = new_names () in - let type_str_item env srem {pstr_loc = loc; pstr_desc = desc} = - match desc with - | Pstr_eval (sexpr, attrs) -> - let expr = - Builtin_attributes.warning_scope attrs - (fun () -> Typecore.type_expression env sexpr) - in - Tstr_eval (expr, attrs), [], env - | Pstr_value(rec_flag, sdefs) -> - let scope = - match rec_flag with - | Recursive -> - Some (Annot.Idef {scope with - Location.loc_start = loc.Location.loc_start}) - | Nonrecursive -> - let start = - match srem with - | [] -> loc.Location.loc_end - | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start - in - Some (Annot.Idef {scope with Location.loc_start = start}) - in - let (defs, newenv) = - Typecore.type_binding env rec_flag sdefs scope in - let () = if rec_flag = Recursive then - Typecore.check_recursive_bindings env defs - in - (* Note: Env.find_value does not trigger the value_used event. Values - will be marked as being used during the signature inclusion test. *) - Tstr_value(rec_flag, defs), - List.map (fun id -> Sig_value(id, Env.find_value (Pident id) newenv)) - (let_bound_idents defs), - newenv - | Pstr_primitive sdesc -> - let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in - Tstr_primitive desc, [Sig_value(desc.val_id, desc.val_val)], newenv - | Pstr_type (rec_flag, sdecls) -> - List.iter - (fun decl -> check_name check_type names decl.ptype_name) - sdecls; - let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in - Tstr_type (rec_flag, decls), - map_rec_type_with_row_types ~rec_flag - (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs)) - decls [], - enrich_type_decls anchor decls env newenv - | Pstr_typext styext -> - List.iter - (fun pext -> check_name check_typext names pext.pext_name) - styext.ptyext_constructors; - let (tyext, newenv) = - Typedecl.transl_type_extension true env loc styext - in - (Tstr_typext tyext, - map_ext - (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es)) - tyext.tyext_constructors [], - newenv) - | Pstr_exception sext -> - check_name check_typext names sext.pext_name; - let (ext, newenv) = Typedecl.transl_exception env sext in - Tstr_exception ext, - [Sig_typext(ext.ext_id, ext.ext_type, Text_exception)], - newenv - | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs; - pmb_loc; - } -> - check_name check_module names name; - let id = Ident.create name.txt in (* create early for PR#6752 *) - let modl = - Builtin_attributes.warning_scope attrs - (fun () -> - type_module ~alias:true true funct_body - (anchor_submodule name.txt anchor) env smodl - ) - in - let md = - { md_type = enrich_module_type anchor name.txt modl.mod_type env; - md_attributes = attrs; - md_loc = pmb_loc; - } - in - (*prerr_endline (Ident.unique_toplevel_name id);*) - Mtype.lower_nongen (Ident.binding_time id - 1) md.md_type; - let newenv = Env.enter_module_declaration id md env in - Tstr_module {mb_id=id; mb_name=name; mb_expr=modl; - mb_attributes=attrs; mb_loc=pmb_loc; - }, - [Sig_module(id, - {md_type = modl.mod_type; - md_attributes = attrs; - md_loc = pmb_loc; - }, Trec_not)], - newenv - | Pstr_recmodule sbind -> - let sbind = - List.map - (function - | {pmb_name = name; - pmb_expr = {pmod_desc=Pmod_constraint(expr, typ)}; - pmb_attributes = attrs; - pmb_loc = loc; - } -> - name, typ, expr, attrs, loc - | mb -> - raise (Error (mb.pmb_expr.pmod_loc, env, - Recursive_module_require_explicit_type)) - ) - sbind - in - List.iter - (fun (name, _, _, _, _) -> check_name check_module names name) - sbind; - let (decls, newenv) = - transl_recmodule_modtypes env - (List.map (fun (name, smty, _smodl, attrs, loc) -> - {pmd_name=name; pmd_type=smty; - pmd_attributes=attrs; pmd_loc=loc}) sbind - ) in - let bindings1 = - List.map2 - (fun {md_id=id; md_type=mty} (name, _, smodl, attrs, loc) -> - let modl = - Builtin_attributes.warning_scope attrs - (fun () -> - type_module true funct_body (anchor_recmodule id) - newenv smodl - ) - in - let mty' = - enrich_module_type anchor (Ident.name id) modl.mod_type newenv - in - (id, name, mty, modl, mty', attrs, loc)) - decls sbind in - let newenv = (* allow aliasing recursive modules from outside *) - List.fold_left - (fun env md -> - let mdecl = - { - md_type = md.md_type.mty_type; - md_attributes = md.md_attributes; - md_loc = md.md_loc; - } - in - Env.add_module_declaration ~check:true md.md_id mdecl env - ) - env decls - in - let bindings2 = - check_recmodule_inclusion newenv bindings1 in - Tstr_recmodule bindings2, - map_rec (fun rs mb -> - Sig_module(mb.mb_id, { - md_type=mb.mb_expr.mod_type; - md_attributes=mb.mb_attributes; - md_loc=mb.mb_loc; - }, rs)) - bindings2 [], - newenv - | Pstr_modtype pmtd -> - (* check that it is non-abstract *) - let newenv, mtd, sg = - transl_modtype_decl names env pmtd - in - Tstr_modtype mtd, [sg], newenv - | Pstr_open sod -> - let (_path, newenv, od) = type_open ~toplevel env sod in - Tstr_open od, [], newenv - | Pstr_class cl -> - List.iter - (fun {pci_name} -> check_name check_type names pci_name) - cl; - let (classes, new_env) = Typeclass.class_declarations env cl in - Tstr_class - (List.map (fun cls -> - (cls.Typeclass.cls_info, - cls.Typeclass.cls_pub_methods)) classes), -(* TODO: check with Jacques why this is here - Tstr_class_type - (List.map (fun (_,_, i, d, _,_,_,_,_,_,c) -> (i, c)) classes) :: - Tstr_type - (List.map (fun (_,_,_,_, i, d, _,_,_,_,_) -> (i, d)) classes) :: - Tstr_type - (List.map (fun (_,_,_,_,_,_, i, d, _,_,_) -> (i, d)) classes) :: -*) - List.flatten - (map_rec - (fun rs cls -> - let open Typeclass in - [Sig_class(cls.cls_id, cls.cls_decl, rs); - Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs); - Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs); - Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs)]) - classes []), - new_env - | Pstr_class_type cl -> - List.iter - (fun {pci_name} -> check_name check_type names pci_name) - cl; - let (classes, new_env) = Typeclass.class_type_declarations env cl in - Tstr_class_type - (List.map (fun cl -> - (cl.Typeclass.clsty_ty_id, - cl.Typeclass.clsty_id_loc, - cl.Typeclass.clsty_info)) classes), -(* TODO: check with Jacques why this is here - Tstr_type - (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) :: - Tstr_type - (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: *) - List.flatten - (map_rec - (fun rs decl -> - let open Typeclass in - [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs); - Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs); - Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)]) - classes []), - new_env - | Pstr_include sincl -> - let smodl = sincl.pincl_mod in - let modl = - Builtin_attributes.warning_scope sincl.pincl_attributes - (fun () -> type_module true funct_body None env smodl) - in - (* Rename all identifiers bound by this signature to avoid clashes *) - let sg = Subst.signature Subst.identity - (extract_sig_open env smodl.pmod_loc modl.mod_type) in - List.iter (check_sig_item names loc) sg; - let new_env = Env.add_signature sg env in - let incl = - { incl_mod = modl; - incl_type = sg; - incl_attributes = sincl.pincl_attributes; - incl_loc = sincl.pincl_loc; - } - in - Tstr_include incl, sg, new_env - | Pstr_extension (ext, _attrs) -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) - | Pstr_attribute x -> - Builtin_attributes.warning_attribute x; - Tstr_attribute x, [], env - in let rec type_struct env sstr = - Ctype.init_def(Ident.current_time()); + Ctype.init_def (Ident.current_time()); match sstr with | [] -> ([], [], env) - | pstr :: srem -> - let previous_saved_types = Cmt_format.get_saved_types () in - let desc, sg, new_env = type_str_item env srem pstr in - let str = { str_desc = desc; str_loc = pstr.pstr_loc; str_env = env } in - Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str - :: previous_saved_types); - let (str_rem, sig_rem, final_env) = type_struct new_env srem in - (str :: str_rem, sg @ sig_rem, final_env) + | {pstr_desc = desc; pstr_loc = loc} :: srem -> + match desc with + | Pstr_eval (sexpr, attrs) -> + let expr = + Builtin_attributes.warning_scope attrs + (fun () -> Typecore.type_expression env sexpr) + in + let str_rem, sig_rem, final_env = type_struct env srem in + mkstr (Tstr_eval (expr, attrs)) env loc :: str_rem, + sig_rem, final_env + | Pstr_value(rec_flag, sdefs) -> + let scope = + match rec_flag with + | Recursive -> + Some (Annot.Idef {scope with + Location.loc_start = loc.Location.loc_start}) + | Nonrecursive -> + let start = + match srem with + | [] -> loc.Location.loc_end + | {pstr_loc = loc2} :: _ -> loc2.Location.loc_start + in + Some (Annot.Idef {scope with Location.loc_start = start}) + in + let (defs, newenv) = + Typecore.type_binding env rec_flag sdefs scope in + let () = if rec_flag = Recursive then + Typecore.check_recursive_bindings env defs + in + let str_rem, sig_rem, final_env = type_struct newenv srem in + (* Note: Env.find_value does not trigger the value_used event. Values + will be marked as being used during the signature inclusion test. *) + mkstr (Tstr_value(rec_flag, defs)) newenv loc :: str_rem, + (List.map (fun id -> Sig_value(id, Env.find_value (Pident id) newenv)) + (let_bound_idents defs)) @ sig_rem, final_env + | Pstr_primitive sdesc -> + let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in + let str_rem, sig_rem, final_env = type_struct newenv srem in + mkstr (Tstr_primitive desc) newenv loc :: str_rem, + [Sig_value(desc.val_id, desc.val_val)] @ sig_rem, final_env + | Pstr_type (rec_flag, sdecls) -> + List.iter + (fun decl -> check_name check_type names decl.ptype_name) + sdecls; + let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in + let newenv = enrich_type_decls anchor decls env newenv in + let str_rem, sig_rem, final_env = type_struct newenv srem in + mkstr (Tstr_type (rec_flag, decls)) newenv loc :: str_rem, + (map_rec_type_with_row_types ~rec_flag + (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs)) + decls []) @ sig_rem, final_env + | Pstr_typext styext -> + List.iter + (fun pext -> check_name check_typext names pext.pext_name) + styext.ptyext_constructors; + let (tyext, newenv) = + Typedecl.transl_type_extension true env loc styext + in + let str_rem, sig_rem, final_env = type_struct newenv srem in + mkstr (Tstr_typext tyext) newenv loc :: str_rem, + (map_ext + (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es)) + tyext.tyext_constructors []) @ sig_rem, final_env + | Pstr_exception sext -> + check_name check_typext names sext.pext_name; + let (ext, newenv) = Typedecl.transl_exception env sext in + let str_rem, sig_rem, final_env = type_struct newenv srem in + mkstr (Tstr_exception ext) newenv loc :: str_rem, + [Sig_typext(ext.ext_id, ext.ext_type, Text_exception)] @ sig_rem, + final_env + | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs; + pmb_loc; + } -> + check_name check_module names name; + let id = Ident.create name.txt in (* create early for PR#6752 *) + let modl = + Builtin_attributes.warning_scope attrs + (fun () -> + type_module ~alias:true true funct_body + (anchor_submodule name.txt anchor) env smodl + ) + in + let md = + { md_type = enrich_module_type anchor name.txt modl.mod_type env; + md_attributes = attrs; + md_loc = pmb_loc; + } + in + (*prerr_endline (Ident.unique_toplevel_name id);*) + Mtype.lower_nongen (Ident.binding_time id - 1) md.md_type; + let newenv = Env.enter_module_declaration id md env in + let str_rem, sig_rem, final_env = type_struct newenv srem in + mkstr (Tstr_module {mb_id=id; mb_name=name; mb_expr=modl; + mb_attributes=attrs; mb_loc=pmb_loc; + }) newenv loc :: str_rem, + Sig_module(id, + {md_type = remove_inserted_modtype modl.mod_type; + md_attributes = attrs; + md_loc = pmb_loc; + }, Trec_not) :: sig_rem, + final_env + | Pstr_recmodule sbind -> + let sbind = + List.map + (function + | {pmb_name = name; + pmb_expr = {pmod_desc=Pmod_constraint(expr, typ)}; + pmb_attributes = attrs; + pmb_loc = loc; + } -> + name, typ, expr, attrs, loc + | mb -> + raise (Error (mb.pmb_expr.pmod_loc, env, + Recursive_module_require_explicit_type)) + ) + sbind + in + List.iter + (fun (name, _, _, _, _) -> check_name check_module names name) + sbind; + let (decls, newenv) = + transl_recmodule_modtypes env + (List.map (fun (name, smty, _smodl, attrs, loc) -> + {pmd_name=name; pmd_type=smty; + pmd_attributes=attrs; pmd_loc=loc}) sbind + ) in + let bindings1 = + List.map2 + (fun {md_id=id; md_type=mty} (name, _, smodl, attrs, loc) -> + let modl = + Builtin_attributes.warning_scope attrs + (fun () -> + type_module true funct_body (anchor_recmodule id) + newenv smodl + ) + in + let mty' = + enrich_module_type anchor (Ident.name id) modl.mod_type newenv + in + (id, name, mty, modl, mty', attrs, loc)) + decls sbind in + let newenv = (* allow aliasing recursive modules from outside *) + List.fold_left + (fun env md -> + let mdecl = + { + md_type = md.md_type.mty_type; + md_attributes = md.md_attributes; + md_loc = md.md_loc; + } + in + Env.add_module_declaration ~check:true md.md_id mdecl env + ) + env decls + in + let str_rem, sig_rem, final_env = type_struct newenv srem in + let bindings2 = + check_recmodule_inclusion newenv bindings1 in + mkstr (Tstr_recmodule bindings2) newenv loc :: str_rem, + (map_rec (fun rs mb -> + Sig_module(mb.mb_id, { + md_type=mb.mb_expr.mod_type; + md_attributes=mb.mb_attributes; + md_loc=mb.mb_loc; + }, rs)) + bindings2 []) @ sig_rem, + final_env + | Pstr_modtype pmtd -> + (* check that it is non-abstract *) + let newenv, mtd, sg = + transl_modtype_decl names env pmtd + in + let str_rem, sig_rem, final_env = type_struct newenv srem in + mkstr (Tstr_modtype mtd) newenv loc :: str_rem, sg :: sig_rem, + final_env + | Pstr_open sod -> + let (inserted_md, od) = type_open ~toplevel env sod in + let open_env = od.open_env in + let str_rem, sig_rem, final_env = type_struct open_env srem in + begin + match inserted_md with + | None -> mkstr (Tstr_open od) open_env loc :: str_rem, + sig_rem, final_env + | Some (id, md, md_env) -> + let tm = + Tstr_module {mb_id=id; + mb_name={txt=Ident.name id; loc=Location.none}; + mb_expr = od.open_expr; + mb_attributes=od.open_expr.mod_attributes; + mb_loc=od.open_expr.mod_loc} in + let tm_str = { str_desc = tm; str_loc = loc; + str_env = md_env } in + let open_str = mkstr (Tstr_open od) open_env loc in + let md_sig = + Sig_module (id, {md_type=md.Types.md_type; md_loc=loc; + md_attributes = []}, Trec_not) in + let sg = + if not (in_nested_struct ()) then + let s_rem = Mty_signature sig_rem in + match Mtype.nondep_supertype open_env id s_rem with + | Mty_signature sg -> sg + | exception Not_found -> + raise (Error(loc, env, + Cannot_eliminate_anon_module(id, sig_rem))) + | Mty_ident _ | Mty_functor _ | Mty_alias _ -> assert false + else sig_rem in + tm_str :: open_str :: str_rem, md_sig :: sg, final_env + end + | Pstr_class cl -> + List.iter + (fun {pci_name} -> check_name check_type names pci_name) + cl; + let (classes, new_env) = Typeclass.class_declarations env cl in + let str_rem, sig_rem, final_env = type_struct new_env srem in + mkstr + (Tstr_class + (List.map (fun cls -> + (cls.Typeclass.cls_info, + cls.Typeclass.cls_pub_methods)) classes)) + new_env loc :: str_rem, + (* TODO: check with Jacques why this is here + Tstr_class_type + (List.map (fun (_,_, i, d, _,_,_,_,_,_,c) -> (i, c)) classes) :: + Tstr_type + (List.map (fun (_,_,_,_, i, d, _,_,_,_,_) -> (i, d)) classes) :: + Tstr_type + (List.map (fun (_,_,_,_,_,_, i, d, _,_,_) -> (i, d)) classes) :: + *) + (List.flatten + (map_rec + (fun rs cls -> + let open Typeclass in + [Sig_class(cls.cls_id, cls.cls_decl, rs); + Sig_class_type(cls.cls_ty_id, cls.cls_ty_decl, rs); + Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs); + Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs)]) + classes [])) @ sig_rem, + final_env + | Pstr_class_type cl -> + List.iter + (fun {pci_name} -> check_name check_type names pci_name) + cl; + let (classes, new_env) = Typeclass.class_type_declarations env cl in + let str_rem, sig_rem, final_env = type_struct new_env srem in + mkstr + (Tstr_class_type + (List.map (fun cl -> + (cl.Typeclass.clsty_ty_id, + cl.Typeclass.clsty_id_loc, + cl.Typeclass.clsty_info)) classes)) new_env loc :: str_rem, + (* TODO: check with Jacques why this is here + Tstr_type + (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) :: + Tstr_type + (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: *) + (List.flatten + (map_rec + (fun rs decl -> + let open Typeclass in + [Sig_class_type(decl.clsty_ty_id, decl.clsty_ty_decl, rs); + Sig_type(decl.clsty_obj_id, decl.clsty_obj_abbr, rs); + Sig_type(decl.clsty_typesharp_id, decl.clsty_abbr, rs)]) + classes [])) @ sig_rem, + final_env + | Pstr_include sincl -> + let smodl = sincl.pincl_mod in + let modl = + Builtin_attributes.warning_scope sincl.pincl_attributes + (fun () -> type_module true funct_body None env smodl) + in + (* Rename all identifiers bound by this signature to avoid clashes *) + let sg = Subst.signature Subst.identity + (extract_sig_open env smodl.pmod_loc modl.mod_type) in + List.iter (check_sig_item names loc) sg; + let new_env = Env.add_signature sg env in + let str_rem, sig_rem, final_env = type_struct new_env srem in + let incl = + { incl_mod = modl; + incl_type = sg; + incl_attributes = sincl.pincl_attributes; + incl_loc = sincl.pincl_loc; + } + in + mkstr (Tstr_include incl) new_env loc :: str_rem, + sg @ sig_rem, final_env + | Pstr_extension (ext, _attrs) -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + | Pstr_attribute x -> + Builtin_attributes.warning_attribute x; + let str_rem, sig_rem, final_env = type_struct env srem in + mkstr (Tstr_attribute x) env loc :: str_rem, sig_rem, final_env in if !Clflags.annotations then (* moved to genannot *) @@ -1723,7 +1849,9 @@ and type_structure ?(toplevel = false) funct_body anchor env sstr scope = let type_toplevel_phrase env s = Env.reset_required_globals (); let (str, sg, env) = - type_structure ~toplevel:true false None env s Location.none in + Misc.protect_refs [R(open_struct_level, 0)] + (fun () -> + type_structure ~toplevel:true false None env s Location.none) in let (str, _coerce) = ImplementationHooks.apply_hooks { Misc.sourcefile = "//toplevel//" } (str, Tcoerce_none) in @@ -1816,85 +1944,117 @@ let type_package env m p nl = (wrap_constraint env true modl mty Tmodtype_implicit, tl') (* Fill in the forward declarations *) + +let type_open ?used_slot ovf env loc me = + type_open_ ?used_slot ?toplevel:None ovf env loc me + +let gen_mod_ident me = + match me.pmod_desc with + | Pmod_functor _ | Pmod_extension _ | Pmod_ident _ -> None + | Pmod_structure _ | Pmod_apply _ | Pmod_constraint _ | Pmod_unpack _ -> + Some(gen_mod_ident ()) + let () = Typecore.type_module := type_module_alias; Typetexp.transl_modtype_longident := transl_modtype_longident; Typetexp.transl_modtype := transl_modtype; - Typecore.type_open := type_open_ ?toplevel:None; + Typecore.type_open := type_open; Typecore.type_package := type_package; + Typecore.gen_mod_ident := gen_mod_ident; + type_module_fwd := type_module; type_module_type_of_fwd := type_module_type_of (* Typecheck an implementation file *) +let simplify_signature sg = + let rec aux = function + | [] -> [], StringSet.empty + | (Sig_value(id, _descr) as component) :: sg -> + let (sg, val_names) as k = aux sg in + let name = Ident.name id in + if StringSet.mem name val_names then k + else (component :: sg, StringSet.add name val_names) + | Sig_module({Ident.name}, _, _) :: sg + when open_generated name -> aux sg + | component :: sg -> + let (sg, val_names) = aux sg in + (component :: sg, val_names) + in + let (sg, _) = aux sg in + sg + let type_implementation sourcefile outputprefix modulename initial_env ast = - Cmt_format.clear (); - try - Typecore.reset_delayed_checks (); - Env.reset_required_globals (); - if !Clflags.print_types then (* #7656 *) - Warnings.parse_options false "-32-34-37-38-60"; - let (str, sg, finalenv) = - type_structure initial_env ast (Location.in_file sourcefile) in - let simple_sg = simplify_signature sg in - if !Clflags.print_types then begin - Typecore.force_delayed_checks (); - Printtyp.wrap_printing_env ~error:false initial_env - (fun () -> fprintf std_formatter "%a@." Printtyp.signature simple_sg); - (str, Tcoerce_none) (* result is ignored by Compile.implementation *) - end else begin - let sourceintf = - Filename.remove_extension sourcefile ^ !Config.interface_suffix in - if Sys.file_exists sourceintf then begin - let intf_file = - try - find_in_path_uncap !Config.load_path (modulename ^ ".cmi") - with Not_found -> - raise(Error(Location.in_file sourcefile, Env.empty, - Interface_not_compiled sourceintf)) in - let dclsig = Env.read_signature modulename intf_file in - let coercion = - Includemod.compunit initial_env ~mark:Includemod.Mark_positive - sourcefile sg intf_file dclsig - in + Misc.protect_refs [R(open_struct_level, 0); R(mod_ident_counter, 0)] + (fun () -> + Cmt_format.clear (); + try + Typecore.reset_delayed_checks (); + Env.reset_required_globals (); + if !Clflags.print_types then (* #7656 *) + Warnings.parse_options false "-32-34-37-38-60"; + let (str, sg, finalenv) = + type_structure initial_env ast (Location.in_file sourcefile) in + let simple_sg = simplify_signature sg in + if !Clflags.print_types then begin Typecore.force_delayed_checks (); - (* It is important to run these checks after the inclusion test above, - so that value declarations which are not used internally but exported - are not reported as being unused. *) - Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - (Cmt_format.Implementation str) (Some sourcefile) initial_env None; - (str, coercion) + Printtyp.wrap_printing_env ~error:false initial_env + (fun () -> fprintf std_formatter "%a@." Printtyp.signature simple_sg); + (str, Tcoerce_none) (* result is ignored by Compile.implementation *) end else begin - let coercion = - Includemod.compunit initial_env ~mark:Includemod.Mark_positive - sourcefile sg "(inferred signature)" simple_sg - in - check_nongen_schemes finalenv simple_sg; - normalize_signature finalenv simple_sg; - Typecore.force_delayed_checks (); - (* See comment above. Here the target signature contains all - the value being exported. We can still capture unused - declarations like "let x = true;; let x = 1;;", because in this - case, the inferred signature contains only the last declaration. *) - if not !Clflags.dont_write_files then begin - let deprecated = Builtin_attributes.deprecated_of_str ast in - let cmi = - Env.save_signature ~deprecated - simple_sg modulename (outputprefix ^ ".cmi") + let sourceintf = + Filename.remove_extension sourcefile ^ !Config.interface_suffix in + if Sys.file_exists sourceintf then begin + let intf_file = + try + find_in_path_uncap !Config.load_path (modulename ^ ".cmi") + with Not_found -> + raise(Error(Location.in_file sourcefile, Env.empty, + Interface_not_compiled sourceintf)) in + let dclsig = Env.read_signature modulename intf_file in + let coercion = + Includemod.compunit initial_env ~mark:Includemod.Mark_positive + sourcefile sg intf_file dclsig in - Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - (Cmt_format.Implementation str) - (Some sourcefile) initial_env (Some cmi); - end; - (str, coercion) - end - end - with e -> - Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - (Cmt_format.Partial_implementation - (Array.of_list (Cmt_format.get_saved_types ()))) - (Some sourcefile) initial_env None; - raise e + Typecore.force_delayed_checks (); + (* It is important to run these checks after the inclusion test above, + so that value declarations which are not used internally but exported + are not reported as being unused. *) + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Implementation str) (Some sourcefile) initial_env None; + (str, coercion) + end else begin + let coercion = + Includemod.compunit initial_env ~mark:Includemod.Mark_positive + sourcefile sg "(inferred signature)" simple_sg + in + check_nongen_schemes finalenv simple_sg; + normalize_signature finalenv simple_sg; + Typecore.force_delayed_checks (); + (* See comment above. Here the target signature contains all + the value being exported. We can still capture unused + declarations like "let x = true;; let x = 1;;", because in this + case, the inferred signature contains only the last declaration. *) + if not !Clflags.dont_write_files then begin + let deprecated = Builtin_attributes.deprecated_of_str ast in + let cmi = + Env.save_signature ~deprecated + simple_sg modulename (outputprefix ^ ".cmi") + in + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Implementation str) + (Some sourcefile) initial_env (Some cmi); + end; + (str, coercion) + end + end + with e -> + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Partial_implementation + (Array.of_list (Cmt_format.get_saved_types ()))) + (Some sourcefile) initial_env None; + raise e + ) let type_implementation sourcefile outputprefix modulename initial_env ast = ImplementationHooks.apply_hooks { Misc.sourcefile } @@ -2073,6 +2233,9 @@ let report_error ppf = function fprintf ppf "This is an alias for module %a, which is missing" path p + | Cannot_eliminate_anon_module (id, sg) -> + fprintf ppf "The module identifier %a cannot be \ + eliminated from %a" ident id signature sg 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 68d2103e66f5..78e101b1999a 100644 --- a/typing/typemod.mli +++ b/typing/typemod.mli @@ -37,8 +37,10 @@ val check_nongen_schemes: Env.t -> Types.signature -> unit val type_open_: ?used_slot:bool ref -> ?toplevel:bool -> - Asttypes.override_flag -> - Env.t -> Location.t -> Longident.t Asttypes.loc -> Path.t * Env.t + Asttypes.override_flag -> Env.t -> Location.t -> + Parsetree.module_expr -> + (Ident.t * Types.module_declaration * Env.t) option * + Typedtree.module_expr * Env.t val modtype_of_package: Env.t -> Location.t -> Path.t -> Longident.t list -> type_expr list -> module_type @@ -84,6 +86,7 @@ type error = | Recursive_module_require_explicit_type | Apply_generative | Cannot_scrape_alias of Path.t + | Cannot_eliminate_anon_module of Ident.t * signature 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 e4ec51ce45b8..4f12df7b7676 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -136,7 +136,7 @@ let open_description sub od = let attrs = sub.attributes sub od.open_attributes in Opn.mk ~loc ~attrs ~override:od.open_override - (map_loc sub od.open_txt) + (sub.module_expr sub od.open_expr) let structure_item sub item = let loc = sub.location sub item.str_loc in @@ -329,8 +329,8 @@ let exp_extra sub (extra, loc, attrs) sexp = sub.typ sub cty2) | Texp_constraint cty -> Pexp_constraint (sexp, sub.typ sub cty) - | Texp_open (ovf, _path, lid, _) -> - Pexp_open (ovf, map_loc sub lid, sexp) + | Texp_open od -> + Pexp_open (od.open_override, sub.module_expr sub od.open_expr, sexp) | Texp_poly cto -> Pexp_poly (sexp, map_opt (sub.typ sub) cto) | Texp_newtype s -> Pexp_newtype (mkloc s loc, sexp) in @@ -634,8 +634,8 @@ let class_expr sub cexpr = | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) -> Pcl_constraint (sub.class_expr sub cl, sub.class_type sub clty) - | Tcl_open (ovf, _p, lid, _env, e) -> - Pcl_open (ovf, lid, sub.class_expr sub e) + | Tcl_open (od, e) -> + Pcl_open (od.open_override, sub.module_expr sub od.open_expr, sub.class_expr sub e) | Tcl_ident _ -> assert false | Tcl_constraint (_, None, _, _, _) -> assert false @@ -651,8 +651,8 @@ let class_type sub ct = Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list) | Tcty_arrow (label, ct, cl) -> Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl) - | Tcty_open (ovf, _p, lid, _env, e) -> - Pcty_open (ovf, lid, sub.class_type sub e) + | Tcty_open (od, e) -> + Pcty_open (od.open_override, sub.module_expr sub od.open_expr, sub.class_type sub e) in Cty.mk ~loc ~attrs desc