Fix dropped attribute on package types.

Signed-off-by: Thomas Del Vecchio <[email protected]>

lib/Ast.ml

@@ -1000,7 +1000,7 @@ end = struct
             List.exists r1N ~f:(function
               | {prf_desc= Rtag (_, _, t1N); _} -> List.exists t1N ~f
               | {prf_desc= Rinherit t1; _} -> typ == t1 ) )
-      | 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
@@ -1036,14 +1036,14 @@ end = struct
       match ctx.ppat_desc with
       | Ppat_constraint (_, Some 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 (_, Some t1, _)
        |Pexp_coerce (_, None, t1)
        |Pexp_poly (_, Some t1)
@@ -1080,7 +1080,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

@@ -1054,10 +1054,11 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx
         $ fmt "@ " $ 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 (fmt "module@ " $ fmt_longident_loc c id)
-        $ fmt_package_type c ctx cnstrs )
+        $ fmt_package_type c ctx cnstrs
+        $ fmt_attributes c attrs )
   | Ptyp_poly ([], _) ->
       impossible "produced by the parser, handled elsewhere"
   | Ptyp_poly (a1N, t) ->
@@ -1488,12 +1489,13 @@ 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 $ fmt "@ : " $ 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
@@ -2867,10 +2869,11 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
       and epi = fmt_if_k inner_parens cls_paren in
       let fmt_mod m =
         match pt with
-        | Some (id, cnstrs) ->
+        | Some (id, cnstrs, attrs) ->
             hvbox 2
               ( hovbox 0 (m $ fmt "@ : " $ 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
@@ -4777,11 +4780,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)
         $ hvbox 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/dropped_attribute.ml

@@ -1,8 +1,6 @@
 (* Attributes [[@annot1]] and [[@annot3]] are dropped by the compiler;
    an upcoming patch should fix this. *)
 
-(* CR-soon tdelvecchio: [[@annot4]] is dropped by ocamlformat. *)
-
 module _ : sig
   val foo : (module T [@annot1] with type t = 'a [@annot2]) -> unit
 end = struct

test/passing/tests/dropped_attribute.ml.js-ref

@@ -1,10 +1,8 @@
 (* Attributes [[@annot1]] and [[@annot3]] are dropped by the compiler;
    an upcoming patch should fix this. *)
 
-(* CR-soon tdelvecchio: [[@annot4]] is dropped by ocamlformat. *)
-
 module _ : sig
   val foo : ((module T with type t = 'a)[@annot2]) -> unit
 end = struct
-  let foo (type a) (module M : T with type t = a) = ()
+  let foo (type a) (module M : T with type t = a[@annot4]) = ()
 end

test/passing/tests/dropped_attribute.ml.ref

@@ -1,10 +1,8 @@
 (* Attributes [[@annot1]] and [[@annot3]] are dropped by the compiler; an
    upcoming patch should fix this. *)
 
-(* CR-soon tdelvecchio: [[@annot4]] is dropped by ocamlformat. *)
-
 module _ : sig
   val foo : ((module T with type t = 'a)[@annot2]) -> unit
 end = struct
-  let foo (type a) (module M : T with type t = a) = ()
+  let foo (type a) (module M : T with type t = a[@annot4]) = ()
 end

vendor/parser-extended/ast_helper.ml

@@ -78,7 +78,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)
 
   (* Jane Street extension *)

vendor/parser-extended/ast_mapper.ml

@@ -102,8 +102,10 @@ let map_type_var sub (n, l) =
 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
@@ -227,8 +229,7 @@ module T = struct
     | Ptyp_poly (sl, t) -> poly ~loc ~attrs
                              (List.map (map_type_var 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_extension x -> extension ~loc ~attrs (sub.extension sub x)
 
     (* Jane Street extension *)

vendor/parser-extended/parser.mly

@@ -4446,12 +4446,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

@@ -226,7 +226,8 @@ and core_type_desc =
   | Ptyp_constr_unboxed of Longident.t loc * core_type list
   (* End Jane Street extension *)
 
-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

@@ -309,8 +309,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 =
@@ -633,7 +634,7 @@ and jkind_annotation ?loc i ppf jkind =
   let fmt_loc_opt ppf = function
     | None -> ()
     | Some loc -> fmt_location ppf loc
-  in 
+  in
   match jkind with
   | Default -> line i ppf "Default %a\n" fmt_loc_opt loc
   | Abbreviation jkind ->