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

@@ -265,7 +265,7 @@ let fmt_str_loc_opt c ?pre ?(default = "_") {txt; loc} =
   Cmts.fmt c loc (opt pre str $ str (Option.value ~default txt))
 
 let fmt_ident_loc_opt c ?pre ?default {txt; loc} =
-  fmt_str_loc_opt c ?pre ?default {txt = Option.map txt ~f:escape_ident; loc}
+  fmt_str_loc_opt c ?pre ?default {txt= Option.map txt ~f:escape_ident; loc}
 
 let variant_var c ({txt= x; loc} : variant_var) =
   Cmts.fmt c loc @@ (str "`" $ fmt_ident_loc c x)
@@ -1074,11 +1074,11 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx
         $ fmt_longident_loc c ~constructor:false 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 ~constructor:false id)
-        $ fmt_package_type c ctx cnstrs )
+        $ fmt_package_type c ctx cnstrs attrs )
   | Ptyp_poly ([], _) ->
       impossible "produced by the parser, handled elsewhere"
   | Ptyp_poly (a1N, t) ->
@@ -1209,7 +1209,7 @@ and fmt_labeled_tuple_type c lbl xtyp =
       hvbox 0
         (Cmts.fmt c s.loc (ident s.txt) $ str ":" $ fmt_core_type c xtyp)
 
-and fmt_package_type c ctx cnstrs =
+and fmt_package_type c ctx cnstrs attrs =
   let fmt_cstr ~first ~last:_ (lid, typ) =
     fmt_or first "@;<1 0>" "@;<1 1>"
     $ hvbox 2
@@ -1218,7 +1218,7 @@ and fmt_package_type c ctx cnstrs =
         $ fmt " =@ "
         $ fmt_core_type c (sub_typ ~ctx typ) )
   in
-  list_fl cnstrs fmt_cstr
+  list_fl cnstrs fmt_cstr $ fmt_attributes c attrs
 
 and fmt_row_field c ctx {prf_desc; prf_attributes; prf_loc} =
   let c = update_config c prf_attributes in
@@ -1276,8 +1276,7 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
   | Ppat_var {txt; loc} ->
       let is_symbol = Std_longident.String_id.is_symbol txt in
       let str = if is_symbol then str else ident in
-      Cmts.fmt c loc
-      @@ wrap_if is_symbol "( " " )" (str txt)
+      Cmts.fmt c loc @@ wrap_if is_symbol "( " " )" (str txt)
   | Ppat_alias (pat, {txt; loc}) ->
       let paren_pat =
         match pat.ppat_desc with
@@ -1520,14 +1519,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 $ fmt "@ : "
                         $ fmt_longident_loc c ~constructor:false id )
-                    $ fmt_package_type c ctx cnstrs ) ) )
+                    $ fmt_package_type c ctx cnstrs attrs ) ) )
         | None -> wrap_fits_breaks_if ~space:false c.conf parens "(" ")" k
       in
       fmt_constraint_opt pt
@@ -2908,11 +2907,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 ~constructor:false c id)
-              $ fmt_package_type c ctx cnstrs )
+              $ fmt_package_type c ctx cnstrs attrs )
         | None -> m
       in
       outer_pro
@@ -4838,11 +4837,11 @@ 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 ~constructor:false lid)
-            $ fmt_package_type c ctx cstrs )
+            $ fmt_package_type c ctx cstrs attrs )
       in
       { empty with
         opn= Some (open_hvbox 2)

test/passing/tests/dropped_attribute.ml

@@ -1,5 +1,3 @@
-(* CR-soon tdelvecchio: [[@annot2]] and [[@annot3]] are dropped by ocamlformat. *)
-
 module _ : sig
   val foo : (module T with type t = 'a [@annot1]) -> unit
 end = struct

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

@@ -1,7 +1,7 @@
-(* CR-soon tdelvecchio: [[@annot2]] and [[@annot3]] are dropped by ocamlformat. *)
-
 module _ : sig
   val foo : ((module T with type t = 'a)[@annot1]) -> unit
 end = struct
-  let foo (type a) (module M : T with type t = a) = (module M : T with type t = a)
+  let foo (type a) (module M : T with type t = a[@annot2]) =
+    (module M : T with type t = a[@annot3])
+  ;;
 end

test/passing/tests/dropped_attribute.ml.ref

@@ -1,9 +1,6 @@
-(* CR-soon tdelvecchio: [[@annot2]] and [[@annot3]] are dropped by
-   ocamlformat. *)
-
 module _ : sig
   val foo : ((module T with type t = 'a)[@annot1]) -> unit
 end = struct
-  let foo (type a) (module M : T with type t = a) =
-    (module M : T with type t = a)
+  let foo (type a) (module M : T with type t = a[@annot2]) =
+    (module M : T with type t = a[@annot3])
 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 a b = mk ?loc ?attrs (Ptyp_package (a, b, []))
   let extension ?loc ?attrs a = mk ?loc ?attrs (Ptyp_extension a)
 
   (* Jane Street extension *)

vendor/parser-extended/ast_mapper.ml

@@ -102,8 +102,8 @@ 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, a) =
+  (map_loc sub lid), (List.map (map_tuple (map_loc sub) (sub.typ sub)) l), sub.attributes sub a
 
 let map_arg_label sub = function
   | Asttypes.Nolabel -> Asttypes.Nolabel
@@ -227,8 +227,8 @@ 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
+        let lid, l, attrs' = map_package_type sub pt in
+        package ~loc ~attrs:(attrs @ attrs') lid l
     | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x)
 
     (* Jane Street extension *)

vendor/parser-extended/parser.mly

@@ -4445,12 +4445,12 @@ 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) }
+      { let (lid, cstrs, attrs) = package_type_of_module_type $1 in
+        (lid, cstrs, attrs) }
 ;
 %inline row_field_list:
   separated_nonempty_llist(BAR, row_field)

vendor/parser-extended/parsetree.mli

@@ -226,7 +226,7 @@ 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,9 +309,10 @@ 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, a) =
   line i ppf "package_type %a\n" fmt_longident_loc s;
-  list i package_with ppf l
+  list i package_with ppf l;
+  attributes i ppf a
 
 and pattern i ppf x =
   line i ppf "pattern %a\n" fmt_location x.ppat_loc;
@@ -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 ->