Fix dropped attribute in (module M : S [@attr]) (#2602)

The attributes were lost by mistake in the patched parser.

Author: Julow

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)
 
 ### Changes
 - The location of attributes for structure items is now tracked and preserved. (#2247, @EmileTrotignon)

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 -> (

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)

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])

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])

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

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)

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)

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)])]

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 =