API: optional names for formatting boxes (#1083)

CHANGES.md

@@ -1,5 +1,6 @@
 ### (master)
 
+  + API: optional names for formatting boxes (#1083) (Guillaume Petiot)
   + Build: check ocamlformat error codes (#1084) (Etienne Millon)
   + Internal: clean Translation_unit (#1078) (Guillaume Petiot)
   + Build: use dune file generation in test/passing/dune (#1082) (Etienne Millon)

src/Fmt.ml

@@ -164,11 +164,14 @@ let box_depth_colors = [|32; 33; 94; 31; 35; 36|]
 let box_depth_color () =
   box_depth_colors.(!box_depth % Array.length box_depth_colors)
 
-let debug_box_open box_kind n fs =
+let debug_box_open ?name box_kind n fs =
   if !box_debug_enabled then (
-    let openning =
-      if n = 0 then box_kind else Format.sprintf "%s<%d" box_kind n
+    let name =
+      match name with
+      | Some s -> Format.sprintf "%s:%s" box_kind s
+      | None -> box_kind
     in
+    let openning = if n = 0 then name else Format.sprintf "%s<%d" name n in
     pp_color_k (box_depth_color ())
       (fun fs -> Format.fprintf fs "@<0>[@<0>%s@<0>>" openning)
       fs ;
@@ -185,35 +188,41 @@ let debug_box_close fs =
         (fun fs -> Format.fprintf fs "@<0>]")
         fs )
 
-let open_box n fs = debug_box_open "b" n fs ; Format.pp_open_box fs n
+let open_box ?name n fs =
+  debug_box_open ?name "b" n fs ;
+  Format.pp_open_box fs n
 
-and open_vbox n fs = debug_box_open "v" n fs ; Format.pp_open_vbox fs n
+and open_vbox ?name n fs =
+  debug_box_open ?name "v" n fs ;
+  Format.pp_open_vbox fs n
 
-and open_hvbox n fs = debug_box_open "hv" n fs ; Format.pp_open_hvbox fs n
+and open_hvbox ?name n fs =
+  debug_box_open ?name "hv" n fs ;
+  Format.pp_open_hvbox fs n
 
-and open_hovbox n fs =
-  debug_box_open "hov" n fs ;
+and open_hovbox ?name n fs =
+  debug_box_open ?name "hov" n fs ;
   Format.pp_open_hovbox fs n
 
 and close_box fs = debug_box_close fs ; Format.pp_close_box fs ()
 
 (** Wrapping boxes ------------------------------------------------------*)
 
-let cbox n = wrap_k (open_box n) close_box
+let cbox ?name n = wrap_k (open_box ?name n) close_box
 
-and vbox n = wrap_k (open_vbox n) close_box
+and vbox ?name n = wrap_k (open_vbox ?name n) close_box
 
-and hvbox n = wrap_k (open_hvbox n) close_box
+and hvbox ?name n = wrap_k (open_hvbox ?name n) close_box
 
-and hovbox n = wrap_k (open_hovbox n) close_box
+and hovbox ?name n = wrap_k (open_hovbox ?name n) close_box
 
-and cbox_if cnd n = wrap_if_k cnd (open_box n) close_box
+and cbox_if ?name cnd n = wrap_if_k cnd (open_box ?name n) close_box
 
-and vbox_if cnd n = wrap_if_k cnd (open_vbox n) close_box
+and vbox_if ?name cnd n = wrap_if_k cnd (open_vbox ?name n) close_box
 
-and hvbox_if cnd n = wrap_if_k cnd (open_hvbox n) close_box
+and hvbox_if ?name cnd n = wrap_if_k cnd (open_hvbox ?name n) close_box
 
-and hovbox_if cnd n = wrap_if_k cnd (open_hovbox n) close_box
+and hovbox_if ?name cnd n = wrap_if_k cnd (open_hovbox ?name n) close_box
 
 (** Text filling --------------------------------------------------------*)
 

src/Fmt.mli

@@ -163,44 +163,44 @@ val with_box_debug : t -> t
 (** Represent boxes inside a format thunk with colored brackets. For debug
     purposes *)
 
-val open_vbox : int -> t
+val open_vbox : ?name:string -> int -> t
 (** Open an vbox with specified indentation. *)
 
-val open_hvbox : int -> t
+val open_hvbox : ?name:string -> int -> t
 (** Open an hvbox with specified indentation. *)
 
-val open_hovbox : int -> t
+val open_hovbox : ?name:string -> int -> t
 (** Open an hovbox with specified indentation. *)
 
 val close_box : t
 (** Close an arbitrary box. *)
 
 (** Wrapping boxes ------------------------------------------------------*)
 
-val cbox : int -> t -> t
+val cbox : ?name:string -> int -> t -> t
 (** Wrap a format thunk with a compacting box with specified indentation. *)
 
-val vbox : int -> t -> t
+val vbox : ?name:string -> int -> t -> t
 (** Wrap a format thunk with a vbox with specified indentation. *)
 
-val hvbox : int -> t -> t
+val hvbox : ?name:string -> int -> t -> t
 (** Wrap a format thunk with an hvbox with specified indentation. *)
 
-val hovbox : int -> t -> t
+val hovbox : ?name:string -> int -> t -> t
 (** Wrap a format thunk with an hovbox with specified indentation. *)
 
-val cbox_if : bool -> int -> t -> t
+val cbox_if : ?name:string -> bool -> int -> t -> t
 (** Conditionally wrap a format thunk with a compacting sbox with specified
     indentation. *)
 
-val vbox_if : bool -> int -> t -> t
+val vbox_if : ?name:string -> bool -> int -> t -> t
 (** Conditionally wrap a format thunk with a vbox with specified indentation. *)
 
-val hvbox_if : bool -> int -> t -> t
+val hvbox_if : ?name:string -> bool -> int -> t -> t
 (** Conditionally wrap a format thunk with an hvbox with specified
     indentation. *)
 
-val hovbox_if : bool -> int -> t -> t
+val hovbox_if : ?name:string -> bool -> int -> t -> t
 (** Conditionally wrap a format thunk with an hovbox with specified
     indentation. *)
 

src/Fmt_ast.ml

@@ -1392,7 +1392,8 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0)
     in
     list_fl groups (fmt_args c ctx)
   in
-  hvbox_if box 0 @@ fmt_cmts
+  hvbox_if box 0 ~name:"expr"
+  @@ fmt_cmts
   @@ (fun fmt -> Option.call ~f:pro $ fmt)
   @@
   match pexp_desc with
@@ -3923,7 +3924,8 @@ and fmt_structure_item c ~last:last_item ?ext {ctx; ast= si} =
   in
   let pro = fmt_or maybe_box "@ " "\n@;<1000 0>" in
   let fmt_cmts_after = Cmts.fmt_after ~pro c si.pstr_loc in
-  (fun k -> fmt_cmts_before $ hvbox_if maybe_box 0 (k $ fmt_cmts_after))
+  (fun k ->
+    fmt_cmts_before $ hvbox_if maybe_box 0 ~name:"stri" (k $ fmt_cmts_after))
   @@
   match si.pstr_desc with
   | Pstr_attribute atr ->
@@ -3934,10 +3936,10 @@ and fmt_structure_item c ~last:last_item ?ext {ctx; ast= si} =
       let doc, atrs = doc_atrs atrs in
       fmt_if (not skip_double_semi) ";;@;<1000 0>"
       $ fmt_docstring c doc
-      $ cbox 0 (fmt_expression c (sub_exp ~ctx exp))
+      $ cbox 0 ~name:"eval" (fmt_expression c (sub_exp ~ctx exp))
       $ fmt_attributes c ~pre:(str " ") ~key:"@@" atrs
   | Pstr_exception extn_constr ->
-      hvbox 2
+      hvbox 2 ~name:"exn"
         (fmt_type_exception ~pre:(fmt "exception@ ") c (str ": ") ctx
            extn_constr)
   | Pstr_include {pincl_mod; pincl_attributes= attributes; pincl_loc} ->
@@ -4004,7 +4006,7 @@ and fmt_structure_item c ~last:last_item ?ext {ctx; ast= si} =
                 ?ext:(if first && first_grp then ext else None)
                 ctx ?epi ~attributes ~loc pvb_pat pvb_expr)
       in
-      hvbox 0
+      hvbox 0 ~name:"value"
         (list_fl grps (fun ~first ~last grp ->
              fmt_grp ~first ~last grp $ fmt_if (not last) "\n@;<1000 0>"))
   | Pstr_modtype mtd -> fmt_module_type_declaration c ctx mtd
@@ -4015,9 +4017,9 @@ and fmt_structure_item c ~last:last_item ?ext {ctx; ast= si} =
         | PTyp _ | PPat _ | PStr [_] | PSig [_] -> true
         | PStr _ | PSig _ -> false
       in
-      hvbox_if box c.conf.stritem_extension_indent
+      hvbox_if box c.conf.stritem_extension_indent ~name:"ext1"
         ( doc_before
-        $ hvbox_if (not box) 0 (fmt_extension c ctx "%%" ext)
+        $ hvbox_if (not box) 0 ~name:"ext2" (fmt_extension c ctx "%%" ext)
         $ fmt_attributes c ~pre:(str " ") ~key:"@@" atrs
         $ doc_after )
   | Pstr_class_type cl -> fmt_class_types c ctx ~pre:"class type" ~sep:"=" cl