diff --git a/CHANGES.md b/CHANGES.md index a45b043aed..513c14466a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -61,6 +61,7 @@ profile. This started with version 0.26.0. - \* Fix arrow type indentation with `break-separators=before` (#2598, @Julow) - Fix formatting of short `fun` expressions with the janestreet profile (#2593, @Julow) - Fix missing parentheses around a let in class expressions (#2599, @Julow) +- Fix dropped attribute in `(module M : S [@attr])` (#2602, @Julow) - Build on OCaml 5.3 (#2603, @adamchol, @Julow) ### Changes diff --git a/lib/Ast.ml b/lib/Ast.ml index 55e326babe..bdc3a40cd7 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -968,7 +968,7 @@ end = struct | {prf_desc= Rtag (_, _, t1N); _} -> List.exists t1N ~f | {prf_desc= Rinherit t1; _} -> typ == t1 ) ) | Ptyp_open (_, t1) -> assert (t1 == typ) - | Ptyp_package (_, it1N) -> assert (List.exists it1N ~f:snd_f) + | Ptyp_package (_, it1N, _) -> assert (List.exists it1N ~f:snd_f) | Ptyp_object (fields, _) -> assert ( List.exists fields ~f:(function @@ -1001,14 +1001,14 @@ end = struct match ctx.ppat_desc with | Ppat_constraint (_, t1) -> assert (typ == t1) | Ppat_extension (_, PTyp t) -> assert (typ == t) - | Ppat_unpack (_, Some (_, l)) -> + | Ppat_unpack (_, Some (_, l, _)) -> assert (List.exists l ~f:(fun (_, t) -> typ == t)) | Ppat_record (l, _) -> assert (List.exists l ~f:(fun (_, t, _) -> Option.exists t ~f)) | _ -> assert false ) | Exp ctx -> ( match ctx.pexp_desc with - | Pexp_pack (_, Some (_, it1N)) -> assert (List.exists it1N ~f:snd_f) + | Pexp_pack (_, Some (_, it1N, _)) -> assert (List.exists it1N ~f:snd_f) | Pexp_constraint (_, t1) |Pexp_coerce (_, None, t1) |Pexp_extension (_, PTyp t1) -> @@ -1046,7 +1046,7 @@ end = struct | Mod ctx -> ( match ctx.pmod_desc with | Pmod_unpack (_, ty1, ty2) -> - let f (_, cstrs) = List.exists cstrs ~f:(fun (_, x) -> f x) in + let f (_, cstrs, _) = List.exists cstrs ~f:(fun (_, x) -> f x) in assert (Option.exists ty1 ~f || Option.exists ty2 ~f) | _ -> assert false ) | Sig ctx -> ( diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 25bc6600f1..e74a8b3dfc 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -909,10 +909,11 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx $ space_break $ fmt_longident_loc c lid ) | Ptyp_extension ext -> hvbox c.conf.fmt_opts.extension_indent.v (fmt_extension c ctx ext) - | Ptyp_package (id, cnstrs) -> + | Ptyp_package (id, cnstrs, attrs) -> hvbox 2 ( hovbox 0 (str "module" $ space_break $ fmt_longident_loc c id) - $ fmt_package_type c ctx cnstrs ) + $ fmt_package_type c ctx cnstrs + $ fmt_attributes c attrs ) | Ptyp_open (lid, typ) -> hvbox 2 ( hvbox 0 (fmt_longident_loc c lid $ str ".(") @@ -1293,13 +1294,14 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false) | Ppat_unpack (name, pt) -> let fmt_constraint_opt pt k = match pt with - | Some (id, cnstrs) -> + | Some (id, cnstrs, attrs) -> hovbox 0 (Params.parens_if parens c.conf (hvbox 1 ( hovbox 0 (k $ space_break $ str ": " $ fmt_longident_loc c id) - $ fmt_package_type c ctx cnstrs ) ) ) + $ fmt_package_type c ctx cnstrs + $ fmt_attributes c attrs ) ) ) | None -> wrap_fits_breaks_if ~space:false c.conf parens "(" ")" k in fmt_constraint_opt pt @@ -2594,10 +2596,11 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens and epi = cls_paren in let fmt_mod m = match pt with - | Some (id, cnstrs) -> + | Some (id, cnstrs, attrs) -> hvbox 2 ( hovbox 0 (m $ space_break $ str ": " $ fmt_longident_loc c id) - $ fmt_package_type c ctx cnstrs ) + $ fmt_package_type c ctx cnstrs + $ fmt_attributes c attrs ) | None -> m in outer_pro @@ -4330,11 +4333,12 @@ and fmt_module_expr ?(dock_struct = true) c ({ast= m; _} as xmod) = (str "end" $ fmt_attributes_and_docstrings c pmod_attributes) $ after ) } | Pmod_unpack (e, ty1, ty2) -> - let package_type sep (lid, cstrs) = + let package_type sep (lid, cstrs, attrs) = break 1 (Params.Indent.mod_unpack_annot c.conf) $ hovbox 0 ( hovbox 0 (str sep $ fmt_longident_loc c lid) - $ fmt_package_type c ctx cstrs ) + $ fmt_package_type c ctx cstrs + $ fmt_attributes c attrs ) in { empty with opn= Some (open_hvbox 2) diff --git a/test/passing/tests/first_class_module.ml b/test/passing/tests/first_class_module.ml index 1a56a1c914..9f2c09219a 100644 --- a/test/passing/tests/first_class_module.ml +++ b/test/passing/tests/first_class_module.ml @@ -114,3 +114,5 @@ let x = (module M : S) (* Unpack containing a [pexp_constraint]. *) module T = (val (x : (module S))) + +let _ = (module Int : T [@foo]) diff --git a/test/passing/tests/first_class_module.ml.ref b/test/passing/tests/first_class_module.ml.ref index e70fb45497..0c1bd834b0 100644 --- a/test/passing/tests/first_class_module.ml.ref +++ b/test/passing/tests/first_class_module.ml.ref @@ -116,3 +116,5 @@ let x = (module M : S) (* Unpack containing a [pexp_constraint]. *) module T = (val (x : (module S))) + +let _ = (module Int : T[@foo]) diff --git a/vendor/parser-extended/ast_helper.ml b/vendor/parser-extended/ast_helper.ml index 5b0f8572e2..3b092ffdea 100644 --- a/vendor/parser-extended/ast_helper.ml +++ b/vendor/parser-extended/ast_helper.ml @@ -80,7 +80,7 @@ module Typ = struct let alias ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_alias (a, b)) let variant ?loc ?attrs a b c = mk ?loc ?attrs (Ptyp_variant (a, b, c)) let poly ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_poly (a, b)) - let package ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_package (a, b)) + let package ?loc ?attrs p = mk ?loc ?attrs (Ptyp_package p) let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a) let open_ ?loc ?attrs mod_ident t = mk ?loc ?attrs (Ptyp_open (mod_ident, t)) end diff --git a/vendor/parser-extended/ast_mapper.ml b/vendor/parser-extended/ast_mapper.ml index f78bcaf472..d76b373a1c 100644 --- a/vendor/parser-extended/ast_mapper.ml +++ b/vendor/parser-extended/ast_mapper.ml @@ -96,8 +96,10 @@ let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} let variant_var sub x = {loc = sub.location sub x.loc; txt= map_loc sub x.txt} -let map_package_type sub (lid, l) = - (map_loc sub lid), (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) +let map_package_type sub (lid, l, attrs) = + (map_loc sub lid), + (List.map (map_tuple (map_loc sub) (sub.typ sub)) l), + sub.attributes sub attrs let map_arg_label sub = function | Asttypes.Nolabel -> Asttypes.Nolabel @@ -240,8 +242,7 @@ module T = struct | Ptyp_poly (sl, t) -> poly ~loc ~attrs (List.map (map_loc sub) sl) (sub.typ sub t) | Ptyp_package pt -> - let lid, l = map_package_type sub pt in - package ~loc ~attrs lid l + package ~loc ~attrs (map_package_type sub pt) | Ptyp_open (mod_ident, t) -> open_ ~loc ~attrs (map_loc sub mod_ident) (sub.typ sub t) | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly index 519a1dce99..66f7f41a16 100644 --- a/vendor/parser-extended/parser.mly +++ b/vendor/parser-extended/parser.mly @@ -3612,12 +3612,11 @@ atomic_type: %inline package_core_type: module_type { let (lid, cstrs, attrs) = package_type_of_module_type $1 in - let descr = Ptyp_package (lid, cstrs) in + let descr = Ptyp_package (lid, cstrs, []) in mktyp ~loc:$sloc ~attrs descr } ; %inline package_type: module_type - { let (lid, cstrs, _attrs) = package_type_of_module_type $1 in - (lid, cstrs) } + { package_type_of_module_type $1 } ; %inline row_field_list: separated_nonempty_llist(BAR, row_field) diff --git a/vendor/parser-extended/parsetree.mli b/vendor/parser-extended/parsetree.mli index 9027ef6a73..aa5a11874f 100644 --- a/vendor/parser-extended/parsetree.mli +++ b/vendor/parser-extended/parsetree.mli @@ -181,7 +181,8 @@ and core_type_desc = | Ptyp_open of Longident.t loc * core_type (** [M.(T)] *) | Ptyp_extension of extension (** [[%id]]. *) -and package_type = Longident.t loc * (Longident.t loc * core_type) list +and package_type = + Longident.t loc * (Longident.t loc * core_type) list * attributes (** As {!package_type} typed values: - [(S, [])] represents [(module S)], - [(S, [(t1, T1) ; ... ; (tn, Tn)])] diff --git a/vendor/parser-extended/printast.ml b/vendor/parser-extended/printast.ml index 16631a399d..25b2756882 100644 --- a/vendor/parser-extended/printast.ml +++ b/vendor/parser-extended/printast.ml @@ -259,8 +259,9 @@ and package_with i ppf (s, t) = line i ppf "with type %a\n" fmt_longident_loc s; core_type i ppf t -and package_type i ppf (s, l) = +and package_type i ppf (s, l, attrs) = line i ppf "package_type %a\n" fmt_longident_loc s; + attributes (i+1) ppf attrs; list i package_with ppf l and pattern i ppf x =