From ca3e30f3874071fb49cb3a9d47cf0bd72ac0ac0b Mon Sep 17 00:00:00 2001 From: Zesen Qian Date: Wed, 27 Aug 2025 14:05:54 +0100 Subject: [PATCH 1/4] add missing parsing for modal modules --- lib/Ast.ml | 8 +- lib/Exposed.ml | 2 +- lib/Fmt_ast.ml | 112 +++++++++++----------- test/passing/tests/module_modes.ml | 47 +++++++++ test/passing/tests/module_modes.ml.js-ref | 55 +++++++++++ test/passing/tests/module_modes.ml.ref | 56 +++++++++++ vendor/parser-extended/ast_helper.ml | 5 +- vendor/parser-extended/ast_mapper.ml | 6 +- vendor/parser-extended/parser.mly | 20 ++-- vendor/parser-extended/parsetree.mli | 4 +- vendor/parser-extended/printast.ml | 4 +- vendor/parser-standard/parser.mly | 5 +- 12 files changed, 246 insertions(+), 78 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index 07ea090f4a..b6eabe098a 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -1585,7 +1585,7 @@ end = struct |Pexp_unboxed_field (e, _) |Pexp_lazy e |Pexp_letexception (_, e) - |Pexp_letmodule (_, _, _, e) + |Pexp_letmodule (_, _, _, _, e) |Pexp_newtype (_, e) |Pexp_open (_, e) |Pexp_letopen (_, e) @@ -2291,7 +2291,7 @@ end = struct | Pexp_let (_, e) |Pexp_letop {body= e; _} |Pexp_letexception (_, e) - |Pexp_letmodule (_, _, _, e) -> ( + |Pexp_letmodule (_, _, _, _, e) -> ( match cls with Match | Then | ThenElse -> continue e | _ -> false ) | Pexp_match _ when match cls with Then -> true | _ -> false -> false @@ -2370,7 +2370,7 @@ end = struct | Pexp_let (_, e) |Pexp_letop {body= e; _} |Pexp_letexception (_, e) - |Pexp_letmodule (_, _, _, e) -> + |Pexp_letmodule (_, _, _, _, e) -> continue e | Pexp_ifthenelse (eN, None) -> continue (List.last_exn eN).if_body | Pexp_extension (ext, PStr [{pstr_desc= Pstr_eval (e, _); _}]) @@ -2461,7 +2461,7 @@ end = struct | Exp {pexp_desc; _} -> ( match pexp_desc with | Pexp_let (_, e) - |Pexp_letmodule (_, _, _, e) + |Pexp_letmodule (_, _, _, _, e) |Pexp_letexception (_, e) |Pexp_letopen (_, e) |Pexp_open (_, e) diff --git a/lib/Exposed.ml b/lib/Exposed.ml index 71902b5e25..5bd04d0de7 100644 --- a/lib/Exposed.ml +++ b/lib/Exposed.ml @@ -176,7 +176,7 @@ module Right_square = struct | Pexp_ifthenelse (_, Some exp) -> expression exp | Pexp_sequence (_, exp) -> expression exp | Pexp_setinstvar (_, exp) -> expression exp - | Pexp_letmodule (_, _, _, exp) -> expression exp + | Pexp_letmodule (_, _, _, _, exp) -> expression exp | Pexp_letexception (_, exp) -> expression exp | Pexp_assert exp -> expression exp | Pexp_lazy exp -> expression exp diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index f322de7f69..bef973f606 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -640,6 +640,38 @@ let let_binding_can_be_punned ~binding ~is_ext = true | _ -> false +let extract_module_binding_constraints c ctx args modes body = + let xbody = sub_mod ~ctx body in + let xbody, xmty, xmodes = + match xbody.ast with + | { pmod_desc= Pmod_constraint (body_me, body_mt, body_mm) + ; pmod_loc + ; pmod_attributes= [] } -> + let xbody = sub_mod ~ctx body_me in + let xmty, after = + match body_mt with + | None -> (None, body_me.pmod_loc) + | Some body_mt -> (Some (sub_mty ~ctx body_mt), body_mt.pmty_loc) + in + Cmts.relocate c.cmts ~src:pmod_loc ~before:body_me.pmod_loc ~after ; + (xbody, xmty, body_mm) + | _ -> (xbody, None, []) + in + (* [xmodes_id] is the modes on the identifier, while [xmodes] is the modes + on the RHS. For example, [module (F @ xmodes_id) () @ xmodes = ...]. *) + let xmodes_id, xmodes = + match (args, xmodes) with + | [], [] -> + (* If there is no argument, then [xmodes_id] and [xmodes] are the + same thing, in which case we prefer [xmodes]. But we don't want to + reduce [module (M @ foo) @ bar = ...] to [module M @ foo bar = + ...] because that would be viewed as changed AST by the standard + parser. *) + ([], modes) + | _ -> (modes, xmodes) + in + (xmodes_id, xmty, xmodes, xbody) + let rec fmt_extension_aux c ctx ~key (ext, pld) = match (ext.txt, pld, ctx) with (* Quoted extensions (since ocaml 4.11). *) @@ -2839,25 +2871,10 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens $ fmt "@;<1000 0>" $ fmt_expression c (sub_exp ~ctx exp) ) $ fmt_atrs ) - | Pexp_letmodule (name, args, pmod, exp) -> + | Pexp_letmodule (name, modes, args, pmod, exp) -> let keyword = "let module" in - let xbody = sub_mod ~ctx pmod in - let xbody, xmty, xmmodes = - match xbody.ast with - | { pmod_desc= Pmod_constraint (body_me, body_mt, body_mm) - ; pmod_loc - ; pmod_attributes= [] } -> - let xbody = sub_mod ~ctx body_me in - let xmty, after = - match body_mt with - | None -> (None, body_me.pmod_loc) - | Some body_mt -> - (Some (sub_mty ~ctx body_mt), body_mt.pmty_loc) - in - Cmts.relocate c.cmts ~src:pmod_loc ~before:body_me.pmod_loc - ~after ; - (xbody, xmty, body_mm) - | _ -> (xbody, None, []) + let xmodes_id, xmty, xmodes, xbody = + extract_module_binding_constraints c ctx args modes pmod in let can_sparse = match xbody.ast.pmod_desc with @@ -2870,8 +2887,8 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens (parens || not (List.is_empty pexp_attributes)) c.conf ( hvbox 2 - (fmt_module c ctx keyword ~eqty:":" name (Modes xmmodes) - args (Some xbody) xmty + (fmt_module c ctx keyword ~eqty:":" name (Modes xmodes_id) + args (Some xbody) xmty (Modes xmodes) ~attrs:(Ast_helper.Attr.ext_attrs ?ext ()) ~epi:(str "in") ~can_sparse ~rec_flag:false ) $ fmt "@;<1000 0>" @@ -4569,7 +4586,7 @@ and fmt_class_exprs ?ext c ctx cls = @@ Cmts.fmt c cl.pci_loc (doc_before $ class_exprs $ doc_after) ) and fmt_module c ctx ?rec_ ?epi ?(can_sparse = false) keyword ?(eqty = "=") - name modals xargs xbody xmty ~attrs ~rec_flag = + name modals_id xargs xbody xmty modals ~attrs ~rec_flag = let ext = attrs.attrs_extension in let blk_t = Option.value_map xmty ~default:empty ~f:(fun xmty -> @@ -4579,20 +4596,11 @@ and fmt_module c ctx ?rec_ ?epi ?(can_sparse = false) keyword ?(eqty = "=") Some (str " " $ str eqty $ opt blk.pro (fun pro -> str " " $ pro)) ; psp= fmt_if (Option.is_none blk.pro) "@;<1 2>" $ blk.psp } ) in - let fmt_name, fmt_trailing_modals = - match modals with - | Modes _ -> - (* [module M : S @ m = M] *) - (fmt_str_loc_opt c name, fmt_modals c modals) - | Modalities _ -> - (* [module (M @@ m) : S] *) - ( wrap_if - (not (is_empty_modals modals)) - "(" ")" - (fmt_str_loc_opt c name $ fmt_modals c modals) - , noop ) - | No_modals -> (fmt_str_loc_opt c name, noop) - | Mode_crossing _ -> assert false + let fmt_name = + wrap_if + (not (is_empty_modals modals_id)) + "(" ")" + (fmt_str_loc_opt c name $ fmt_modals c modals_id) in let blk_b = Option.value_map xbody ~default:empty ~f:(fmt_module_expr c) in let fmt_name_and_mt ~pro ~loc name mt = @@ -4656,7 +4664,7 @@ and fmt_module c ctx ?rec_ ?epi ?(can_sparse = false) keyword ?(eqty = "=") ( hvbox args_p.indent (fmt_args ~pro:intro xargs $ fmt_opt blk_t.pro) $ blk_t.psp $ blk_t.bdy ) - $ blk_t.esp $ fmt_opt blk_t.epi $ fmt_trailing_modals + $ blk_t.esp $ fmt_opt blk_t.epi $ fmt_modals c modals $ fmt_if (Option.is_some xbody) " =" $ fmt_if_k compact fmt_pro ) $ fmt_if_k (not compact) fmt_pro @@ -4697,7 +4705,7 @@ and fmt_module_declaration c ~rec_flag ~first {ast= pmd; _} = in Cmts.fmt c pmd_loc (fmt_module ~rec_:rec_flag c ctx keyword pmd_name - (Modalities pmd_modalities) pmd_args None ?eqty (Some xmty) + (Modalities pmd_modalities) pmd_args None ?eqty (Some xmty) No_modals ~rec_flag:(rec_flag && first) ~attrs ) and fmt_module_substitution c ctx pms = @@ -4714,7 +4722,7 @@ and fmt_module_substitution c ctx pms = let pms_name = {pms_name with txt= Some pms_name.txt} in Cmts.fmt c pms_loc (fmt_module c ctx "module" ~eqty:":=" pms_name No_modals [] None - (Some xmty) ~attrs ~rec_flag:false ) + (Some xmty) No_modals ~attrs ~rec_flag:false ) and fmt_module_type_declaration ?eqty c ctx pmtd = let {pmtd_name; pmtd_type; pmtd_ext_attrs= attrs; pmtd_loc} = pmtd in @@ -4724,7 +4732,7 @@ and fmt_module_type_declaration ?eqty c ctx pmtd = fmt_module ?eqty c ctx "module type" pmtd_name No_modals [] None ~rec_flag:false (Option.map pmtd_type ~f:(sub_mty ~ctx)) - ~attrs + No_modals ~attrs and fmt_open_description ?ext c ?(keyword = "open") ~kw_attributes {popen_expr= popen_lid; popen_override; popen_attributes; popen_loc} = @@ -4787,14 +4795,14 @@ and fmt_with_constraint c ctx ~pre = function let m2 = Some (sub_mty ~ctx m2) in str pre $ break 1 2 $ fmt_module c ctx "module type" m1 No_modals [] None ~rec_flag:false - m2 + m2 No_modals ~attrs:(Ast_helper.Attr.ext_attrs ()) | Pwith_modtypesubst (m1, m2) -> let m1 = {m1 with txt= Some (str_longident m1.txt)} in let m2 = Some (sub_mty ~ctx m2) in str pre $ break 1 2 $ fmt_module c ctx ~eqty:":=" "module type" m1 No_modals [] None - ~rec_flag:false m2 + ~rec_flag:false m2 No_modals ~attrs:(Ast_helper.Attr.ext_attrs ()) and fmt_mod_apply c ctx loc attrs ~parens ~dock_struct me_f arg = @@ -5361,26 +5369,14 @@ and fmt_module_binding c ~rec_flag ~first {ast= pmb; _} = @@ fun c -> let ctx = Mb pmb in let keyword = if first then "module" else "and" in - let xbody = sub_mod ~ctx pmb.pmb_expr in - let xbody, xmty, xmodes = - match xbody.ast with - | { pmod_desc= Pmod_constraint (body_me, body_mt, body_mm) - ; pmod_loc - ; pmod_attributes= [] } -> - let xbody = sub_mod ~ctx body_me in - let xmty, after = - match body_mt with - | None -> (None, body_me.pmod_loc) - | Some body_mt -> (Some (sub_mty ~ctx body_mt), body_mt.pmty_loc) - in - Cmts.relocate c.cmts ~src:pmod_loc ~before:body_me.pmod_loc ~after ; - (xbody, xmty, body_mm) - | _ -> (xbody, None, []) + let xmodes_id, xmty, xmodes, xbody = + extract_module_binding_constraints c ctx pmb.pmb_args pmb.pmb_modes + pmb.pmb_expr in Cmts.fmt c pmb.pmb_loc (fmt_module ~rec_:rec_flag c ctx keyword ~rec_flag:(rec_flag && first) - ~eqty:":" pmb_name (Modes xmodes) pmb.pmb_args (Some xbody) xmty - ~attrs ) + ~eqty:":" pmb_name (Modes xmodes_id) pmb.pmb_args (Some xbody) xmty + (Modes xmodes) ~attrs ) let fmt_toplevel_directive c ~semisemi dir = let fmt_dir_arg = function diff --git a/test/passing/tests/module_modes.ml b/test/passing/tests/module_modes.ml index 191bc9bebb..15a8fa6428 100644 --- a/test/passing/tests/module_modes.ml +++ b/test/passing/tests/module_modes.ml @@ -70,3 +70,50 @@ let () = let () = let module (* 38 *) M (* 39 *) @ (* 40 *) m (* 41 *) = (* 42 *) M (* 43 *) in () + +module (M @ foo) = struct end + +module (M @ foo) : S = struct end + +module (M @ foo) @ bar = struct end + +module (M @ foo) : S @ bar = struct end + +module (F @ foo) () = struct end + +module (F @ foo) () : S = struct end + +module (F @ foo) () @ bar = struct end + +module (F @ foo) () : S @ bar = struct end + +module rec (M @ foo) : S @ bar = struct end +and (N @ foo) : S @ bar = struct end + +module rec (F @ foo) () : S @ bar = struct end +and (G @ foo) () : S @ bar = struct end + + +let () = + let module (M @ foo) = struct end in () + +let () = + let module (M @ foo) : S = struct end in () + +let () = + let module (M @ foo) @ bar = struct end in () + +let () = + let module (M @ foo) : S @ bar = struct end in () + +let () = + let module (F @ foo) () = struct end in () + +let () = + let module (F @ foo) () : S = struct end in () + +let () = + let module (F @ foo) () @ bar = struct end in () + +let () = + let module (F @ foo) () : S @ bar = struct end in () diff --git a/test/passing/tests/module_modes.ml.js-ref b/test/passing/tests/module_modes.ml.js-ref index 374095ef58..924635b9fb 100644 --- a/test/passing/tests/module_modes.ml.js-ref +++ b/test/passing/tests/module_modes.ml.js-ref @@ -105,3 +105,58 @@ let () = in () ;; + +module M @ foo = struct end +module M : S @ foo = struct end +module (M @ foo) @ bar = struct end +module (M @ foo) : S @ bar = struct end +module (F @ foo) () = struct end +module (F @ foo) () : S = struct end +module (F @ foo) () @ bar = struct end +module (F @ foo) () : S @ bar = struct end + +module rec (M @ foo) : S @ bar = struct end +and (N @ foo) : S @ bar = struct end + +module rec (F @ foo) () : S @ bar = struct end +and (G @ foo) () : S @ bar = struct end + +let () = + let module M @ foo = struct end in + () +;; + +let () = + let module M : S @ foo = struct end in + () +;; + +let () = + let module (M @ foo) @ bar = struct end in + () +;; + +let () = + let module (M @ foo) : S @ bar = struct end in + () +;; + +let () = + let module (F @ foo) () = struct end in + () +;; + +let () = + let module (F @ foo) () : S = struct end in + () +;; + +let () = + let module (F @ foo) () @ bar = struct end in + () +;; + +let () = + let module (F @ foo) () : S @ bar = struct end in + () +;; diff --git a/test/passing/tests/module_modes.ml.ref b/test/passing/tests/module_modes.ml.ref index f44751a140..15dc4f8f45 100644 --- a/test/passing/tests/module_modes.ml.ref +++ b/test/passing/tests/module_modes.ml.ref @@ -102,3 +102,59 @@ let () = (* 43 *) in () + +module M @ foo = struct end + +module M : S @ foo = struct end + +module (M @ foo) @ bar = struct end + +module (M @ foo) : S @ bar = struct end + +module (F @ foo) () = struct end + +module (F @ foo) () : S = struct end + +module (F @ foo) () @ bar = struct end + +module (F @ foo) () : S @ bar = struct end + +module rec (M @ foo) : S @ bar = struct end + +and (N @ foo) : S @ bar = struct end + +module rec (F @ foo) () : S @ bar = struct end + +and (G @ foo) () : S @ bar = struct end + +let () = + let module M @ foo = struct end in + () + +let () = + let module M : S @ foo = struct end in + () + +let () = + let module (M @ foo) @ bar = struct end in + () + +let () = + let module (M @ foo) : S @ bar = struct end in + () + +let () = + let module (F @ foo) () = struct end in + () + +let () = + let module (F @ foo) () : S = struct end in + () + +let () = + let module (F @ foo) () @ bar = struct end in + () + +let () = + let module (F @ foo) () : S @ bar = struct end in + () diff --git a/vendor/parser-extended/ast_helper.ml b/vendor/parser-extended/ast_helper.ml index 234547f653..299cc18a0e 100644 --- a/vendor/parser-extended/ast_helper.ml +++ b/vendor/parser-extended/ast_helper.ml @@ -160,7 +160,7 @@ module Exp = struct let indexop_access ?loc ?attrs pia_lhs pia_kind pia_paren pia_rhs = mk ?loc ?attrs (Pexp_indexop_access {pia_lhs; pia_kind; pia_paren; pia_rhs}) let override ?loc ?attrs a = mk ?loc ?attrs (Pexp_override a) - let letmodule ?loc ?attrs a b c d = mk ?loc ?attrs (Pexp_letmodule (a, b, c, d)) + let letmodule ?loc ?attrs a b c d e = mk ?loc ?attrs (Pexp_letmodule (a, b, c, d, e)) let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) let lazy_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_lazy a) @@ -432,9 +432,10 @@ end module Mb = struct let mk ?(loc = !default_loc) ?(attrs=Attr.ext_attrs ()) - ?(docs = empty_docs) ?(text = []) name args expr = + ?(docs = empty_docs) ?(text = []) name modes args expr = { pmb_name = name; + pmb_modes = modes; pmb_args = args; pmb_expr = expr; pmb_ext_attrs = add_text_attrs' text (add_docs_attrs' docs attrs); diff --git a/vendor/parser-extended/ast_mapper.ml b/vendor/parser-extended/ast_mapper.ml index 9a791f7485..477627648b 100644 --- a/vendor/parser-extended/ast_mapper.ml +++ b/vendor/parser-extended/ast_mapper.ml @@ -665,8 +665,9 @@ module E = struct | Pexp_override sel -> override ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) - | Pexp_letmodule (s, args, me, e) -> + | Pexp_letmodule (s, m, args, me, e) -> letmodule ~loc ~attrs (map_loc sub s) + (sub.modes sub m) (List.map (map_functor_param sub) args) (sub.module_expr sub me) (sub.expr sub e) @@ -947,8 +948,9 @@ let default_mapper = ); module_binding = - (fun this {pmb_name; pmb_args; pmb_expr; pmb_ext_attrs; pmb_loc} -> + (fun this {pmb_name; pmb_modes; pmb_args; pmb_expr; pmb_ext_attrs; pmb_loc} -> Mb.mk (map_loc this pmb_name) + (this.modes this pmb_modes) (List.map (map_functor_param this) pmb_args) (this.module_expr this pmb_expr) ~attrs:(this.ext_attrs this pmb_ext_attrs) diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly index 95bed77997..ef64a6b87f 100644 --- a/vendor/parser-extended/parser.mly +++ b/vendor/parser-extended/parser.mly @@ -1697,14 +1697,15 @@ structure_item: %inline module_binding: MODULE ext = ext attrs1 = attributes - name = mkrhs(module_name) + name_ = module_name_modal(at_mode_expr) args = functor_args body = module_binding_body attrs2 = post_item_attributes { let docs = symbol_docs $sloc in let loc = make_loc $sloc in let attrs = Attr.ext_attrs ?ext ~before:attrs1 ~after:attrs2 () in - let body = Mb.mk name args body ~attrs ~loc ~docs in + let name, modes = name_ in + let body = Mb.mk name modes args body ~attrs ~loc ~docs in Pstr_module body } ; @@ -1747,7 +1748,7 @@ module_binding_body: ext = ext attrs1 = attributes REC - name = mkrhs(module_name) + name_ = module_name_modal(at_mode_expr) args = functor_args body = module_binding_body attrs2 = post_item_attributes @@ -1755,7 +1756,8 @@ module_binding_body: let loc = make_loc $sloc in let attrs = Attr.ext_attrs ?ext ~before:attrs1 ~after:attrs2 () in let docs = symbol_docs $sloc in - Mb.mk name args body ~attrs ~loc ~docs + let name, modes = name_ in + Mb.mk name modes args body ~attrs ~loc ~docs } ; @@ -1763,7 +1765,7 @@ module_binding_body: %inline and_module_binding: AND attrs1 = attributes - name = mkrhs(module_name) + name_ = module_name_modal(at_mode_expr) args = functor_args body = module_binding_body attrs2 = post_item_attributes @@ -1772,7 +1774,8 @@ module_binding_body: let attrs = Attr.ext_attrs ~before:attrs1 ~after:attrs2 () in let docs = symbol_docs $sloc in let text = symbol_text $symbolstartpos in - Mb.mk name args body ~attrs ~loc ~text ~docs + let name, modes = name_ in + Mb.mk name modes args body ~attrs ~loc ~text ~docs } ; @@ -2703,8 +2706,9 @@ expr: { mkexp_exclave ~loc:$sloc $2 } ; %inline expr_attrs: - | LET MODULE ext_attributes mkrhs(module_name) functor_args module_binding_body IN seq_expr - { Pexp_letmodule($4, $5, $6, $8), $3 } + | LET MODULE ext_attributes module_name_modal(at_mode_expr) functor_args module_binding_body IN seq_expr + { let name, modes = $4 in + Pexp_letmodule(name, modes, $5, $6, $8), $3 } | LET EXCEPTION ext_attributes let_exception_declaration IN seq_expr { Pexp_letexception($4, $6), $3 } | LET OPEN override_flag ext_attributes module_expr IN seq_expr diff --git a/vendor/parser-extended/parsetree.mli b/vendor/parser-extended/parsetree.mli index 84c4f1ff6a..c74f81b753 100644 --- a/vendor/parser-extended/parsetree.mli +++ b/vendor/parser-extended/parsetree.mli @@ -499,7 +499,7 @@ and expression_desc = | Pexp_setinstvar of label loc * expression (** [x <- 2] *) | Pexp_override of (label loc * expression) list (** [{< x1 = E1; ...; xn = En >}] *) - | Pexp_letmodule of string option loc * functor_parameter loc list * module_expr * expression + | Pexp_letmodule of string option loc * modes * functor_parameter loc list * module_expr * expression (** [let module M = ME in E] *) | Pexp_letexception of extension_constructor * expression (** [let exception C in E] *) @@ -1290,6 +1290,8 @@ and value_bindings = and module_binding = { pmb_name: string option loc; + pmb_modes: modes; + (** The modes on the identifier *) pmb_args: functor_parameter loc list; pmb_expr: module_expr; pmb_ext_attrs : ext_attrs; diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml index 6cdd1a6dfe..a8a7148662 100644 --- a/vendor/parser-extended/printast.ml +++ b/vendor/parser-extended/printast.ml @@ -513,8 +513,9 @@ and expression i ppf x = | Pexp_override (l) -> line i ppf "Pexp_override\n"; list i string_x_expression ppf l; - | Pexp_letmodule (s, args, me, e) -> + | Pexp_letmodule (s, m, args, me, e) -> line i ppf "Pexp_letmodule %a\n" fmt_str_opt_loc s; + modes i ppf m; list i functor_parameter ppf args; module_expr i ppf me; expression i ppf e; @@ -1214,6 +1215,7 @@ and module_declaration i ppf pmd = and module_binding i ppf x = line i ppf "module_binding %a %a\n" fmt_str_opt_loc x.pmb_name fmt_location x.pmb_loc; + modes i ppf x.pmb_modes; list i functor_parameter ppf x.pmb_args; ext_attrs i ppf x.pmb_ext_attrs; module_expr (i+1) ppf x.pmb_expr diff --git a/vendor/parser-standard/parser.mly b/vendor/parser-standard/parser.mly index aef0fdce3c..492b3adfc1 100644 --- a/vendor/parser-standard/parser.mly +++ b/vendor/parser-standard/parser.mly @@ -975,7 +975,10 @@ let unboxed_type sloc lident tys = let maybe_pmod_constraint mode expr = match mode with | [] -> expr - | _ :: _ -> Mod.constraint_ None mode expr + | _ :: _ -> + match expr.pmod_desc with + | Pmod_constraint (me, mty, []) -> { expr with pmod_desc = Pmod_constraint (me, mty, mode) } + | _ -> Mod.constraint_ None mode expr %} /* Tokens */ From 85ef41456470bc2205ee80c2f2d1d8e4935fca0f Mon Sep 17 00:00:00 2001 From: David Vulakh Date: Tue, 2 Sep 2025 18:13:14 -0400 Subject: [PATCH 2/4] prefer modes on identifier when possible when there are no functor args, moving modes from constraint to identifier should not be a semantic change Signed-off-by: David Vulakh --- lib/Fmt_ast.ml | 6 +- lib/Normalize_std_ast.ml | 33 ++++- test/passing/tests/module_modes.ml | 50 ++++++++ test/passing/tests/module_modes.ml.js-ref | 141 ++++++++++++++++---- test/passing/tests/module_modes.ml.ref | 150 ++++++++++++++++++---- vendor/parser-extended/ast_helper.ml | 29 ++++- 6 files changed, 342 insertions(+), 67 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index bef973f606..5e4d2621b6 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -663,11 +663,11 @@ let extract_module_binding_constraints c ctx args modes body = match (args, xmodes) with | [], [] -> (* If there is no argument, then [xmodes_id] and [xmodes] are the - same thing, in which case we prefer [xmodes]. But we don't want to - reduce [module (M @ foo) @ bar = ...] to [module M @ foo bar = + same thing, in which case we prefer [xmodes_id]. But we don't want + to reduce [module (M @ foo) @ bar = ...] to [module M @ foo bar = ...] because that would be viewed as changed AST by the standard parser. *) - ([], modes) + (modes, []) | _ -> (modes, xmodes) in (xmodes_id, xmty, xmodes, xbody) diff --git a/lib/Normalize_std_ast.ml b/lib/Normalize_std_ast.ml index 0855837f5c..e7f9c07ccc 100644 --- a/lib/Normalize_std_ast.ml +++ b/lib/Normalize_std_ast.ml @@ -540,6 +540,36 @@ let make_mapper conf ~ignore_doc_comments ~erase_jane_syntax = } else ca.pca_type ) } in + let module_binding (m : Ast_mapper.mapper) (mb : module_binding) = + (* Special cases: normalize the forms {[ module (M @ m) : S @ l = N ]} to + {[ module (M @ m l) : S = N ]} and {[ module M : S @ m = N ]} to {[ + module (M @ m) : S = N ]} *) + let mb = Ast_mapper.default_mapper.module_binding m mb in + let pmod_desc = + match mb.pmb_expr.pmod_desc with + | Pmod_constraint + ( ( {pmod_desc= Pmod_constraint (expr, mty, outer_modes); _} as + inner_expr ) + , None + , inner_modes ) -> + let inner_expr = + match mty with + | Some _ -> + {inner_expr with pmod_desc= Pmod_constraint (expr, mty, [])} + | None -> expr + in + Pmod_constraint (inner_expr, None, inner_modes @ outer_modes) + | Pmod_constraint (expr, (Some _ as mty), modes) -> + Pmod_constraint + ( { pmod_desc= Pmod_constraint (expr, mty, []) + ; pmod_loc= Location.none + ; pmod_attributes= [] } + , None + , modes ) + | pmod_desc -> pmod_desc + in + {mb with pmb_expr= {mb.pmb_expr with pmod_desc}} + in { Ast_mapper.default_mapper with location ; attribute @@ -558,7 +588,8 @@ let make_mapper conf ~ignore_doc_comments ~erase_jane_syntax = ; modalities ; value_binding ; constructor_declaration - ; extension_constructor } + ; extension_constructor + ; module_binding } let ast fragment ~ignore_doc_comments ~erase_jane_syntax c = map fragment (make_mapper c ~ignore_doc_comments ~erase_jane_syntax) diff --git a/test/passing/tests/module_modes.ml b/test/passing/tests/module_modes.ml index 15a8fa6428..a3e2c117e7 100644 --- a/test/passing/tests/module_modes.ml +++ b/test/passing/tests/module_modes.ml @@ -71,10 +71,14 @@ let () = let module (* 38 *) M (* 39 *) @ (* 40 *) m (* 41 *) = (* 42 *) M (* 43 *) in () +(* test mode on ident *) + module (M @ foo) = struct end module (M @ foo) : S = struct end +(* No functor args: [bar] should move onto [M] *) + module (M @ foo) @ bar = struct end module (M @ foo) : S @ bar = struct end @@ -83,6 +87,8 @@ module (F @ foo) () = struct end module (F @ foo) () : S = struct end +(* There are functor args: [bar] is not allowed to move *) + module (F @ foo) () @ bar = struct end module (F @ foo) () : S @ bar = struct end @@ -93,6 +99,35 @@ and (N @ foo) : S @ bar = struct end module rec (F @ foo) () : S @ bar = struct end and (G @ foo) () : S @ bar = struct end +(* attributes *) + +module[@a] (M @ foo) = struct end + +module[@a] (M @ foo) : S = struct end + +module[@a] (M @ foo) @ bar = struct end + +module[@a] (M @ foo) : S @ bar = struct end + +module[@a] (F @ foo) () = struct end + +module[@a] (F @ foo) () : S = struct end + +module[@a] (F @ foo) () @ bar = struct end + +module[@a] (F @ foo) () : S @ bar = struct end + +module rec (M @ foo) = (struct end : S @ bar) [@a] +and (N @ foo) = (struct end : S @ bar) [@a] + +module rec (F @ foo) () = (struct end : S @ bar) [@a] +and (G @ foo) () = (struct end : S @ bar) [@a] + +module rec (M @ foo) : S @ bar = (struct end [@a]) +and (N @ foo) : S @ bar = (struct end [@a]) + +module rec (F @ foo) () : S @ bar = (struct end [@a]) +and (G @ foo) () : S @ bar = (struct end [@a]) let () = let module (M @ foo) = struct end in () @@ -117,3 +152,18 @@ let () = let () = let module (F @ foo) () : S @ bar = struct end in () + +(* comments *) + +module rec (* 44 *) ( (* 45 *) F (* 46 *) @ (* 47 *) foo (* 48 *)) (* 49 *) () (* 50 *) + : (* 51 *) S (* 52 *) @ (* 53 *) bar (* 54 *) = (* 55 *) (struct (* 55 *) end (* 56 *) + [@a]) (* 57 *) +and (* 58 *) (G (* 59 *) @ (* 60 *) foo (* 61 *)) (* 62 *) () (* 63 *) + : (* 64 *) S (* 65 *) @ (* 66 *) bar (* 67 *) = (* 68 *) (struct (* 69 *) end (* 70 *) + [@a]) (* 71 *) + +module (* 72 *) ( (* 73 *) M (* 74 *) @ (* 75 *) foo (* 76 *)) (* 77 *) @ (* 78 *) bar + (* 79 *) = (* 80 *) struct (* 81 *) end (* 82 *) + +module (* 83 *) ( (* 84 *) M (* 85 *) @ (* 86 *) foo (* 87 *)) (* 88 *) + : (* 89 *) S (* 90 *) @ (* 91 *) bar (* 92 *) = (* 93 *) struct (* 94 *) end (* 95 *) diff --git a/test/passing/tests/module_modes.ml.js-ref b/test/passing/tests/module_modes.ml.js-ref index 924635b9fb..805de45525 100644 --- a/test/passing/tests/module_modes.ml.js-ref +++ b/test/passing/tests/module_modes.ml.js-ref @@ -1,29 +1,29 @@ (* bindings *) -module M : sig +module (M @ m) : sig type t -end @ m = +end = M -module M : S @ m = M -module M @ m = M +module (M @ m) : S = M +module (M @ m) = M -module M : sig +module (M @ m) : sig type t -end @ m = +end = M [@@a] -module M : S @ m = M [@@a] -module M @ m = M [@@a] +module (M @ m) : S = M [@@a] +module (M @ m) = M [@@a] -module [@a] M : sig +module [@a] (M @ m) : sig type t -end @ m = +end = M -module [@a] M : S @ m = M -module [@a] M @ m = M +module [@a] (M @ m) : S = M +module [@a] (M @ m) = M (* expressions *) @@ -48,27 +48,23 @@ let () = (* test comment preservation *) -module M : (* 02 *) sig +module (M @ (* 05 *) m (* 06 *)) : (* 02 *) sig (* 03 *) type t -end (* 04 *) @ (* 05 *) m (* 06 *) = +end (* 04 *) = (* 01 *) (* 07 *) M (* 08 *) -module M : (* 10 *) S (* 11 *) @ (* 12 *) m (* 13 *) = +module (M @ (* 12 *) m (* 13 *)) : (* 10 *) S (* 11 *) = (* 09 *) (* 14 *) M (* 15 *) -module M @ (* 17 *) m (* 18 *) = - (* 16 *) - (* 19 *) - M -(* 20 *) +module (M (* 16 *) @ (* 17 *) m (* 18 *)) = (* 19 *) M (* 20 *) let () = let module (* 21 *) M : (* 23 *) sig @@ -106,28 +102,59 @@ let () = () ;; -module M @ foo = struct end -module M : S @ foo = struct end -module (M @ foo) @ bar = struct end -module (M @ foo) : S @ bar = struct end +(* test mode on ident *) + +module (M @ foo) = struct end +module (M @ foo) : S = struct end + +(* No functor args: [bar] should move onto [M] *) + +module (M @ bar foo) = struct end +module (M @ bar foo) : S = struct end module (F @ foo) () = struct end module (F @ foo) () : S = struct end + +(* There are functor args: [bar] is not allowed to move *) + module (F @ foo) () @ bar = struct end module (F @ foo) () : S @ bar = struct end -module rec (M @ foo) : S @ bar = struct end -and (N @ foo) : S @ bar = struct end +module rec (M @ bar foo) : S = struct end +and (N @ bar foo) : S = struct end module rec (F @ foo) () : S @ bar = struct end and (G @ foo) () : S @ bar = struct end +(* attributes *) + +module [@a] (M @ foo) = struct end +module [@a] (M @ foo) : S = struct end +module [@a] (M @ bar foo) = struct end +module [@a] (M @ bar foo) : S = struct end +module [@a] (F @ foo) () = struct end +module [@a] (F @ foo) () : S = struct end +module [@a] (F @ foo) () @ bar = struct end +module [@a] (F @ foo) () : S @ bar = struct end + +module rec (M @ bar foo) = (struct end : S) [@a] +and (N @ bar foo) = (struct end : S) [@a] + +module rec (F @ foo) () = (struct end : S @ bar) [@a] +and (G @ foo) () = (struct end : S @ bar) [@a] + +module rec (M @ bar foo) : S = struct end [@a] +and (N @ bar foo) : S = struct end [@a] + +module rec (F @ foo) () : S @ bar = struct end [@a] +and (G @ foo) () : S @ bar = struct end [@a] + let () = - let module M @ foo = struct end in + let module (M @ foo) = struct end in () ;; let () = - let module M : S @ foo = struct end in + let module (M @ foo) : S = struct end in () ;; @@ -160,3 +187,61 @@ let () = let module (F @ foo) () : S @ bar = struct end in () ;; + +(* comments *) + +module rec ((* 44 *) + (* 45 *) + F + (* 46 *) + @ (* 47 *) foo (* 48 *)) + (* 49 *) + () : (* 51 *) S (* 52 *) @ (* 53 *) bar (* 54 *) = +(* 50 *) +(* 55 *) struct + (* 55 *) +end [@a] +(* 56 *) +(* 57 *) + +and ((* 58 *) G (* 59 *) @ (* 60 *) foo (* 61 *)) (* 62 *) () : (* 64 *) S (* 65 *) +@ (* 66 *) bar (* 67 *) = +(* 63 *) +(* 68 *) struct + (* 69 *) +end [@a] +(* 70 *) +(* 71 *) + +module ((* 72 *) + (* 73 *) + M + (* 74 *) + @ (* 77 *) + (* 78 *) + bar + (* 79 *) + (* 75 *) + foo + (* 76 *)) = +(* 80 *) +struct + (* 81 *) +end +(* 82 *) + +module ((* 83 *) + (* 84 *) + M + (* 85 *) + @ (* 91 *) + bar + (* 92 *) + (* 86 *) + foo + (* 87 *)) : (* 89 *) S (* 90 *) = +(* 88 *) +(* 93 *) struct + (* 94 *) +end +(* 95 *) diff --git a/test/passing/tests/module_modes.ml.ref b/test/passing/tests/module_modes.ml.ref index 15dc4f8f45..761cfb7eaf 100644 --- a/test/passing/tests/module_modes.ml.ref +++ b/test/passing/tests/module_modes.ml.ref @@ -1,32 +1,32 @@ (* bindings *) -module M : sig +module (M @ m) : sig type t -end @ m = +end = M -module M : S @ m = M +module (M @ m) : S = M -module M @ m = M +module (M @ m) = M -module M : sig +module (M @ m) : sig type t -end @ m = +end = M [@@a] -module M : S @ m = M [@@a] +module (M @ m) : S = M [@@a] -module M @ m = M [@@a] +module (M @ m) = M [@@a] -module [@a] M : sig +module [@a] (M @ m) : sig type t -end @ m = +end = M -module [@a] M : S @ m = M +module [@a] (M @ m) : S = M -module [@a] M @ m = M +module [@a] (M @ m) = M (* expressions *) @@ -48,27 +48,23 @@ let () = (* test comment preservation *) -module M : (* 02 *) sig +module (M @ (* 05 *) m (* 06 *)) : (* 02 *) sig (* 03 *) type t -end (* 04 *) @ (* 05 *) m (* 06 *) = +end (* 04 *) = (* 01 *) (* 07 *) M (* 08 *) -module M : (* 10 *) S (* 11 *) @ (* 12 *) m (* 13 *) = +module (M @ (* 12 *) m (* 13 *)) : (* 10 *) S (* 11 *) = (* 09 *) (* 14 *) M (* 15 *) -module M @ (* 17 *) m (* 18 *) = - (* 16 *) - (* 19 *) - M -(* 20 *) +module (M (* 16 *) @ (* 17 *) m (* 18 *)) = (* 19 *) M (* 20 *) let () = let module (* 21 *) M : (* 23 *) sig @@ -103,36 +99,76 @@ let () = in () -module M @ foo = struct end +(* test mode on ident *) + +module (M @ foo) = struct end + +module (M @ foo) : S = struct end -module M : S @ foo = struct end +(* No functor args: [bar] should move onto [M] *) -module (M @ foo) @ bar = struct end +module (M @ bar foo) = struct end -module (M @ foo) : S @ bar = struct end +module (M @ bar foo) : S = struct end module (F @ foo) () = struct end module (F @ foo) () : S = struct end +(* There are functor args: [bar] is not allowed to move *) + module (F @ foo) () @ bar = struct end module (F @ foo) () : S @ bar = struct end -module rec (M @ foo) : S @ bar = struct end +module rec (M @ bar foo) : S = struct end -and (N @ foo) : S @ bar = struct end +and (N @ bar foo) : S = struct end module rec (F @ foo) () : S @ bar = struct end and (G @ foo) () : S @ bar = struct end +(* attributes *) + +module [@a] (M @ foo) = struct end + +module [@a] (M @ foo) : S = struct end + +module [@a] (M @ bar foo) = struct end + +module [@a] (M @ bar foo) : S = struct end + +module [@a] (F @ foo) () = struct end + +module [@a] (F @ foo) () : S = struct end + +module [@a] (F @ foo) () @ bar = struct end + +module [@a] (F @ foo) () : S @ bar = struct end + +module rec (M @ bar foo) = (struct end : S) [@a] + +and (N @ bar foo) = (struct end : S) [@a] + +module rec (F @ foo) () = (struct end : S @ bar) [@a] + +and (G @ foo) () = (struct end : S @ bar) [@a] + +module rec (M @ bar foo) : S = struct end [@a] + +and (N @ bar foo) : S = struct end [@a] + +module rec (F @ foo) () : S @ bar = struct end [@a] + +and (G @ foo) () : S @ bar = struct end [@a] + let () = - let module M @ foo = struct end in + let module (M @ foo) = struct end in () let () = - let module M : S @ foo = struct end in + let module (M @ foo) : S = struct end in () let () = @@ -158,3 +194,61 @@ let () = let () = let module (F @ foo) () : S @ bar = struct end in () + +(* comments *) + +module rec ((* 44 *) + (* 45 *) +F +(* 46 *) +@ (* 47 *) foo (* 48 *)) + (* 49 *) +() : (* 51 *) S (* 52 *) @ (* 53 *) bar (* 54 *) = +(* 50 *) +(* 55 *) struct + (* 55 *) +end [@a] +(* 56 *) +(* 57 *) + +and ((* 58 *) G (* 59 *) @ (* 60 *) foo (* 61 *)) (* 62 *) () : (* 64 *) S +(* 65 *) @ (* 66 *) bar (* 67 *) = +(* 63 *) +(* 68 *) struct + (* 69 *) +end [@a] +(* 70 *) +(* 71 *) + +module ((* 72 *) + (* 73 *) +M +(* 74 *) +@ (* 77 *) + (* 78 *) + bar + (* 79 *) + (* 75 *) + foo + (* 76 *)) = +(* 80 *) +struct + (* 81 *) +end +(* 82 *) + +module ((* 83 *) + (* 84 *) +M +(* 85 *) +@ (* 91 *) + bar + (* 92 *) + (* 86 *) + foo + (* 87 *)) : (* 89 *) S (* 90 *) = +(* 88 *) +(* 93 *) struct + (* 94 *) +end +(* 95 *) diff --git a/vendor/parser-extended/ast_helper.ml b/vendor/parser-extended/ast_helper.ml index 299cc18a0e..3dfd85b710 100644 --- a/vendor/parser-extended/ast_helper.ml +++ b/vendor/parser-extended/ast_helper.ml @@ -433,13 +433,28 @@ end module Mb = struct let mk ?(loc = !default_loc) ?(attrs=Attr.ext_attrs ()) ?(docs = empty_docs) ?(text = []) name modes args expr = - { - pmb_name = name; - pmb_modes = modes; - pmb_args = args; - pmb_expr = expr; - pmb_ext_attrs = add_text_attrs' text (add_docs_attrs' docs attrs); - pmb_loc = loc; + (* Special case: when this module binding is not a functor, and the module expression + is a constraint with modes, move the modes to the binding *) + let modes, expr = + match args, expr.pmod_desc with + | [], Pmod_constraint (mexpr, mty, (_ :: _ as outer_modes)) -> + let expr = + match mty with + | Some _ -> { expr with pmod_desc = Pmod_constraint (mexpr, mty, []) } + | None -> mexpr + in + ( List.sort + (fun { txt = Mode m1; _ } { txt = Mode m2 } -> String.compare m1 m2) + (modes @ outer_modes) + , expr ) + | _ -> modes, expr + in + { pmb_name = name + ; pmb_modes = modes + ; pmb_args = args + ; pmb_expr = expr + ; pmb_ext_attrs = add_text_attrs' text (add_docs_attrs' docs attrs) + ; pmb_loc = loc } end From 7b9c9e5952a4da8d0312263435152fe5dd60d4bd Mon Sep 17 00:00:00 2001 From: David Vulakh Date: Tue, 2 Sep 2025 18:14:56 -0400 Subject: [PATCH 3/4] simplify mode extraction the normalization happens in the parsrer now Signed-off-by: David Vulakh --- lib/Fmt_ast.ml | 19 ++++--------------- 1 file changed, 4 insertions(+), 15 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 5e4d2621b6..9eab1536e4 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -640,7 +640,7 @@ let let_binding_can_be_punned ~binding ~is_ext = true | _ -> false -let extract_module_binding_constraints c ctx args modes body = +let extract_module_binding_constraints c ctx modes body = let xbody = sub_mod ~ctx body in let xbody, xmty, xmodes = match xbody.ast with @@ -659,17 +659,7 @@ let extract_module_binding_constraints c ctx args modes body = in (* [xmodes_id] is the modes on the identifier, while [xmodes] is the modes on the RHS. For example, [module (F @ xmodes_id) () @ xmodes = ...]. *) - let xmodes_id, xmodes = - match (args, xmodes) with - | [], [] -> - (* If there is no argument, then [xmodes_id] and [xmodes] are the - same thing, in which case we prefer [xmodes_id]. But we don't want - to reduce [module (M @ foo) @ bar = ...] to [module M @ foo bar = - ...] because that would be viewed as changed AST by the standard - parser. *) - (modes, []) - | _ -> (modes, xmodes) - in + let xmodes_id = modes in (xmodes_id, xmty, xmodes, xbody) let rec fmt_extension_aux c ctx ~key (ext, pld) = @@ -2874,7 +2864,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens | Pexp_letmodule (name, modes, args, pmod, exp) -> let keyword = "let module" in let xmodes_id, xmty, xmodes, xbody = - extract_module_binding_constraints c ctx args modes pmod + extract_module_binding_constraints c ctx modes pmod in let can_sparse = match xbody.ast.pmod_desc with @@ -5370,8 +5360,7 @@ and fmt_module_binding c ~rec_flag ~first {ast= pmb; _} = let ctx = Mb pmb in let keyword = if first then "module" else "and" in let xmodes_id, xmty, xmodes, xbody = - extract_module_binding_constraints c ctx pmb.pmb_args pmb.pmb_modes - pmb.pmb_expr + extract_module_binding_constraints c ctx pmb.pmb_modes pmb.pmb_expr in Cmts.fmt c pmb.pmb_loc (fmt_module ~rec_:rec_flag c ctx keyword ~rec_flag:(rec_flag && first) From 3f5a61a5616274d9f0b82021413063d62bf49fde Mon Sep 17 00:00:00 2001 From: David Vulakh Date: Thu, 4 Sep 2025 17:42:12 -0400 Subject: [PATCH 4/4] revert to preserving mode placement we will want to go back to putting modes on the ident when possible, but need the compiler to type check them better first Signed-off-by: David Vulakh --- lib/Normalize_std_ast.ml | 33 +--------- test/passing/tests/module_modes.ml.js-ref | 73 +++++++++++------------ test/passing/tests/module_modes.ml.ref | 73 +++++++++++------------ vendor/parser-extended/ast_helper.ml | 29 +++------ 4 files changed, 76 insertions(+), 132 deletions(-) diff --git a/lib/Normalize_std_ast.ml b/lib/Normalize_std_ast.ml index e7f9c07ccc..0855837f5c 100644 --- a/lib/Normalize_std_ast.ml +++ b/lib/Normalize_std_ast.ml @@ -540,36 +540,6 @@ let make_mapper conf ~ignore_doc_comments ~erase_jane_syntax = } else ca.pca_type ) } in - let module_binding (m : Ast_mapper.mapper) (mb : module_binding) = - (* Special cases: normalize the forms {[ module (M @ m) : S @ l = N ]} to - {[ module (M @ m l) : S = N ]} and {[ module M : S @ m = N ]} to {[ - module (M @ m) : S = N ]} *) - let mb = Ast_mapper.default_mapper.module_binding m mb in - let pmod_desc = - match mb.pmb_expr.pmod_desc with - | Pmod_constraint - ( ( {pmod_desc= Pmod_constraint (expr, mty, outer_modes); _} as - inner_expr ) - , None - , inner_modes ) -> - let inner_expr = - match mty with - | Some _ -> - {inner_expr with pmod_desc= Pmod_constraint (expr, mty, [])} - | None -> expr - in - Pmod_constraint (inner_expr, None, inner_modes @ outer_modes) - | Pmod_constraint (expr, (Some _ as mty), modes) -> - Pmod_constraint - ( { pmod_desc= Pmod_constraint (expr, mty, []) - ; pmod_loc= Location.none - ; pmod_attributes= [] } - , None - , modes ) - | pmod_desc -> pmod_desc - in - {mb with pmb_expr= {mb.pmb_expr with pmod_desc}} - in { Ast_mapper.default_mapper with location ; attribute @@ -588,8 +558,7 @@ let make_mapper conf ~ignore_doc_comments ~erase_jane_syntax = ; modalities ; value_binding ; constructor_declaration - ; extension_constructor - ; module_binding } + ; extension_constructor } let ast fragment ~ignore_doc_comments ~erase_jane_syntax c = map fragment (make_mapper c ~ignore_doc_comments ~erase_jane_syntax) diff --git a/test/passing/tests/module_modes.ml.js-ref b/test/passing/tests/module_modes.ml.js-ref index 805de45525..acda94b315 100644 --- a/test/passing/tests/module_modes.ml.js-ref +++ b/test/passing/tests/module_modes.ml.js-ref @@ -1,29 +1,29 @@ (* bindings *) -module (M @ m) : sig +module M : sig type t -end = +end @ m = M -module (M @ m) : S = M -module (M @ m) = M +module M : S @ m = M +module M @ m = M -module (M @ m) : sig +module M : sig type t -end = +end @ m = M [@@a] -module (M @ m) : S = M [@@a] -module (M @ m) = M [@@a] +module M : S @ m = M [@@a] +module M @ m = M [@@a] -module [@a] (M @ m) : sig +module [@a] M : sig type t -end = +end @ m = M -module [@a] (M @ m) : S = M -module [@a] (M @ m) = M +module [@a] M : S @ m = M +module [@a] M @ m = M (* expressions *) @@ -48,23 +48,27 @@ let () = (* test comment preservation *) -module (M @ (* 05 *) m (* 06 *)) : (* 02 *) sig +module M : (* 02 *) sig (* 03 *) type t -end (* 04 *) = +end (* 04 *) @ (* 05 *) m (* 06 *) = (* 01 *) (* 07 *) M (* 08 *) -module (M @ (* 12 *) m (* 13 *)) : (* 10 *) S (* 11 *) = +module M : (* 10 *) S (* 11 *) @ (* 12 *) m (* 13 *) = (* 09 *) (* 14 *) M (* 15 *) -module (M (* 16 *) @ (* 17 *) m (* 18 *)) = (* 19 *) M (* 20 *) +module M @ (* 17 *) m (* 18 *) = + (* 16 *) + (* 19 *) + M +(* 20 *) let () = let module (* 21 *) M : (* 23 *) sig @@ -109,8 +113,8 @@ module (M @ foo) : S = struct end (* No functor args: [bar] should move onto [M] *) -module (M @ bar foo) = struct end -module (M @ bar foo) : S = struct end +module (M @ foo) @ bar = struct end +module (M @ foo) : S @ bar = struct end module (F @ foo) () = struct end module (F @ foo) () : S = struct end @@ -119,8 +123,8 @@ module (F @ foo) () : S = struct end module (F @ foo) () @ bar = struct end module (F @ foo) () : S @ bar = struct end -module rec (M @ bar foo) : S = struct end -and (N @ bar foo) : S = struct end +module rec (M @ foo) : S @ bar = struct end +and (N @ foo) : S @ bar = struct end module rec (F @ foo) () : S @ bar = struct end and (G @ foo) () : S @ bar = struct end @@ -129,21 +133,21 @@ and (G @ foo) () : S @ bar = struct end module [@a] (M @ foo) = struct end module [@a] (M @ foo) : S = struct end -module [@a] (M @ bar foo) = struct end -module [@a] (M @ bar foo) : S = struct end +module [@a] (M @ foo) @ bar = struct end +module [@a] (M @ foo) : S @ bar = struct end module [@a] (F @ foo) () = struct end module [@a] (F @ foo) () : S = struct end module [@a] (F @ foo) () @ bar = struct end module [@a] (F @ foo) () : S @ bar = struct end -module rec (M @ bar foo) = (struct end : S) [@a] -and (N @ bar foo) = (struct end : S) [@a] +module rec (M @ foo) = (struct end : S @ bar) [@a] +and (N @ foo) = (struct end : S @ bar) [@a] module rec (F @ foo) () = (struct end : S @ bar) [@a] and (G @ foo) () = (struct end : S @ bar) [@a] -module rec (M @ bar foo) : S = struct end [@a] -and (N @ bar foo) : S = struct end [@a] +module rec (M @ foo) : S @ bar = struct end [@a] +and (N @ foo) : S @ bar = struct end [@a] module rec (F @ foo) () : S @ bar = struct end [@a] and (G @ foo) () : S @ bar = struct end [@a] @@ -217,13 +221,9 @@ module ((* 72 *) (* 73 *) M (* 74 *) - @ (* 77 *) - (* 78 *) - bar - (* 79 *) - (* 75 *) - foo - (* 76 *)) = + @ (* 75 *) foo (* 76 *)) +@ (* 78 *) bar (* 79 *) = +(* 77 *) (* 80 *) struct (* 81 *) @@ -234,12 +234,7 @@ module ((* 83 *) (* 84 *) M (* 85 *) - @ (* 91 *) - bar - (* 92 *) - (* 86 *) - foo - (* 87 *)) : (* 89 *) S (* 90 *) = + @ (* 86 *) foo (* 87 *)) : (* 89 *) S (* 90 *) @ (* 91 *) bar (* 92 *) = (* 88 *) (* 93 *) struct (* 94 *) diff --git a/test/passing/tests/module_modes.ml.ref b/test/passing/tests/module_modes.ml.ref index 761cfb7eaf..d72b9e1081 100644 --- a/test/passing/tests/module_modes.ml.ref +++ b/test/passing/tests/module_modes.ml.ref @@ -1,32 +1,32 @@ (* bindings *) -module (M @ m) : sig +module M : sig type t -end = +end @ m = M -module (M @ m) : S = M +module M : S @ m = M -module (M @ m) = M +module M @ m = M -module (M @ m) : sig +module M : sig type t -end = +end @ m = M [@@a] -module (M @ m) : S = M [@@a] +module M : S @ m = M [@@a] -module (M @ m) = M [@@a] +module M @ m = M [@@a] -module [@a] (M @ m) : sig +module [@a] M : sig type t -end = +end @ m = M -module [@a] (M @ m) : S = M +module [@a] M : S @ m = M -module [@a] (M @ m) = M +module [@a] M @ m = M (* expressions *) @@ -48,23 +48,27 @@ let () = (* test comment preservation *) -module (M @ (* 05 *) m (* 06 *)) : (* 02 *) sig +module M : (* 02 *) sig (* 03 *) type t -end (* 04 *) = +end (* 04 *) @ (* 05 *) m (* 06 *) = (* 01 *) (* 07 *) M (* 08 *) -module (M @ (* 12 *) m (* 13 *)) : (* 10 *) S (* 11 *) = +module M : (* 10 *) S (* 11 *) @ (* 12 *) m (* 13 *) = (* 09 *) (* 14 *) M (* 15 *) -module (M (* 16 *) @ (* 17 *) m (* 18 *)) = (* 19 *) M (* 20 *) +module M @ (* 17 *) m (* 18 *) = + (* 16 *) + (* 19 *) + M +(* 20 *) let () = let module (* 21 *) M : (* 23 *) sig @@ -107,9 +111,9 @@ module (M @ foo) : S = struct end (* No functor args: [bar] should move onto [M] *) -module (M @ bar foo) = struct end +module (M @ foo) @ bar = struct end -module (M @ bar foo) : S = struct end +module (M @ foo) : S @ bar = struct end module (F @ foo) () = struct end @@ -121,9 +125,9 @@ module (F @ foo) () @ bar = struct end module (F @ foo) () : S @ bar = struct end -module rec (M @ bar foo) : S = struct end +module rec (M @ foo) : S @ bar = struct end -and (N @ bar foo) : S = struct end +and (N @ foo) : S @ bar = struct end module rec (F @ foo) () : S @ bar = struct end @@ -135,9 +139,9 @@ module [@a] (M @ foo) = struct end module [@a] (M @ foo) : S = struct end -module [@a] (M @ bar foo) = struct end +module [@a] (M @ foo) @ bar = struct end -module [@a] (M @ bar foo) : S = struct end +module [@a] (M @ foo) : S @ bar = struct end module [@a] (F @ foo) () = struct end @@ -147,17 +151,17 @@ module [@a] (F @ foo) () @ bar = struct end module [@a] (F @ foo) () : S @ bar = struct end -module rec (M @ bar foo) = (struct end : S) [@a] +module rec (M @ foo) = (struct end : S @ bar) [@a] -and (N @ bar foo) = (struct end : S) [@a] +and (N @ foo) = (struct end : S @ bar) [@a] module rec (F @ foo) () = (struct end : S @ bar) [@a] and (G @ foo) () = (struct end : S @ bar) [@a] -module rec (M @ bar foo) : S = struct end [@a] +module rec (M @ foo) : S @ bar = struct end [@a] -and (N @ bar foo) : S = struct end [@a] +and (N @ foo) : S @ bar = struct end [@a] module rec (F @ foo) () : S @ bar = struct end [@a] @@ -224,13 +228,9 @@ module ((* 72 *) (* 73 *) M (* 74 *) -@ (* 77 *) - (* 78 *) - bar - (* 79 *) - (* 75 *) - foo - (* 76 *)) = +@ (* 75 *) foo (* 76 *)) +@ (* 78 *) bar (* 79 *) = +(* 77 *) (* 80 *) struct (* 81 *) @@ -241,12 +241,7 @@ module ((* 83 *) (* 84 *) M (* 85 *) -@ (* 91 *) - bar - (* 92 *) - (* 86 *) - foo - (* 87 *)) : (* 89 *) S (* 90 *) = +@ (* 86 *) foo (* 87 *)) : (* 89 *) S (* 90 *) @ (* 91 *) bar (* 92 *) = (* 88 *) (* 93 *) struct (* 94 *) diff --git a/vendor/parser-extended/ast_helper.ml b/vendor/parser-extended/ast_helper.ml index 3dfd85b710..299cc18a0e 100644 --- a/vendor/parser-extended/ast_helper.ml +++ b/vendor/parser-extended/ast_helper.ml @@ -433,28 +433,13 @@ end module Mb = struct let mk ?(loc = !default_loc) ?(attrs=Attr.ext_attrs ()) ?(docs = empty_docs) ?(text = []) name modes args expr = - (* Special case: when this module binding is not a functor, and the module expression - is a constraint with modes, move the modes to the binding *) - let modes, expr = - match args, expr.pmod_desc with - | [], Pmod_constraint (mexpr, mty, (_ :: _ as outer_modes)) -> - let expr = - match mty with - | Some _ -> { expr with pmod_desc = Pmod_constraint (mexpr, mty, []) } - | None -> mexpr - in - ( List.sort - (fun { txt = Mode m1; _ } { txt = Mode m2 } -> String.compare m1 m2) - (modes @ outer_modes) - , expr ) - | _ -> modes, expr - in - { pmb_name = name - ; pmb_modes = modes - ; pmb_args = args - ; pmb_expr = expr - ; pmb_ext_attrs = add_text_attrs' text (add_docs_attrs' docs attrs) - ; pmb_loc = loc + { + pmb_name = name; + pmb_modes = modes; + pmb_args = args; + pmb_expr = expr; + pmb_ext_attrs = add_text_attrs' text (add_docs_attrs' docs attrs); + pmb_loc = loc; } end