Dock indent a fun passed as a labelled argument (#2271)

Avoid adding breaks inside '~label:(fun' and base the indentation on the label. This is similar to what we've done to functions in 92ba086. Some care is needed for comments between the ':' and the '(fun'
ocaml-ppx · Mar 9, 2023 · 869ea50 · 869ea50
1 parent 9167713
commit 869ea50
Show file tree

Hide file tree

Showing 8 changed files with 76 additions and 8 deletions.
diff --git a/CHANGES.md b/CHANGES.md
@@ -6,6 +6,8 @@
 
 ### Bug fixes
 
+- Avoid adding breaks inside `~label:(fun` and base the indentation on the label. (#2271, @Julow)
+
 ### Changes
 
 ### New features

diff --git a/lib/Conf_decl.ml b/lib/Conf_decl.ml
@@ -438,8 +438,8 @@ let removed_option ~names ~since ~msg =
 let update store ~config ~from:new_from ~name ~value ~inline =
   List.find_map store
     ~f:(fun
-         (Pack {names; parse; update; allow_inline; get_value; to_string; _})
-       ->
+      (Pack {names; parse; update; allow_inline; get_value; to_string; _})
+    ->
       if List.exists names ~f:(String.equal name) then
         if inline && not allow_inline then
           Some (Error (Error.Misplaced (name, value)))

diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml
@@ -1822,9 +1822,13 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0)
         when List.for_all rev_e1N ~f:(fun (_, eI) ->
                  is_simple c.conf (fun _ -> 0) (sub_exp ~ctx eI) ) ->
           let e1N = List.rev rev_e1N in
-          (* side effects of Cmts.fmt c.cmts before Sugar.fun_ is
-             important *)
-          let cmts_before = Cmts.fmt_before c pexp_loc in
+          (* Make sure the comment is placed after the eventual label but not
+             into the inner box if no label is present. Side effects of
+             Cmts.fmt c.cmts before Sugar.fun_ is important. *)
+          let cmts_outer, cmts_inner =
+            let cmt = Cmts.fmt_before c pexp_loc in
+            match lbl with Nolabel -> (cmt, noop) | _ -> (noop, cmt)
+          in
           let xargs, xbody = Sugar.fun_ c.cmts (sub_exp ~ctx eN1) in
           let fmt_cstr, xbody = type_constr_and_body c xbody in
           let box =
@@ -1842,11 +1846,13 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0)
                (hovbox 0
                   ( hovbox 2
                       ( wrap
-                          ( fmt_args_grouped e0 e1N $ fmt "@ "
-                          $ fmt_label lbl ":" $ cmts_before
+                          ( fmt_args_grouped e0 e1N $ fmt "@ " $ cmts_outer
                           $ hvbox 0
                               ( hvbox 2
-                                  ( fmt "(fun@ "
+                                  ( hvbox 0
+                                      ( fmt_label lbl ":" $ cmts_inner
+                                      $ fmt "(fun" )
+                                  $ fmt "@ "
                                   $ fmt_attributes c eN1.pexp_attributes
                                       ~suf:" "
                                   $ fmt_fun_args c xargs $ fmt_opt fmt_cstr

diff --git a/test/passing/tests/js_source.ml b/test/passing/tests/js_source.ml
@@ -7642,3 +7642,11 @@ let bind t ~f =
          | Yield { value = a; state = s } ->
            Yield { value = a; state = Sequence { state = s; next }, rest }))
     ~init:(empty, t)
+
+let () =
+  very_long_function_name
+    ~very_long_argument_label:(fun
+                                very_long_argument_name_one
+                                very_long_argument_name_two
+                                very_long_argument_name_three
+                              -> () )
diff --git a/test/passing/tests/js_source.ml.ocp b/test/passing/tests/js_source.ml.ocp
@@ -9865,3 +9865,12 @@ let bind t ~f =
            Yield { value = a; state = Sequence { state = s; next }, rest }))
     ~init:(empty, t)
 ;;
+
+let () =
+  very_long_function_name
+    ~very_long_argument_label:(fun
+                                very_long_argument_name_one
+                                very_long_argument_name_two
+                                very_long_argument_name_three
+                                -> ())
+;;
diff --git a/test/passing/tests/js_source.ml.ref b/test/passing/tests/js_source.ml.ref
@@ -9865,3 +9865,12 @@ let bind t ~f =
            Yield { value = a; state = Sequence { state = s; next }, rest }))
     ~init:(empty, t)
 ;;
+
+let () =
+  very_long_function_name
+    ~very_long_argument_label:(fun
+      very_long_argument_name_one
+      very_long_argument_name_two
+      very_long_argument_name_three
+    -> ())
+;;
diff --git a/test/passing/tests/labelled_args-414.ml.ref b/test/passing/tests/labelled_args-414.ml.ref
@@ -1,3 +1,20 @@
 let _ =
   let f ~y = y + 1 in
   f ~(y : int)
+
+let () =
+  very_long_function_name
+    ~very_long_argument_label:(fun
+      very_long_argument_name_one
+      very_long_argument_name_two
+      very_long_argument_name_three
+    -> () )
+
+let () =
+  very_long_function_name
+    ~very_long_argument_label:(* foo *)
+    (fun
+      very_long_argument_name_one
+      very_long_argument_name_two
+      very_long_argument_name_three
+    -> () )
diff --git a/test/passing/tests/labelled_args.ml b/test/passing/tests/labelled_args.ml
@@ -1,3 +1,20 @@
 let _ =
   let f ~y = y + 1 in
   f ~y:(y : int)
+
+let () =
+  very_long_function_name
+    ~very_long_argument_label:(fun
+      very_long_argument_name_one
+      very_long_argument_name_two
+      very_long_argument_name_three
+    -> () )
+
+let () =
+  very_long_function_name
+    ~very_long_argument_label:(* foo *)
+    (fun
+      very_long_argument_name_one
+      very_long_argument_name_two
+      very_long_argument_name_three
+    -> () )