Attributes now stay where the user put them (#2451)

    module [@attr] M = struct end

used to be formatted into

    module = struct end [@@attr]

This PR make it so that the user can choose between the two syntaxes, ocamlformat will not change anything.

Author: EmileTrotignon

CHANGES.md

@@ -134,6 +134,7 @@ profile. This started with version 0.26.0.
 - JaneStreet profile: doesn't align infix ops with open paren (#2204, @gpetiot)
 - Re-use the type let_binding from the parser instead of value_binding, improve the spacing of let-bindings regarding of having extension or comments (#2219, @gpetiot)
 - The `ocamlformat` package now only contains the binary, the library is available through the `ocamlformat-lib` package (#2230, @gpetiot)
+- The position of module and module type attributes is now preserved. (#2451, @emiletrotignon)
 
 ### Added
 

lib/Ast.ml

@@ -105,6 +105,12 @@ module Ext = struct
   end
 end
 
+module Ext_attrs = struct
+  let has_doc ea =
+    List.exists ~f:Attr.is_doc ea.attrs_before
+    || List.exists ~f:Attr.is_doc ea.attrs_after
+end
+
 module Exp = struct
   let location x = x.pexp_loc
 
@@ -318,27 +324,30 @@ module Structure_item = struct
   let has_doc itm =
     match itm.pstr_desc with
     | Pstr_attribute atr -> Attr.is_doc atr
+    (* one attribute list *)
     | Pstr_eval (_, atrs)
      |Pstr_value {pvbs_bindings= {pvb_attributes= atrs; _} :: _; _}
      |Pstr_primitive {pval_attributes= atrs; _}
      |Pstr_type (_, {ptype_attributes= atrs; _} :: _)
      |Pstr_typext {ptyext_attributes= atrs; _}
      |Pstr_recmodule ({pmb_expr= {pmod_attributes= atrs; _}; _} :: _)
-     |Pstr_modtype {pmtd_attributes= atrs; _}
      |Pstr_open {popen_attributes= atrs; _}
      |Pstr_extension (_, atrs)
      |Pstr_class_type ({pci_attributes= atrs; _} :: _)
      |Pstr_class ({pci_attributes= atrs; _} :: _) ->
         List.exists ~f:Attr.is_doc atrs
-    | Pstr_include
-        {pincl_mod= {pmod_attributes= atrs1; _}; pincl_attributes= atrs2; _}
-     |Pstr_exception
+    | Pstr_exception
         { ptyexn_attributes= atrs1
         ; ptyexn_constructor= {pext_attributes= atrs2; _}
         ; _ }
-     |Pstr_module
-        {pmb_attributes= atrs1; pmb_expr= {pmod_attributes= atrs2; _}; _} ->
+     |Pstr_include
+        {pincl_mod= {pmod_attributes= atrs1; _}; pincl_attributes= atrs2; _}
+      ->
         List.exists ~f:Attr.is_doc atrs1 || List.exists ~f:Attr.is_doc atrs2
+    | Pstr_modtype {pmtd_ext_attrs; _} -> Ext_attrs.has_doc pmtd_ext_attrs
+    | Pstr_module {pmb_ext_attrs; pmb_expr= {pmod_attributes; _}; _} ->
+        Ext_attrs.has_doc pmb_ext_attrs
+        || List.exists ~f:Attr.is_doc pmod_attributes
     | Pstr_value {pvbs_bindings= []; _}
      |Pstr_type (_, [])
      |Pstr_recmodule []
@@ -412,30 +421,33 @@ module Signature_item = struct
   let has_doc itm =
     match itm.psig_desc with
     | Psig_attribute atr -> Attr.is_doc atr
+    (* one attribute list *)
     | Psig_value {pval_attributes= atrs; _}
      |Psig_type (_, {ptype_attributes= atrs; _} :: _)
      |Psig_typesubst ({ptype_attributes= atrs; _} :: _)
      |Psig_typext {ptyext_attributes= atrs; _}
-     |Psig_modtype {pmtd_attributes= atrs; _}
-     |Psig_modtypesubst {pmtd_attributes= atrs; _}
-     |Psig_modsubst {pms_attributes= atrs; _}
      |Psig_open {popen_attributes= atrs; _}
      |Psig_extension (_, atrs)
      |Psig_class_type ({pci_attributes= atrs; _} :: _)
      |Psig_class ({pci_attributes= atrs; _} :: _) ->
         List.exists ~f:Attr.is_doc atrs
-    | Psig_recmodule
-        ( {pmd_type= {pmty_attributes= atrs1; _}; pmd_attributes= atrs2; _}
-        :: _ )
-     |Psig_include
+    (* two attribute list *)
+    | Psig_modtype {pmtd_ext_attrs= ea; _}
+     |Psig_modtypesubst {pmtd_ext_attrs= ea; _}
+     |Psig_modsubst {pms_ext_attrs= ea; _} ->
+        Ext_attrs.has_doc ea
+    | Psig_include
         {pincl_mod= {pmty_attributes= atrs1; _}; pincl_attributes= atrs2; _}
      |Psig_exception
         { ptyexn_attributes= atrs1
         ; ptyexn_constructor= {pext_attributes= atrs2; _}
-        ; _ }
-     |Psig_module
-        {pmd_attributes= atrs1; pmd_type= {pmty_attributes= atrs2; _}; _} ->
+        ; _ } ->
         List.exists ~f:Attr.is_doc atrs1 || List.exists ~f:Attr.is_doc atrs2
+    | Psig_recmodule
+        ({pmd_type= {pmty_attributes= atrs; _}; pmd_ext_attrs= ea; _} :: _)
+     |Psig_module {pmd_ext_attrs= ea; pmd_type= {pmty_attributes= atrs; _}; _}
+      ->
+        Ext_attrs.has_doc ea || (List.exists ~f:Attr.is_doc) atrs
     | Psig_type (_, [])
      |Psig_typesubst []
      |Psig_recmodule []
@@ -510,7 +522,7 @@ module Lb = struct
 end
 
 module Mb = struct
-  let has_doc itm = List.exists ~f:Attr.is_doc itm.pmb_attributes
+  let has_doc itm = Ext_attrs.has_doc itm.pmb_ext_attrs
 
   let is_simple (i, (c : Conf.t)) =
     Poly.(c.fmt_opts.module_item_spacing.v = `Compact)
@@ -524,7 +536,7 @@ module Mb = struct
 end
 
 module Md = struct
-  let has_doc itm = List.exists ~f:Attr.is_doc itm.pmd_attributes
+  let has_doc itm = Ext_attrs.has_doc itm.pmd_ext_attrs
 
   let is_simple (i, (c : Conf.t)) =
     Poly.(c.fmt_opts.module_item_spacing.v = `Compact)
@@ -669,6 +681,8 @@ include T
 
 let is_top = function Top -> true | _ -> false
 
+let attrs_of_ext_attrs ea = ea.attrs_before @ ea.attrs_after
+
 let attributes = function
   | Pld _ -> []
   | Typ x -> x.ptyp_attributes
@@ -677,8 +691,8 @@ let attributes = function
   | Pat x -> x.ppat_attributes
   | Exp x -> x.pexp_attributes
   | Lb x -> x.pvb_attributes
-  | Mb x -> x.pmb_attributes
-  | Md x -> x.pmd_attributes
+  | Mb x -> attrs_of_ext_attrs x.pmb_ext_attrs
+  | Md x -> attrs_of_ext_attrs x.pmd_ext_attrs
   | Cl x -> x.pcl_attributes
   | Mty x -> x.pmty_attributes
   | Mod x -> x.pmod_attributes

lib/Fmt_ast.ml

@@ -178,6 +178,10 @@ let update_config_maybe_disabled c loc l f =
   let c = update_config c l in
   maybe_disabled c loc l f
 
+let update_config_maybe_disabled_attrs c loc attrs f =
+  let l = attrs.attrs_before @ attrs.attrs_after in
+  update_config_maybe_disabled c loc l f
+
 let update_config_maybe_disabled_block c loc l f =
   let fmt bdy = {empty with opn= Some (open_vbox 2); bdy; cls= close_box} in
   let c = update_config c l in
@@ -463,6 +467,15 @@ let fmt_docstring_around_item ?is_val ?force_before ?fit c attrs =
   in
   (doc_before, doc_after, attrs)
 
+(** Returns the documentation before and after the item as well as the
+    [ext_attrs] before and after attributes, modified.
+    It is assumed that docstrings can only occurs in [attrs_after]. *)
+let fmt_docstring_around_item_attrs ?is_val ?force_before ?fit c attrs =
+  let doc_before, doc_after, attrs_after =
+    fmt_docstring_around_item ?is_val ?force_before ?fit c attrs.attrs_after
+  in
+  (doc_before, doc_after, attrs.attrs_before, attrs_after)
+
 let fmt_extension_suffix c ext =
   opt ext (fun name -> str "%" $ fmt_str_loc c name)
 
@@ -2289,7 +2302,9 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0)
             c.conf
             ( hvbox 2
                 (fmt_module c ctx keyword ~eqty:":" name args (Some xbody)
-                   xmty [] ~epi:(str "in") ~can_sparse ?ext ~rec_flag:false )
+                   xmty
+                   ~attrs:(Ast_helper.Attr.ext_attrs ?ext ())
+                   ~epi:(str "in") ~can_sparse ~rec_flag:false )
             $ fmt "@;<1000 0>"
             $ fmt_expression c (sub_exp ~ctx exp) )
         $ fmt_atrs )
@@ -3622,20 +3637,16 @@ and fmt_signature_item c ?ext {ast= si; _} =
             $ esp $ fmt_opt epi
             $ fmt_item_attributes c ~pre:(Break (1, 0)) atrs )
         $ doc_after )
-  | Psig_modtype mtd -> fmt_module_type_declaration ?ext c ctx mtd
-  | Psig_modtypesubst mtd ->
-      fmt_module_type_declaration ?ext ~eqty:":=" c ctx mtd
+  | Psig_modtype mtd -> fmt_module_type_declaration c ctx mtd
+  | Psig_modtypesubst mtd -> fmt_module_type_declaration ~eqty:":=" c ctx mtd
   | Psig_module md ->
       hvbox 0
-        (fmt_module_declaration ?ext c ~rec_flag:false ~first:true
+        (fmt_module_declaration c ~rec_flag:false ~first:true
            (sub_md ~ctx md) )
-  | Psig_modsubst ms -> hvbox 0 (fmt_module_substitution ?ext c ctx ms)
+  | Psig_modsubst ms -> hvbox 0 (fmt_module_substitution c ctx ms)
   | Psig_open od -> fmt_open_description ?ext c ~kw_attributes:[] od
   | Psig_recmodule mds ->
-      fmt_recmodule c ctx mds
-        (fmt_module_declaration ?ext)
-        (fun x -> Md x)
-        sub_md
+      fmt_recmodule c ctx mds fmt_module_declaration (fun x -> Md x) sub_md
   | Psig_type (rec_flag, decls) -> fmt_type c ?ext rec_flag decls ctx
   | Psig_typext te -> fmt_type_extension ?ext c ctx te
   | Psig_value vd -> fmt_value_description ?ext c ctx vd
@@ -3720,8 +3731,9 @@ and fmt_class_exprs ?ext c ctx cls =
          $ hovbox 0
            @@ Cmts.fmt c cl.pci_loc (doc_before $ class_exprs $ doc_after) )
 
-and fmt_module c ctx ?rec_ ?ext ?epi ?(can_sparse = false) keyword
-    ?(eqty = "=") name xargs xbody xmty attributes ~rec_flag =
+and fmt_module c ctx ?rec_ ?epi ?(can_sparse = false) keyword ?(eqty = "=")
+    name xargs xbody xmty ~attrs ~rec_flag =
+  let ext = attrs.attrs_extension in
   let blk_t =
     Option.value_map xmty ~default:empty ~f:(fun xmty ->
         let blk = fmt_module_type ?rec_ c xmty in
@@ -3763,24 +3775,25 @@ and fmt_module c ctx ?rec_ ?ext ?epi ?(can_sparse = false) keyword
         let bdy, epi = fmt_arg ~pro hd in
         bdy $ fmt_args ~pro:epi tl
   in
-  let intro =
-    str keyword
-    $ fmt_extension_suffix c ext
-    $ fmt_if rec_flag " rec" $ str " " $ fmt_str_loc_opt c name
-  in
   let single_line =
     Option.for_all xbody ~f:(fun x -> Mod.is_simple x.ast)
     && Option.for_all xmty ~f:(fun x -> Mty.is_simple x.ast)
     && List.for_all xargs ~f:(function {txt= Unit; _} -> true | _ -> false)
   in
+  let doc_before, doc_after, attrs_before, attrs_after =
+    fmt_docstring_around_item_attrs c ~force_before:(not single_line)
+      ~fit:true attrs
+  in
+  let intro =
+    str keyword
+    $ fmt_extension_suffix c ext
+    $ fmt_attributes c ~pre:(Break (1, 0)) attrs_before
+    $ fmt_if rec_flag " rec" $ str " " $ fmt_str_loc_opt c name
+  in
   let compact =
     Poly.(c.conf.fmt_opts.let_module.v = `Compact) || not can_sparse
   in
   let fmt_pro = opt blk_b.pro (fun pro -> fmt "@ " $ pro) in
-  let doc_before, doc_after, atrs =
-    fmt_docstring_around_item c ~force_before:(not single_line) ~fit:true
-      attributes
-  in
   hvbox
     (if compact then 0 else 2)
     ( doc_before
@@ -3799,7 +3812,7 @@ and fmt_module c ctx ?rec_ ?ext ?epi ?(can_sparse = false) keyword
         $ fmt_if (Option.is_none blk_b.pro && Option.is_some xbody) "@ "
         $ blk_b.bdy )
     $ blk_b.esp $ fmt_opt blk_b.epi
-    $ fmt_item_attributes c ~pre:(Break (1, 0)) atrs
+    $ fmt_item_attributes c ~pre:(Break (1, 0)) attrs_after
     $ doc_after
     $ opt epi (fun epi ->
           fmt_or_k compact
@@ -3810,26 +3823,25 @@ and fmt_module c ctx ?rec_ ?ext ?epi ?(can_sparse = false) keyword
             (fmt "@;<1 -2>")
           $ epi ) )
 
-and fmt_module_declaration ?ext c ~rec_flag ~first {ast= pmd; _} =
+and fmt_module_declaration c ~rec_flag ~first {ast= pmd; _} =
   protect c (Md pmd)
   @@
-  let {pmd_name; pmd_args; pmd_type; pmd_attributes; pmd_loc} = pmd in
-  update_config_maybe_disabled c pmd_loc pmd_attributes
+  let {pmd_name; pmd_args; pmd_type; pmd_ext_attrs= attrs; pmd_loc} = pmd in
+  update_config_maybe_disabled_attrs c pmd_loc attrs
   @@ fun c ->
   let ctx = Md pmd in
-  let ext = if first then ext else None in
   let keyword = if first then "module" else "and" in
   let xmty = sub_mty ~ctx pmd_type in
   let eqty =
     match xmty.ast.pmty_desc with Pmty_alias _ -> None | _ -> Some ":"
   in
   Cmts.fmt c pmd_loc
-    (fmt_module ~rec_:rec_flag ?ext c ctx keyword pmd_name pmd_args None
-       ?eqty (Some xmty) ~rec_flag:(rec_flag && first) pmd_attributes )
+    (fmt_module ~rec_:rec_flag c ctx keyword pmd_name pmd_args None ?eqty
+       (Some xmty) ~rec_flag:(rec_flag && first) ~attrs )
 
-and fmt_module_substitution ?ext c ctx pms =
-  let {pms_name; pms_manifest; pms_attributes; pms_loc} = pms in
-  update_config_maybe_disabled c pms_loc pms_attributes
+and fmt_module_substitution c ctx pms =
+  let {pms_name; pms_manifest; pms_ext_attrs= attrs; pms_loc} = pms in
+  update_config_maybe_disabled_attrs c pms_loc attrs
   @@ fun c ->
   let xmty =
     (* TODO: improve *)
@@ -3840,17 +3852,17 @@ and fmt_module_substitution ?ext c ctx pms =
   in
   let pms_name = {pms_name with txt= Some pms_name.txt} in
   Cmts.fmt c pms_loc
-    (fmt_module ?ext c ctx "module" ~eqty:":=" pms_name [] None (Some xmty)
-       pms_attributes ~rec_flag:false )
+    (fmt_module c ctx "module" ~eqty:":=" pms_name [] None (Some xmty) ~attrs
+       ~rec_flag:false )
 
-and fmt_module_type_declaration ?ext ?eqty c ctx pmtd =
-  let {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} = pmtd in
-  update_config_maybe_disabled c pmtd_loc pmtd_attributes
+and fmt_module_type_declaration ?eqty c ctx pmtd =
+  let {pmtd_name; pmtd_type; pmtd_ext_attrs= attrs; pmtd_loc} = pmtd in
+  update_config_maybe_disabled_attrs c pmtd_loc attrs
   @@ fun c ->
   let pmtd_name = {pmtd_name with txt= Some pmtd_name.txt} in
-  fmt_module ?ext ?eqty c ctx "module type" pmtd_name [] None ~rec_flag:false
+  fmt_module ?eqty c ctx "module type" pmtd_name [] None ~rec_flag:false
     (Option.map pmtd_type ~f:(sub_mty ~ctx))
-    pmtd_attributes
+    ~attrs
 
 and fmt_open_description ?ext c ?(keyword = "open") ~kw_attributes
     {popen_expr= popen_lid; popen_override; popen_attributes; popen_loc} =
@@ -3909,13 +3921,15 @@ and fmt_with_constraint c ctx ~pre = function
       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 "module type" m1 [] None ~rec_flag:false m2 []
+      $ fmt_module c ctx "module type" m1 [] None ~rec_flag:false m2
+          ~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 [] None ~rec_flag:false
-          m2 []
+          m2
+          ~attrs:(Ast_helper.Attr.ext_attrs ())
 
 and fmt_mod_apply c ctx loc attrs ~parens ~dock_struct me_f arg =
   match me_f.pmod_desc with
@@ -4184,7 +4198,7 @@ and fmt_structure_item c ~last:last_item ?ext ~semisemi
       let keyword = str "include" $ fmt_extension_suffix c ext $ fmt "@ " in
       fmt_module_statement c ~attributes ~keyword (sub_mod ~ctx pincl_mod)
   | Pstr_module mb ->
-      fmt_module_binding ?ext c ~rec_flag:false ~first:true (sub_mb ~ctx mb)
+      fmt_module_binding c ~rec_flag:false ~first:true (sub_mb ~ctx mb)
   | Pstr_open
       {popen_expr; popen_override; popen_attributes= attributes; popen_loc}
     ->
@@ -4201,9 +4215,7 @@ and fmt_structure_item c ~last:last_item ?ext ~semisemi
       fmt_module_statement c ~attributes ~keyword (sub_mod ~ctx popen_expr)
   | Pstr_primitive vd -> fmt_value_description ?ext c ctx vd
   | Pstr_recmodule mbs ->
-      fmt_recmodule c ctx mbs (fmt_module_binding ?ext)
-        (fun x -> Mb x)
-        sub_mb
+      fmt_recmodule c ctx mbs fmt_module_binding (fun x -> Mb x) sub_mb
   | Pstr_type (rec_flag, decls) -> fmt_type c ?ext rec_flag decls ctx
   | Pstr_typext te -> fmt_type_extension ?ext c ctx te
   | Pstr_value {pvbs_rec= rec_flag; pvbs_bindings= bindings; pvbs_extension}
@@ -4228,7 +4240,7 @@ and fmt_structure_item c ~last:last_item ?ext ~semisemi
         fmt_value_binding c ~rec_flag ?ext ?epi b
       in
       fmt_item_list c ctx update_config ast fmt_item bindings
-  | Pstr_modtype mtd -> fmt_module_type_declaration ?ext c ctx mtd
+  | Pstr_modtype mtd -> fmt_module_type_declaration c ctx mtd
   | Pstr_extension (ext, atrs) ->
       let doc_before, doc_after, atrs = fmt_docstring_around_item c atrs in
       let box =
@@ -4376,12 +4388,12 @@ and fmt_value_binding c ~rec_flag ?ext ?in_ ?epi
       $ epi )
   $ fmt_docstring c ~pro:(fmt "@\n") doc2
 
-and fmt_module_binding ?ext c ~rec_flag ~first {ast= pmb; _} =
+and fmt_module_binding c ~rec_flag ~first {ast= pmb; _} =
+  let {pmb_name; pmb_ext_attrs= attrs; _} = pmb in
   protect c (Mb pmb)
-  @@ update_config_maybe_disabled c pmb.pmb_loc pmb.pmb_attributes
+  @@ update_config_maybe_disabled_attrs c pmb.pmb_loc attrs
   @@ fun c ->
   let ctx = Mb pmb in
-  let ext = if first then ext else None in
   let keyword = if first then "module" else "and" in
   let xbody = sub_mod ~ctx pmb.pmb_expr in
   let xbody, xmty =
@@ -4395,9 +4407,8 @@ and fmt_module_binding ?ext c ~rec_flag ~first {ast= pmb; _} =
     | _ -> (xbody, None)
   in
   Cmts.fmt c pmb.pmb_loc
-    (fmt_module ~rec_:rec_flag ?ext c ctx keyword
-       ~rec_flag:(rec_flag && first) ~eqty:":" pmb.pmb_name pmb.pmb_args
-       (Some xbody) xmty pmb.pmb_attributes )
+    (fmt_module ~rec_:rec_flag c ctx keyword ~rec_flag:(rec_flag && first)
+       ~eqty:":" pmb_name pmb.pmb_args (Some xbody) xmty ~attrs )
 
 let fmt_toplevel_directive c ~semisemi dir =
   let fmt_dir_arg = function