Fix location of comment attached to the underscore of an open record (#…

…1208)

CHANGES.md

@@ -33,6 +33,7 @@
   + Fix break after Psig_include depending on presence of docstring (#1125) (Guillaume Petiot)
   + Remove some calls to if_newline and break_unless_newline and fix break before closing brackets (#1168) (Guillaume Petiot)
   + Fix unstable cmt in or-pattern (#1173) (Guillaume Petiot)
+  + Fix location of comment attached to the underscore of an open record (#1208) (Guillaume Petiot)
 
 #### Documentation
 

lib/Cmts.ml

@@ -45,13 +45,14 @@ let find_at_position t loc pos =
 module Loc_tree : sig
   include Non_overlapping_interval_tree.S with type itv = Location.t
 
-  val of_ast : (Ast_mapper.mapper -> 'a -> _) -> 'a -> t * Location.t list
+  val of_ast :
+    (Ast_mapper.mapper -> 'a -> _) -> 'a -> Source.t -> t * Location.t list
 end = struct
   include Non_overlapping_interval_tree.Make (Location)
 
   (* Use Ast_mapper to collect all locs in ast, and create tree of them. *)
 
-  let of_ast map_ast ast =
+  let of_ast map_ast ast src =
     let attribute (m : Ast_mapper.mapper) (attr : attribute) =
       match (attr.attr_name, attr.attr_payload) with
       | ( {txt= ("ocaml.doc" | "ocaml.text") as txt; _}
@@ -86,7 +87,15 @@ end = struct
       locs := loc :: !locs ;
       loc
     in
-    let mapper = Ast_mapper.{default_mapper with location; attribute} in
+    let pat m p =
+      ( match p.ppat_desc with
+      | Ppat_record (flds, Open) ->
+          Option.iter (Source.loc_of_underscore src flds p.ppat_loc)
+            ~f:(fun loc -> locs := loc :: !locs)
+      | _ -> () ) ;
+      Ast_mapper.default_mapper.pat m p
+    in
+    let mapper = Ast_mapper.{default_mapper with location; pat; attribute} in
     map_ast mapper ast |> ignore ;
     (of_list !locs, !locs)
 end
@@ -335,7 +344,7 @@ let init map_ast ~debug source asts comments_n_docstrings =
         Format.eprintf "%a %s %s@\n%!" Location.fmt loc txt
           (if Source.ends_line source loc then "eol" else "")) ) ;
   if not (List.is_empty comments) then (
-    let loc_tree, locs = Loc_tree.of_ast map_ast asts in
+    let loc_tree, locs = Loc_tree.of_ast map_ast asts source in
     if debug then
       List.iter locs ~f:(fun loc ->
           if not (Location.compare loc Location.none = 0) then

lib/Fmt_ast.ml

@@ -986,11 +986,15 @@ and fmt_pattern c ?pro ?parens ({ctx= ctx0; ast= pat} as xpat) =
             (last && not (is_open closed_flag))
             p1.sep_after_final p1.sep_after_non_final
       in
+      let fmt_underscore =
+        if is_open closed_flag then
+          opt (Source.loc_of_underscore c.source flds ppat_loc) (fun loc ->
+              Cmts.fmt c loc p2.wildcard)
+        else noop
+      in
       hvbox_if parens 0
         (wrap_if parens "(" ")"
-           (p1.box
-              ( list_fl flds fmt_field
-              $ fmt_if_k (is_open closed_flag) p2.wildcard )))
+           (p1.box (list_fl flds fmt_field $ fmt_underscore)))
   | Ppat_array [] ->
       hvbox 0
         (wrap_fits_breaks c.conf "[|" "|]" (Cmts.fmt_within c ppat_loc))

lib/Source.ml

@@ -299,3 +299,14 @@ let typed_expression (typ : Parsetree.core_type)
 let typed_pattern (typ : Parsetree.core_type) (pat : Parsetree.pattern) =
   if Location.compare_start typ.ptyp_loc pat.ppat_loc < 0 then `Type_first
   else `Pat_first
+
+let loc_of_underscore t flds (ppat_loc : Location.t) =
+  let end_last_field =
+    match List.last flds with
+    | Some (_, p) -> p.Parsetree.ppat_loc.loc_end
+    | None -> ppat_loc.loc_start
+  in
+  let loc_underscore = {ppat_loc with loc_start= end_last_field} in
+  let filter = function Parser.UNDERSCORE -> true | _ -> false in
+  let tokens = tokens_at t ~filter loc_underscore in
+  Option.map (List.hd tokens) ~f:snd

lib/Source.mli

@@ -75,3 +75,10 @@ val typed_expression :
 
 val typed_pattern :
   Parsetree.core_type -> Parsetree.pattern -> [`Type_first | `Pat_first]
+
+val loc_of_underscore :
+  t -> ('a * Parsetree.pattern) list -> Location.t -> Location.t option
+(** [loc_of_underscore source fields loc] returns the location of the
+    underscore at the end of the record pattern of location [loc] with fields
+    [fields], if the record pattern is open (it ends with an underscore),
+    otherwise returns [None]. *)

test/passing/record-loose.ml.ref

@@ -114,3 +114,5 @@ let x = {aaaaaaaaaa (* b *); b}
 type t = {a : (module S); b : (module S)}
 
 let _ = {a = (module M : S); b = (module M : S)}
+
+let to_string {x; _ (* we should print y *)} = string_of_int x

test/passing/record-tight_decl.ml.ref

@@ -114,3 +114,5 @@ let x = {aaaaaaaaaa (* b *); b}
 type t = {a: (module S); b: (module S)}
 
 let _ = {a = (module M : S); b = (module M : S)}
+
+let to_string {x; _ (* we should print y *)} = string_of_int x

test/passing/record.ml

@@ -119,3 +119,5 @@ let x =
 type t = { a : (module S); b : (module S) }
 
 let _ = { a = (module M : S); b = (module M : S) }
+
+let to_string {x; _ (* we should print y *)} = string_of_int x

test/passing/record.ml.ref

@@ -114,3 +114,5 @@ let x = {aaaaaaaaaa (* b *); b}
 type t = {a: (module S); b: (module S)}
 
 let _ = {a= (module M : S); b= (module M : S)}
+
+let to_string {x; _ (* we should print y *)} = string_of_int x