JaneStreet profile: improve indentation of function body when max-indent is used (ocaml-ppx#2214)

Author: gpetiot

CHANGES.md

@@ -19,7 +19,7 @@
 
 - Restore short form for first-class modules: `((module M) : (module S))` is formatted as `(module M : S)`) (#2280, #2300, @gpetiot, @Julow)
 - Restore short form formatting of record field aliases (#2282, @gpetiot)
-- Tweaks the JaneStreet profile to be more consistent with ocp-indent (#2281, #2284, #2289, #2299, #2302, #2309, #2310, #2311, #2313, @gpetiot, @Julow)
+- Tweaks the JaneStreet profile to be more consistent with ocp-indent (#2214, #2281, #2284, #2289, #2299, #2302, #2309, #2310, #2311, #2313, @gpetiot, @Julow)
 - Improve formatting of class signatures (#2301, @gpetiot, @Julow)
 
 ### New features

lib/Cmts.ml

@@ -28,8 +28,8 @@ module Layout_cache = struct
 
     let sexp_of_arg_label = function
       | Asttypes.Nolabel -> Sexp.Atom "Nolabel"
-      | Labelled label -> List [Atom "Labelled"; sexp_of_string label]
-      | Optional label -> List [Atom "Optional"; sexp_of_string label]
+      | Labelled label -> List [Atom "Labelled"; sexp_of_string label.txt]
+      | Optional label -> List [Atom "Optional"; sexp_of_string label.txt]
 
     let sexp_of_t = function
       | Arg (label, expression) ->

lib/Fmt_ast.ml

@@ -338,10 +338,11 @@ let fmt_constant c ?epi {pconst_desc; pconst_loc= loc} =
 let fmt_variance_injectivity c vc = hvbox 0 (list vc "" (fmt_str_loc c))
 
 let fmt_label lbl sep =
+  (* No comment can be attached here. *)
   match lbl with
   | Nolabel -> noop
-  | Labelled l -> str "~" $ str l $ fmt sep
-  | Optional l -> str "?" $ str l $ fmt sep
+  | Labelled l -> str "~" $ str l.txt $ fmt sep
+  | Optional l -> str "?" $ str l.txt $ fmt sep
 
 let fmt_direction_flag = function
   | Upto -> fmt "@ to "
@@ -721,8 +722,8 @@ and fmt_arrow_param c ctx {pap_label= lI; pap_loc= locI; pap_type= tI} =
   let arg_label lbl =
     match lbl with
     | Nolabel -> None
-    | Labelled l -> Some (str l $ fmt ":@,")
-    | Optional l -> Some (str "?" $ str l $ fmt ":@,")
+    | Labelled l -> Some (str l.txt $ fmt ":@,")
+    | Optional l -> Some (str "?" $ str l.txt $ fmt ":@,")
   in
   let xtI = sub_typ ~ctx tI in
   let arg =
@@ -1219,7 +1220,7 @@ and fmt_fun_args c args =
                 ; _ }
             ; _ } as xpat )
         , None )
-      when String.equal l txt ->
+      when String.equal l.txt txt ->
         let symbol = match lbl with Labelled _ -> "~" | _ -> "?" in
         cbox 0 (str symbol $ fmt_pattern ~box:true c xpat)
     | Val ((Optional _ as lbl), xpat, None) ->
@@ -1244,7 +1245,7 @@ and fmt_fun_args c args =
         , ( { ast= {ppat_desc= Ppat_var {txt; loc= _}; ppat_attributes= []; _}
             ; _ } as xpat )
         , Some xexp )
-      when String.equal l txt ->
+      when String.equal l.txt txt ->
         cbox 0
           (wrap "?(" ")"
              ( fmt_pattern c ~box:true xpat
@@ -1260,7 +1261,7 @@ and fmt_fun_args c args =
                 ; _ }
             ; _ } as xpat )
         , Some xexp )
-      when String.equal l txt ->
+      when String.equal l.txt txt ->
         cbox 0
           (wrap "?(" ")"
              ( fmt_pattern c ~parens:false ~box:true xpat
@@ -1272,7 +1273,7 @@ and fmt_fun_args c args =
           | _ -> Some false
         in
         cbox 2
-          ( str "?" $ str l
+          ( str "?" $ str l.txt
           $ wrap_k (fmt ":@,(") (str ")")
               ( fmt_pattern c ?parens ~box:true xpat
               $ fmt " =@;<1 2>" $ fmt_expression c xexp ) )
@@ -1386,11 +1387,11 @@ and fmt_fun ?force_closing_paren
 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 ->
+    when String.equal l.txt i && List.is_empty arg.pexp_attributes ->
       Cmts.fmt c loc @@ Cmts.fmt c ?eol arg.pexp_loc @@ fmt_label lbl ""
   | ( (Labelled l | Optional l)
     , Pexp_constraint ({pexp_desc= Pexp_ident {txt= Lident i; _}; _}, _) )
-    when String.equal l i
+    when String.equal l.txt i
          && List.is_empty arg.pexp_attributes
          && Ocaml_version.(
               compare c.conf.opr_opts.ocaml_version.v Releases.v4_14_0 >= 0 )
@@ -1897,15 +1898,25 @@ and fmt_expression c ?(box = true) ?pro ?epi ?eol ?parens ?(indent_wrap = 0)
           let args_before = List.rev rev_args_before in
           let xlast_arg = sub_exp ~ctx eN1 in
           let args =
+            let begin_arg_loc =
+              match lbl with
+              | Nolabel -> eN1.pexp_loc
+              | Optional x | Labelled x -> x.loc
+            in
             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>" )
+                | Some indent when indent <= 2 ->
+                    if
+                      Source.begins_line ~ignore_spaces:true c.source
+                        begin_arg_loc
+                    then break 1 indent
+                    else fmt "@ "
+                | _ -> break 1 2 )
             in
             let wrap_intro x =
               wrap

lib/Loc_tree.ml

@@ -25,6 +25,10 @@ let of_ast fragment ast =
     locs := loc :: !locs ;
     loc
   in
-  let mapper = Ast_mapper.{default_mapper with location; attribute} in
+  (* Ignore locations of arg_labels *)
+  let arg_label _ lbl = lbl in
+  let mapper =
+    Ast_mapper.{default_mapper with location; attribute; arg_label}
+  in
   map fragment mapper ast |> ignore ;
   (of_list !locs, !locs)

test/passing/tests/js_source.ml

@@ -7625,6 +7625,34 @@ let x =
     ^ "Yet another string _________")
 ;;
 
+let x =
+  some_fun________________________________
+    some_arg______________________________ (fun param ->
+    do_something ();
+    do_something_else ();
+    return_this_value)
+
+let x =
+  some_fun________________________________
+    some_arg______________________________ ~f:(fun param ->
+    do_something ();
+    do_something_else ();
+    return_this_value)
+
+let x =
+  some_value
+  |> some_fun (fun x ->
+       do_something ();
+       do_something_else ();
+       return_this_value)
+
+let x =
+  some_value
+  ^ some_fun (fun x ->
+      do_something ();
+      do_something_else ();
+      return_this_value)
+
 let bind t ~f =
   unfold_step
     ~f:(function

test/passing/tests/js_source.ml.ocp

@@ -9815,6 +9815,40 @@ let x =
      ^ "Yet another string _________")
 ;;
 
+let x =
+  some_fun________________________________
+    some_arg______________________________
+    (fun param ->
+       do_something ();
+       do_something_else ();
+       return_this_value)
+;;
+
+let x =
+  some_fun________________________________
+    some_arg______________________________
+    ~f:(fun param ->
+      do_something ();
+      do_something_else ();
+      return_this_value)
+;;
+
+let x =
+  some_value
+  |> some_fun (fun x ->
+    do_something ();
+    do_something_else ();
+    return_this_value)
+;;
+
+let x =
+  some_value
+  ^ some_fun (fun x ->
+    do_something ();
+    do_something_else ();
+    return_this_value)
+;;
+
 let bind t ~f =
   unfold_step
     ~f:(function

test/passing/tests/js_source.ml.ref

@@ -9815,6 +9815,40 @@ let x =
      ^ "Yet another string _________")
 ;;
 
+let x =
+  some_fun________________________________
+    some_arg______________________________
+    (fun param ->
+      do_something ();
+      do_something_else ();
+      return_this_value)
+;;
+
+let x =
+  some_fun________________________________
+    some_arg______________________________
+    ~f:(fun param ->
+      do_something ();
+      do_something_else ();
+      return_this_value)
+;;
+
+let x =
+  some_value
+  |> some_fun (fun x ->
+    do_something ();
+    do_something_else ();
+    return_this_value)
+;;
+
+let x =
+  some_value
+  ^ some_fun (fun x ->
+    do_something ();
+    do_something_else ();
+    return_this_value)
+;;
+
 let bind t ~f =
   unfold_step
     ~f:(function

test/passing/tests/max_indent.ml

@@ -9,10 +9,11 @@ let () =
   |> List.iter
        (fun
          some_really_really_really_long_name_that_doesn't_fit_on_the_line ->
-       let x =
-         some_really_really_really_long_name_that_doesn't_fit_on_the_line $ y
-       in
-       fooooooooooo x )
+         let x =
+           some_really_really_really_long_name_that_doesn't_fit_on_the_line
+           $ y
+         in
+         fooooooooooo x )
 
 let foooooooooo =
   foooooooooooooooooooooo
@@ -68,3 +69,23 @@ let foooooooooooooooooooooooooooooooo =
       | Tpat_variant (lab', Some arg, _) when lab = lab' -> (p, arg :: rem)
       | Tpat_any -> (p, omega :: rem)
       | _ -> raise NoMatch )
+
+let x =
+  some_fun________________________________
+    some_arg______________________________ (fun param ->
+    do_something () ; do_something_else () ; return_this_value )
+
+let x =
+  some_fun________________________________
+    some_arg______________________________ ~f:(fun param ->
+    do_something () ; do_something_else () ; return_this_value )
+
+let x =
+  some_value
+  |> some_fun (fun x ->
+       do_something () ; do_something_else () ; return_this_value )
+
+let x =
+  some_value
+  ^ some_fun (fun x ->
+      do_something () ; do_something_else () ; return_this_value )

vendor/diff-parsers-ext-parsewyc.patch

@@ -699,7 +699,7 @@
  ;
  labeled_simple_expr:
      simple_expr %prec below_HASH
-       { (Nolabel, $1) }
+       { Nolabel, $1 }
    | LABEL simple_expr %prec below_HASH
 @@@@
  ;

vendor/parser-extended/ast_mapper.ml

@@ -27,6 +27,7 @@ open Location
 module String = Misc.Stdlib.String
 
 type mapper = {
+  arg_label: mapper -> Asttypes.arg_label -> Asttypes.arg_label;
   attribute: mapper -> attribute -> attribute;
   attributes: mapper -> attribute list -> attribute list;
   binding_op: mapper -> binding_op -> binding_op;
@@ -84,7 +85,7 @@ type mapper = {
 }
 
 let map_fst f (x, y) = (f x, y)
-let map_snd f (x, y) = (x, f y)
+(*let map_snd f (x, y) = (x, f y)*)
 let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
 let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
 let map_opt f = function None -> None | Some x -> Some (f x)
@@ -97,6 +98,11 @@ let variant_var sub x =
 let map_package_type sub (lid, l) =
   (map_loc sub lid), (List.map (map_tuple (map_loc sub) (sub.typ sub)) l)
 
+let map_arg_label sub = function
+  | Asttypes.Nolabel -> Asttypes.Nolabel
+  | Labelled x -> Labelled (map_loc sub x)
+  | Optional x -> Optional (map_loc sub x)
+
 module Flag = struct
   open Asttypes
 
@@ -174,6 +180,7 @@ module T = struct
     Of.mk ~loc ~attrs desc
 
   let map_arrow_param sub {pap_label; pap_loc; pap_type} =
+    let pap_label = sub.arg_label sub pap_label in
     let pap_loc = sub.location sub pap_loc in
     let pap_type = sub.typ sub pap_type in
     {pap_label; pap_loc; pap_type}
@@ -467,11 +474,16 @@ module E = struct
         let_ ~loc ~attrs (sub.let_bindings sub lbs)
           (sub.expr sub e)
     | Pexp_fun (lab, def, p, e) ->
-        fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p)
+        fun_ ~loc ~attrs
+          (sub.arg_label sub lab)
+          (map_opt (sub.expr sub) def)
+          (sub.pat sub p)
           (sub.expr sub e)
     | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel)
     | Pexp_apply (e, l) ->
-        apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l)
+        apply ~loc ~attrs
+          (sub.expr sub e)
+          (List.map (map_tuple (sub.arg_label sub) (sub.expr sub)) l)
     | Pexp_match (e, pel) ->
         match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
     | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel)
@@ -648,13 +660,14 @@ module CE = struct
     | Pcl_structure s ->
         structure ~loc ~attrs (sub.class_structure sub s)
     | Pcl_fun (lab, e, p, ce) ->
-        fun_ ~loc ~attrs lab
+        fun_ ~loc ~attrs
+          (sub.arg_label sub lab)
           (map_opt (sub.expr sub) e)
           (sub.pat sub p)
           (sub.class_expr sub ce)
     | Pcl_apply (ce, l) ->
         apply ~loc ~attrs (sub.class_expr sub ce)
-          (List.map (map_snd (sub.expr sub)) l)
+          (List.map (map_tuple (sub.arg_label sub) (sub.expr sub)) l)
     | Pcl_let (lbs, ce) ->
         let_ ~loc ~attrs (sub.let_bindings sub lbs)
           (sub.class_expr sub ce)
@@ -711,6 +724,7 @@ end
 
 let default_mapper =
   {
+    arg_label = map_arg_label;
     constant = C.map;
     structure = (fun this l -> List.map (this.structure_item this) l);
     structure_item = M.map_structure_item;