Display comments in the loc_tree for debugging (ocaml-ppx#1665)

Author: Guillaume Petiot

lib/Cmts.ml

@@ -158,34 +158,10 @@ end = struct
     | _ -> (empty, cmts)
 end
 
-let position_to_string = function
-  | `Before -> "before"
-  | `After -> "after"
-  | `Within -> "within"
-
-let add_cmts t ?prev ?next position loc cmts =
-  if not (CmtSet.is_empty cmts) then (
+let add_cmts t position loc cmts =
+  if not (CmtSet.is_empty cmts) then
     let cmtl = CmtSet.to_list cmts in
-    if t.debug then
-      List.iter cmtl ~f:(fun {Cmt.txt= cmt_txt; loc= cmt_loc} ->
-          let string_between (l1 : Location.t) (l2 : Location.t) =
-            match Source.string_between t.source l1.loc_end l2.loc_start with
-            | None -> "swapped"
-            | Some s -> s
-          in
-          let btw_prev =
-            Option.value_map prev ~default:"no prev"
-              ~f:(Fn.flip string_between cmt_loc)
-          in
-          let btw_next =
-            Option.value_map next ~default:"no next"
-              ~f:(string_between cmt_loc)
-          in
-          Caml.Format.eprintf "add %s %a: %a \"%s\" %s \"%s\"@\n%!"
-            (position_to_string position)
-            Location.fmt loc Location.fmt cmt_loc (String.escaped btw_prev)
-            cmt_txt (String.escaped btw_next) ) ;
-    update_cmts t position ~f:(Map.add_exn ~key:loc ~data:cmtl) )
+    update_cmts t position ~f:(Map.add_exn ~key:loc ~data:cmtl)
 
 (** Traverse the location tree from locs, find the deepest location that
     contains each comment, intersperse comments between that location's
@@ -205,19 +181,17 @@ let rec place t loc_tree ?prev_loc locs cmts =
             let after_prev, before_curr =
               CmtSet.partition t.source ~prev:prev_loc ~next:curr_loc before
             in
-            add_cmts t `After ~prev:prev_loc ~next:curr_loc prev_loc
-              after_prev ;
+            add_cmts t `After prev_loc after_prev ;
             before_curr
       in
-      add_cmts t `Before ?prev:prev_loc ~next:curr_loc curr_loc before_curr ;
+      add_cmts t `Before curr_loc before_curr ;
       ( match Loc_tree.children loc_tree curr_loc with
-      | [] ->
-          add_cmts t `Within ?prev:prev_loc ~next:curr_loc curr_loc within
+      | [] -> add_cmts t `Within curr_loc within
       | children -> place t loc_tree children within ) ;
       place t loc_tree ~prev_loc:curr_loc next_locs after
   | [] -> (
     match prev_loc with
-    | Some prev_loc -> add_cmts t `After ~prev:prev_loc prev_loc cmts
+    | Some prev_loc -> add_cmts t `After prev_loc cmts
     | None ->
         if t.debug then
           List.iter (CmtSet.to_list cmts) ~f:(fun {Cmt.txt; _} ->
@@ -311,26 +285,30 @@ let init fragment ~debug source asts comments_n_docstrings =
     ; remove= true }
   in
   let comments = Normalize.dedup_cmts fragment asts comments_n_docstrings in
-  if debug then (
-    Format.eprintf "\nComments:\n%!" ;
-    List.iter comments ~f:(fun {Cmt.txt; loc} ->
-        Caml.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 fragment asts source in
     if debug then
       List.iter locs ~f:(fun loc ->
           if not (Location.compare loc Location.none = 0) then
             update_remaining t ~f:(fun s -> Set.add s loc) ) ;
-    if debug then (
-      let dump fs lt = Fmt.eval fs (Loc_tree.dump lt) in
-      Format.eprintf "\nLoc_tree:\n%!" ;
-      Format.eprintf "@\n%a@\n@\n%!" dump loc_tree ) ;
     let locs = Loc_tree.roots loc_tree in
     let cmts = CmtSet.of_list comments in
-    match locs with
-    | [] -> add_cmts t `After ~prev:Location.none Location.none cmts
+    ( match locs with
+    | [] -> add_cmts t `After Location.none cmts
     | _ -> place t loc_tree locs cmts ) ;
+    if debug then (
+      let dump fs lt =
+        let get_cmts pos loc =
+          let cmts = find_at_position t loc pos in
+          Option.map cmts ~f:(fun cmts -> List.map cmts ~f:Cmt.txt)
+        in
+        let cmts_before = get_cmts `Before in
+        let cmts_within = get_cmts `Within in
+        let cmts_after = get_cmts `After in
+        Fmt.eval fs (Loc_tree.dump ~cmts_before ~cmts_within ~cmts_after lt)
+      in
+      Format.eprintf "\nLoc_tree:\n%!" ;
+      Format.eprintf "@\n%a@\n@\n%!" dump loc_tree ) ) ;
   t
 
 let preserve fmt_x t =

lib/Non_overlapping_interval_tree.ml

@@ -30,7 +30,12 @@ module type S = sig
 
   val children : t -> itv -> itv list
 
-  val dump : t -> Fmt.t
+  val dump :
+       ?cmts_before:(itv -> string list option)
+    -> ?cmts_within:(itv -> string list option)
+    -> ?cmts_after:(itv -> string list option)
+    -> t
+    -> Fmt.t
   (** Debug: dump debug representation of tree. *)
 end
 
@@ -95,14 +100,25 @@ module Make (Itv : IN) = struct
 
   let children {map; _} elt = Option.value ~default:[] (Map.find map elt)
 
-  let dump tree =
+  let dump ?cmts_before ?cmts_within ?cmts_after tree =
     let open Fmt in
+    let dump_cmts lbl cmts loc =
+      opt cmts (fun find ->
+          opt (find loc) (fun cmts ->
+              break 1 8
+              $ list cmts "@;<1 8>" (fun k ->
+                    str lbl $ str ": " $ wrap "(*" "*)" (str k) ) ) )
+    in
     let rec dump_ tree roots =
       vbox 0
         (list roots "@," (fun root ->
              let children = children tree root in
              vbox 1
-               ( str (Sexp.to_string_hum (Itv.comparator.sexp_of_t root))
+               ( vbox 0
+                   ( str (Sexp.to_string_hum (Itv.comparator.sexp_of_t root))
+                   $ dump_cmts "before" cmts_before root
+                   $ dump_cmts "within" cmts_within root
+                   $ dump_cmts "after" cmts_after root )
                $ wrap_if
                    (not (List.is_empty children))
                    "@,{" " }" (dump_ tree children) ) ) )

lib/Non_overlapping_interval_tree.mli

@@ -34,7 +34,12 @@ module type S = sig
 
   val children : t -> itv -> itv list
 
-  val dump : t -> Fmt.t
+  val dump :
+       ?cmts_before:(itv -> string list option)
+    -> ?cmts_within:(itv -> string list option)
+    -> ?cmts_after:(itv -> string list option)
+    -> t
+    -> Fmt.t
   (** Debug: dump debug representation of tree. *)
 end
 

lib/Source.ml

@@ -22,19 +22,6 @@ let create ~text ~tokens =
   in
   {text; tokens= Array.of_list tokens}
 
-let string_between (t : t) (p1 : Lexing.position) (p2 : Lexing.position) =
-  let pos = p1.pos_cnum in
-  let len = Position.distance p1 p2 in
-  if
-    len < 0 || pos < 0
-    (* can happen e.g. if comment is within a parenthesized expression *)
-  then None
-  else if
-    String.length t.text < pos + len
-    (* can happen e.g. if source is not available *)
-  then None
-  else Some (String.sub t.text ~pos ~len)
-
 let string_at t (l : Location.t) =
   let pos = l.loc_start.Lexing.pos_cnum
   and len = Position.distance l.loc_start l.loc_end in

lib/Source.mli

@@ -25,8 +25,6 @@ val empty_line_before : t -> Location.t -> bool
 
 val empty_line_after : t -> Location.t -> bool
 
-val string_between : t -> Lexing.position -> Lexing.position -> string option
-
 val tokens_between :
      t
   -> filter:(Parser.token -> bool)

test/cli/debug.t

@@ -7,52 +7,150 @@
 
   $ ocamlformat --debug a.ml
 
-  Comments:
-  ([1,0+0]..[1,0+33])  Intentionally not formatted  eol
-  
   Loc_tree:
   "([2,34+0]..[4,59+7])"
+          before: (* Intentionally not formatted *)
    {"([2,34+4]..[2,34+6])"
     "([3,43+2]..[4,59+7])"
      {"([3,43+2]..[3,43+15])"
       "([4,59+4]..[4,59+7])" } }
 
-  add before ([2,34+0]..[4,59+7]): ([1,0+0]..[1,0+33]) "no prev"  Intentionally not formatted  "\n"
-  
-  Comments:
-  ([1,0+0]..[1,0+33])  Intentionally not formatted  eol
 
   Loc_tree:
   "([2,34+0]..[4,59+7])"
+          before: (* Intentionally not formatted *)
    {"([2,34+4]..[2,34+6])"
     "([3,43+2]..[4,59+7])"
      {"([3,43+2]..[3,43+15])"
       "([4,59+4]..[4,59+7])" } }
 
-  add before ([2,34+0]..[4,59+7]): ([1,0+0]..[1,0+33]) "no prev"  Intentionally not formatted  "\n"
-  
-  Comments:
-  ([1,0+0]..[1,0+33])  Intentionally not formatted  eol
 
   Loc_tree:
   "([2,34+0]..[2,34+26])"
+          before: (* Intentionally not formatted *)
    {"([2,34+4]..[2,34+6])"
     "([2,34+9]..[2,34+26])"
      {"([2,34+9]..[2,34+22])"
       "([2,34+23]..[2,34+26])" } }
 
-  add before ([2,34+0]..[2,34+26]): ([1,0+0]..[1,0+33]) "no prev"  Intentionally not formatted  "\n"
-  
-  Comments:
-  ([1,0+0]..[1,0+33])  Intentionally not formatted  eol
 
   Loc_tree:
   "([2,34+0]..[2,34+26])"
+          before: (* Intentionally not formatted *)
    {"([2,34+4]..[2,34+6])"
     "([2,34+9]..[2,34+26])"
      {"([2,34+9]..[2,34+22])"
       "([2,34+23]..[2,34+26])" } }
 
-  add before ([2,34+0]..[2,34+26]): ([1,0+0]..[1,0+33]) "no prev"  Intentionally not formatted  "\n"
   (* Intentionally not formatted *)
   let () = print_endline A.x
+
+  $ cat > a.ml << EOF
+  > (* before let-binding *)
+  > let () =
+  >   (* before x binding #1 *)
+  >   (* before x binding #2 *)
+  >   let (* before x *) x (* after x #1 *) (* after x #2 *) = (* before unit *) ( (* within unit #1 *) (* within unit #2 *) ) (* after unit *) in
+  >   x
+  > (* after let-binding *)
+  > EOF
+
+  $ ocamlformat --debug a.ml
+  
+  Loc_tree:
+  "([2,25+0]..[6,233+3])"
+          before: (* before let-binding *)
+          after: (* after let-binding *)
+   {"([2,25+4]..[2,25+6])"
+    "([5,90+2]..[6,233+3])"
+            before: (* before x binding #1 *)
+            before: (* before x binding #2 *)
+     {"([5,90+2]..[5,90+122])"
+              after: (* after unit *)
+       {"([5,90+21]..[5,90+22])"
+                before: (* before x *)
+                after: (* after x #1 *)
+                after: (* after x #2 *)
+        "([5,90+77]..[5,90+122])"
+                before: (* before unit *)
+                within: (* within unit #1 *)
+                within: (* within unit #2 *) }
+      "([6,233+2]..[6,233+3])" } }
+  
+  
+  Loc_tree:
+  "([2,25+0]..[6,233+3])"
+          before: (* before let-binding *)
+          after: (* after let-binding *)
+   {"([2,25+4]..[2,25+6])"
+    "([5,90+2]..[6,233+3])"
+            before: (* before x binding #1 *)
+            before: (* before x binding #2 *)
+     {"([5,90+2]..[5,90+122])"
+              after: (* after unit *)
+       {"([5,90+21]..[5,90+22])"
+                before: (* before x *)
+                after: (* after x #1 *)
+                after: (* after x #2 *)
+        "([5,90+77]..[5,90+122])"
+                before: (* before unit *)
+                within: (* within unit #1 *)
+                within: (* within unit #2 *) }
+      "([6,233+2]..[6,233+3])" } }
+  
+  
+  Loc_tree:
+  "([2,25+0]..[13,265+3])"
+          before: (* before let-binding *)
+          after: (* after let-binding *)
+   {"([2,25+4]..[2,25+6])"
+    "([5,90+2]..[13,265+3])"
+            before: (* before x binding #1 *)
+            before: (* before x binding #2 *)
+     {"([5,90+2]..[10,210+28])"
+              after: (* after unit *)
+       {"([5,90+21]..[5,90+22])"
+                before: (* before x *)
+                after: (* after x #1 *)
+                after: (* after x #2 *)
+        "([9,183+4]..[10,210+28])"
+                before: (* before unit *)
+                within: (* within unit #1 *)
+                within: (* within unit #2 *) }
+      "([13,265+2]..[13,265+3])" } }
+  
+  
+  Loc_tree:
+  "([2,25+0]..[13,265+3])"
+          before: (* before let-binding *)
+          after: (* after let-binding *)
+   {"([2,25+4]..[2,25+6])"
+    "([5,90+2]..[13,265+3])"
+            before: (* before x binding #1 *)
+            before: (* before x binding #2 *)
+     {"([5,90+2]..[10,210+28])"
+              after: (* after unit *)
+       {"([5,90+21]..[5,90+22])"
+                before: (* before x *)
+                after: (* after x #1 *)
+                after: (* after x #2 *)
+        "([9,183+4]..[10,210+28])"
+                before: (* before unit *)
+                within: (* within unit #1 *)
+                within: (* within unit #2 *) }
+      "([13,265+2]..[13,265+3])" } }
+  
+  (* before let-binding *)
+  let () =
+    (* before x binding #1 *)
+    (* before x binding #2 *)
+    let (* before x *) x
+        (* after x #1 *)
+        (* after x #2 *) =
+      (* before unit *)
+      ( (* within unit #1 *)
+        (* within unit #2 *) )
+      (* after unit *)
+    in
+    x
+  (* after let-binding *)