On top of ocaml-ppx#2298

CHANGES.md

@@ -7,7 +7,7 @@
 ### Bug fixes
 
 - Consistent indentation of `fun (type a) ->` that follow `fun x ->` (#2294, @Julow)
-- Avoid adding breaks inside `~label:(fun` and base the indentation on the label. (#2271, #2291, #2293, @Julow)
+- Avoid adding breaks inside `~label:(fun` and base the indentation on the label. (#2271, #2291, #2293, #2298, @Julow)
 - Fix non-stabilizing comments attached to private/virtual/mutable keywords (#2272, @gpetiot)
 - Fix formatting of comments in "disable" chunks (#2279, @gpetiot)
 - Fix indentation of trailing double-semicolons (#2295, @gpetiot)

lib/Fmt_ast.ml

@@ -1329,8 +1329,46 @@ and fmt_indexop_access c ctx ~fmt_atrs ~has_attr ~parens x =
                  fmt_assign_arrow c $ fmt_expression c (sub_exp ~ctx e) ) )
        $ fmt_atrs ) )
 
-and fmt_label_arg ?(box = true) ?epi ?parens ?eol c
-    (lbl, ({ast= arg; _} as xarg)) =
+(** Format [Pexp_fun] or [Pexp_newtype]. [wrap_intro] wraps up to after the
+    [->] and is responsible for breaking. *)
+and fmt_fun ?force_closing_paren
+    ?(wrap_intro = fun x -> hvbox 2 x $ fmt "@ ") ?(box = true) ~label
+    ?(parens = false) c ({ast; _} as xast) =
+  (* Side effects of Cmts.fmt c.cmts before Sugar.fun_ is important. *)
+  let cmt_before =
+    let eol =
+      match label with Nolabel -> None | _ -> Some (fmt "@;<9999 2>")
+    in
+    Cmts.fmt_before ?eol c ast.pexp_loc
+  in
+  let xargs, xbody = Sugar.fun_ c.cmts xast in
+  let fmt_cstr, xbody = type_constr_and_body c xbody in
+  let body =
+    let box =
+      match xbody.ast.pexp_desc with
+      | Pexp_fun _ | Pexp_newtype _ | Pexp_function _ -> Some false
+      | _ -> None
+    in
+    fmt_expression c ?box xbody
+  and closing =
+    if parens then closing_paren c ?force:force_closing_paren ~offset:(-2)
+    else noop
+  in
+  hovbox_if box 2
+    ( wrap_intro
+        (hvbox 2
+           ( hvbox 2
+               ( hvbox 0
+                   ( fmt_label label ":" $ cmt_before $ fmt_if parens "("
+                   $ fmt "fun" )
+               $ fmt "@ "
+               $ fmt_attributes c ast.pexp_attributes ~suf:" "
+               $ fmt_fun_args c xargs $ fmt_opt fmt_cstr )
+           $ fmt "@ ->" ) )
+    $ body $ closing
+    $ Cmts.fmt_after c ast.pexp_loc )
+
+and fmt_label_arg ?(box = true) ?epi ?eol c (lbl, ({ast= arg; _} as xarg)) =
   match (lbl, arg.pexp_desc) with
   | (Labelled l | Optional l), Pexp_ident {txt= Lident i; loc}
     when String.equal l i && List.is_empty arg.pexp_attributes ->
@@ -1348,45 +1386,23 @@ and fmt_label_arg ?(box = true) ?epi ?parens ?eol c
         | Optional _ -> str "?"
         | Nolabel -> noop
       in
-      lbl $ fmt_expression c ~box ?epi ?parens xarg
+      lbl $ fmt_expression c ~box ?epi xarg
   | (Labelled _ | Optional _), _ when Cmts.has_after c.cmts xarg.ast.pexp_loc
     ->
       let cmts_after = Cmts.fmt_after c xarg.ast.pexp_loc in
       hvbox_if box 2
         ( hvbox_if box 0
             (fmt_expression c
                ~pro:(fmt_label lbl ":@;<0 2>")
-               ~box ?epi ?parens xarg )
+               ~box ?epi xarg )
         $ cmts_after )
   | (Labelled _ | Optional _), (Pexp_fun _ | Pexp_newtype _) ->
-      (* Side effects of Cmts.fmt c.cmts before Sugar.fun_ is important. *)
-      let cmt_before = Cmts.fmt_before c arg.pexp_loc in
-      let xargs, xbody = Sugar.fun_ c.cmts xarg in
-      let fmt_cstr, xbody = type_constr_and_body c xbody in
-      let body =
-        let box =
-          match xbody.ast.pexp_desc with
-          | Pexp_fun _ | Pexp_newtype _ | Pexp_function _ -> Some false
-          | _ -> None
-        in
-        fmt "@ " $ fmt_expression c ?box xbody
-      in
-      hovbox_if box 2
-        ( hvbox 2
-            ( hvbox 2
-                ( hvbox 2 (fmt_label lbl ":" $ cmt_before $ fmt "(fun")
-                $ fmt "@ "
-                $ fmt_attributes c arg.pexp_attributes ~suf:" "
-                $ fmt_fun_args c xargs $ fmt_opt fmt_cstr )
-            $ fmt "@ ->" )
-        $ body
-        $ closing_paren c ~offset:(-2)
-        $ Cmts.fmt_after c arg.pexp_loc )
+      fmt_fun ~box ~label:lbl ~parens:true c xarg
   | _ ->
       let label_sep : s =
         if box || c.conf.fmt_opts.wrap_fun_args.v then ":@," else ":"
       in
-      fmt_label lbl label_sep $ fmt_expression c ~box ?epi ?parens xarg
+      fmt_label lbl label_sep $ fmt_expression c ~box ?epi xarg
 
 and expression_width c xe =
   String.length
@@ -1843,60 +1859,38 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0)
         if c.conf.fmt_opts.wrap_fun_args.v then Fn.id else hvbox 2
       in
       match List.rev e1N1 with
-      | (lbl, ({pexp_desc= Pexp_fun _; pexp_loc; _} as eN1)) :: rev_e1N
-        when List.for_all rev_e1N ~f:(fun (_, eI) ->
+      | (lbl, ({pexp_desc= Pexp_fun (_, _, _, eN1_body); _} as eN1))
+        :: rev_args_before
+        when List.for_all rev_args_before ~f:(fun (_, eI) ->
                  is_simple c.conf (fun _ -> 0) (sub_exp ~ctx eI) ) ->
-          let e1N = List.rev rev_e1N 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 =
-            match xbody.ast.pexp_desc with
-            | Pexp_fun _ | Pexp_function _ -> Some false
-            | _ -> None
-          in
-          let force =
-            if Location.is_single_line pexp_loc c.conf.fmt_opts.margin.v then
-              Fit
-            else Break
+          (* Last argument is a [fun _ ->]. *)
+          let args_before = List.rev rev_args_before in
+          let xlast_arg = sub_exp ~ctx eN1 in
+          let args =
+            let break_body =
+              match eN1_body.pexp_desc with
+              | Pexp_function _ -> fmt "@ "
+              | _ -> (
+                (* Avoid the "double indentation" of the application and the
+                   function matching when the [max-indent] option is set. *)
+                match c.conf.fmt_opts.max_indent.v with
+                | Some i when i <= 2 -> fmt "@ "
+                | _ -> fmt "@;<1 2>" )
+            in
+            let wrap_intro x =
+              wrap (fmt_args_grouped e0 args_before $ fmt "@ " $ x)
+              $ break_body
+            in
+            let force_closing_paren =
+              if Location.is_single_line pexp_loc c.conf.fmt_opts.margin.v
+              then Fit
+              else Break
+            in
+            hovbox 0
+              (fmt_fun c ~force_closing_paren ~wrap_intro ~label:lbl
+                 ~parens:true xlast_arg )
           in
-          hvbox 0
-            (Params.parens_if parens c.conf
-               (hovbox 0
-                  ( hovbox 2
-                      ( wrap
-                          ( fmt_args_grouped e0 e1N $ fmt "@ " $ cmts_outer
-                          $ hvbox 2
-                              ( hvbox 2
-                                  ( 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
-                                  )
-                              $ fmt "@ ->" ) )
-                      $ fmt
-                          ( match xbody.ast.pexp_desc with
-                          | Pexp_function _ -> "@ "
-                          | _ -> (
-                            (* Avoid the "double indentation" of the
-                               application and the function matching when the
-                               [max-indent] option is set. *)
-                            match c.conf.fmt_opts.max_indent.v with
-                            | Some i when i <= 2 -> "@ "
-                            | _ -> "@;<1 2>" ) )
-                      $ fmt_expression c ?box xbody
-                      $ closing_paren c ~force ~offset:(-2)
-                      $ Cmts.fmt_after c pexp_loc )
-                  $ fmt_atrs ) ) )
+          hvbox 0 (Params.parens_if parens c.conf (args $ fmt_atrs))
       | ( lbl
         , ( { pexp_desc= Pexp_function [{pc_lhs; pc_guard= None; pc_rhs}]
             ; pexp_loc

test/passing/tests/eliom_ext.eliom

@@ -6,8 +6,9 @@ let%client () =
   Eliom_client.onload
     (* NB The service underlying the server_function isn't available on the
        client before loading the page. *)
-    (fun () ->
-      Lwt.async (fun () -> log "Hello from the client to the server!") )
+    (fun
+      ()
+      -> Lwt.async (fun () -> log "Hello from the client to the server!") )
 
 let%client () =
   Eliom_client.onload

test/passing/tests/indicate_multiline_delimiters-cosl.ml.ref

@@ -44,3 +44,8 @@ let contrived =
       f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
     )
     l
+
+let contrived =
+  List.map l ~f:(fun aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa ->
+      f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa
+  )

test/passing/tests/indicate_multiline_delimiters-space.ml.ref

@@ -39,3 +39,7 @@ let contrived =
     ~f:(fun aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa ->
       f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa )
     l
+
+let contrived =
+  List.map l ~f:(fun aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa ->
+      f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa )

test/passing/tests/indicate_multiline_delimiters.ml

@@ -39,3 +39,7 @@ let contrived =
     ~f:(fun aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa ->
       f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa)
     l
+
+let contrived =
+  List.map l ~f:(fun aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa ->
+      f aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa)

test/passing/tests/issue289.ml

@@ -33,31 +33,31 @@ let foo =
       ~doc:"Toy ID."
       ~args:[]
       ~typ:(non_null guid)
-      ~resolve:(fun _ctx x -> x.id)
+      ~resolve:(fun _ctx x -> x.id )
   ; field
       "name"
       ~doc:"Toy name."
       ~args:[]
       ~typ:(non_null string)
-      ~resolve:(fun _ctx x -> x.name)
+      ~resolve:(fun _ctx x -> x.name )
   ; field
       "description"
       ~doc:"Toy description."
       ~args:[]
       ~typ:string
-      ~resolve:(fun _ctx x -> x.description |> Util.option_of_string)
+      ~resolve:(fun _ctx x -> x.description |> Util.option_of_string )
   ; field
       "type"
       ~doc:"Toy type. Possible values are: car, animal, train."
       ~args:[]
       ~typ:(non_null toy_type_enum)
-      ~resolve:(fun _ctx x -> x.toy_type)
+      ~resolve:(fun _ctx x -> x.toy_type )
   ; field
       "createdAt"
       ~doc:"Date created."
       ~args:[]
       ~typ:(non_null Scalar.date_time)
-      ~resolve:(fun _ctx x -> x.created_at) ]
+      ~resolve:(fun _ctx x -> x.created_at ) ]
 
 [@@@ocamlformat "wrap-fun-args=true"]
 
@@ -82,14 +82,14 @@ let foo =
       | AAAAAAAAAAAAAAAAAAAa -> x.idddddddddddddddddddddddddd
       | BBBBBBBBBBBBBBBB -> ccccccccccccccccccccccc )
   ; field "id" ~doc:"Toy ID." ~args:[] ~typ:(non_null guid)
-      ~resolve:(fun _ctx x -> x.id)
+      ~resolve:(fun _ctx x -> x.id )
   ; field "name" ~doc:"Toy name." ~args:[] ~typ:(non_null string)
-      ~resolve:(fun _ctx x -> x.name)
+      ~resolve:(fun _ctx x -> x.name )
   ; field "description" ~doc:"Toy description." ~args:[] ~typ:string
-      ~resolve:(fun _ctx x -> x.description |> Util.option_of_string)
+      ~resolve:(fun _ctx x -> x.description |> Util.option_of_string )
   ; field "type" ~doc:"Toy type. Possible values are: car, animal, train."
       ~args:[] ~typ:(non_null toy_type_enum) ~resolve:(fun _ctx x ->
         x.toy_type )
   ; field "createdAt" ~doc:"Date created." ~args:[]
-      ~typ:(non_null Scalar.date_time) ~resolve:(fun _ctx x -> x.created_at)
+      ~typ:(non_null Scalar.date_time) ~resolve:(fun _ctx x -> x.created_at )
   ]

test/passing/tests/labelled_args-414.ml.ref

@@ -13,7 +13,7 @@ let () =
 let () =
   very_long_function_name
     ~very_long_argument_label:(* foo *)
-    (fun
+      (fun
       very_long_argument_name_one
       very_long_argument_name_two
       very_long_argument_name_three

test/passing/tests/labelled_args.ml

@@ -13,7 +13,7 @@ let () =
 let () =
   very_long_function_name
     ~very_long_argument_label:(* foo *)
-    (fun
+      (fun
       very_long_argument_name_one
       very_long_argument_name_two
       very_long_argument_name_three

test/passing/tests/wrap_comments_break.ml

@@ -3,6 +3,6 @@ let _ =
     fffffffffff
       aaaaaaaaaaaaaaaaaaaaaaaaaaaa
       bbbbbbbbbbbbbbbbbbbbbbbbbb
-      ~f:(fun x -> return xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx)
+      ~f:(fun x -> return xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx )
   in
   2