promote ocp docking for infix apply. (ocaml-ppx#2694)

* promote ocp docking ofr infix apply.

* fmt

* changelog

Author: EmileTrotignon

CHANGES.md

@@ -104,6 +104,22 @@ profile. This started with version 0.26.0.
   let a = 3
   ```
 
+- \* Infix apply docking behaviour from --ocp-indent-compat is promoted to
+ everyone. The most common effect is that `|> map (fun` is now indented from
+ `|>` and not from `map`:
+  ```ocaml
+  (* before *)
+  v
+  |>>>>>> map (fun x ->
+              x )
+  (* after *)
+  v
+  |>>>>>> map (fun x ->
+      x )
+  ```
+  `@@ match` can now also be on one line.
+  (#2694, @EmileTrotignon)
+
 ## 0.27.0
 
 ### Highlight

bench/bench.ml

@@ -97,14 +97,14 @@ let json_of_ols_results ?name (results : Bechamel.Analyze.OLS.t results) :
   let results =
     metrics_by_test |> Hashtbl.to_seq
     |> Seq.map (fun (test_name, metrics) ->
-           let metrics =
-             metrics |> Hashtbl.to_seq
-             |> Seq.map (fun (metric_name, ols) ->
-                    (metric_name, json_of_ols ols) )
-             |> List.of_seq
-             |> fun bindings -> `Assoc bindings
-           in
-           `Assoc [("name", `String test_name); ("metrics", metrics)] )
+        let metrics =
+          metrics |> Hashtbl.to_seq
+          |> Seq.map (fun (metric_name, ols) ->
+              (metric_name, json_of_ols ols) )
+          |> List.of_seq
+          |> fun bindings -> `Assoc bindings
+        in
+        `Assoc [("name", `String test_name); ("metrics", metrics)] )
     |> List.of_seq
     |> fun items -> `List items
   in

lib/Ast.ml

@@ -995,14 +995,14 @@ end = struct
         assert (
           List.exists ptype_params ~f:fst_f
           || List.exists ptype_cstrs ~f:(fun (t1, t2, _) ->
-                 typ == t1 || typ == t2 )
+              typ == t1 || typ == t2 )
           || ( match ptype_kind with
-             | Ptype_variant cd1N ->
-                 List.exists cd1N ~f:(fun {pcd_args; pcd_res; _} ->
-                     check_cstr pcd_args || Option.exists pcd_res ~f )
-             | Ptype_record ld1N ->
-                 List.exists ld1N ~f:(fun {pld_type; _} -> typ == pld_type)
-             | _ -> false )
+            | Ptype_variant cd1N ->
+                List.exists cd1N ~f:(fun {pcd_args; pcd_res; _} ->
+                    check_cstr pcd_args || Option.exists pcd_res ~f )
+            | Ptype_record ld1N ->
+                List.exists ld1N ~f:(fun {pld_type; _} -> typ == pld_type)
+            | _ -> false )
           || Option.exists ptype_manifest ~f )
     | Cty {pcty_desc; _} ->
         assert (
@@ -1535,13 +1535,13 @@ end = struct
     | Pexp_record (e1N, e0) ->
         Option.for_all e0 ~f:Exp.is_trivial
         && List.for_all e1N ~f:(fun (_, c, eo) ->
-               Option.is_none c && Option.for_all eo ~f:Exp.is_trivial )
+            Option.is_none c && Option.for_all eo ~f:Exp.is_trivial )
         && fit_margin c (width xexp)
     | Pexp_indexop_access {pia_lhs; pia_kind; pia_rhs= None; _} ->
         Exp.is_trivial pia_lhs
         && ( match pia_kind with
-           | Builtin idx -> Exp.is_trivial idx
-           | Dotop (_, _, idx) -> List.for_all idx ~f:Exp.is_trivial )
+          | Builtin idx -> Exp.is_trivial idx
+          | Dotop (_, _, idx) -> List.for_all idx ~f:Exp.is_trivial )
         && fit_margin c (width xexp)
     | Pexp_prefix (_, e) -> Exp.is_trivial e && fit_margin c (width xexp)
     | Pexp_infix ({txt= ":="; _}, _, _) -> false
@@ -2219,7 +2219,7 @@ end = struct
         | Pexp_infix (_, _, e2)
           when e2 == exp
                && Option.value_map ~default:false (prec_ast ctx) ~f:(fun p ->
-                      Prec.compare p Apply < 0 ) ->
+                   Prec.compare p Apply < 0 ) ->
             true
         | Pexp_tuple e1N -> List.last_exn e1N == xexp.ast
         | _ -> false

lib/Cmts.ml

@@ -595,19 +595,19 @@ let fmt_cmts_aux t (conf : Conf.t) cmts ~fmt_code pos =
   vbox 0 ~name:"cmts"
     (list_pn groups (fun ~prev:_ group ~next ->
          ( match group with
-         | [] -> impossible "previous match"
-         | [cmt] ->
-             let break =
-               fmt_if
-                 ( conf.fmt_opts.ocp_indent_compat.v
-                 && Poly.(pos = Cmt.After)
-                 && String.contains (Cmt.txt cmt) '\n' )
-                 (break_unless_newline 1000 0)
-             in
-             break $ fmt_cmt conf cmt ~fmt_code
-         | group ->
-             list group force_break (fun cmt ->
-                 wrap (str "(*") (str "*)") (str (Cmt.txt cmt)) ) )
+           | [] -> impossible "previous match"
+           | [cmt] ->
+               let break =
+                 fmt_if
+                   ( conf.fmt_opts.ocp_indent_compat.v
+                   && Poly.(pos = Cmt.After)
+                   && String.contains (Cmt.txt cmt) '\n' )
+                   (break_unless_newline 1000 0)
+               in
+               break $ fmt_cmt conf cmt ~fmt_code
+           | group ->
+               list group force_break (fun cmt ->
+                   wrap (str "(*") (str "*)") (str (Cmt.txt cmt)) ) )
          $
          match next with
          | Some (next :: _) ->

lib/Fmt_ast.ml

@@ -222,10 +222,10 @@ let fmt_item_list c ctx0 update_config ast fmt_item items =
   let loc = Ast.location ctx in
   maybe_disabled c loc [] (fun c -> fmt_item c ctx ~prev ~next itm)
   $ opt next (fun (i_n, c_n) ->
-        fmt_or
-          (break_between c (ctx, c.conf) (ast i_n, c_n.conf))
-          (str "\n" $ force_break)
-          (fmt_or break_struct force_break space_break) )
+      fmt_or
+        (break_between c (ctx, c.conf) (ast i_n, c_n.conf))
+        (str "\n" $ force_break)
+        (fmt_or break_struct force_break space_break) )
 
 let fmt_recmodule c ctx items fmt_item ast sub =
   let update_config c i = update_config c (Ast.attributes (ast i)) in
@@ -462,7 +462,7 @@ let fmt_docstring_around_item' ?(is_val = false) ?(force_before = false)
       let floating_doc, doc =
         doc
         |> List.map ~f:(fun (({txt; loc}, _) as doc) ->
-               (Docstring.parse ~loc txt, doc) )
+            (Docstring.parse ~loc txt, doc) )
         |> List.partition_tf ~f:(fun (_, (_, floating)) -> floating)
       in
       let placement =
@@ -849,8 +849,8 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx
   update_config_maybe_disabled c ptyp_loc ptyp_attributes
   @@ fun c ->
   ( match pro with
-  | Some pro -> fmt_constraint_sep ~pro_space c pro
-  | None -> noop )
+    | Some pro -> fmt_constraint_sep ~pro_space c pro
+    | None -> noop )
   $
   let doc, atrs = doc_atrs ptyp_attributes in
   Cmts.fmt c ptyp_loc
@@ -1116,8 +1116,8 @@ and fmt_pattern ?ext c ?pro ?parens ?(box = false)
   let parens = match parens with Some b -> b | None -> parenze_pat xpat in
   (match ctx0 with Pat {ppat_desc= Ppat_tuple _; _} -> hvbox 0 | _ -> Fn.id)
   @@ ( match ppat_desc with
-     | Ppat_or _ -> fun k -> Cmts.fmt c ppat_loc @@ k
-     | _ -> fun k -> Cmts.fmt c ppat_loc @@ (fmt_opt pro $ k) )
+    | Ppat_or _ -> fun k -> Cmts.fmt c ppat_loc @@ k
+    | _ -> fun k -> Cmts.fmt c ppat_loc @@ (fmt_opt pro $ k) )
   @@ hovbox_if box 0
   @@ fmt_pattern_attributes c xpat
   @@
@@ -1495,7 +1495,7 @@ and fmt_indexop_access c ctx ~fmt_atrs ~has_attr ~parens x =
                         (str ";" $ space_break)
                         (sub_exp ~ctx >> fmt_expression c) ) )
            $ opt pia_rhs (fun e ->
-                 fmt_assign_arrow c $ fmt_expression c (sub_exp ~ctx e) ) )
+               fmt_assign_arrow c $ fmt_expression c (sub_exp ~ctx e) ) )
        $ fmt_atrs ) )
 
 (** Format a [Pexp_function]. [wrap_intro] wraps up to after the [->] and is
@@ -1873,7 +1873,7 @@ and fmt_infix_op_args c ~parens xexp op_args =
       ((not very_last) && exposed_right_exp Ast.Non_apply xarg.ast)
       || parenze_exp xarg
     in
-    if Params.Exp.Infix_op_arg.dock c.conf xarg then
+    if Params.Exp.Infix_op_arg.dock xarg then
       (* Indentation of docked fun or function start before the operator. *)
       hovbox ~name:"Infix_op_arg docked" 2
         (fmt_expression c ~parens ~box:false ~pro xarg)
@@ -2311,8 +2311,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
            parenthesis. *)
         let dock_fun_arg =
           (* Do not dock the arguments when there's more than one. *)
-          (not c.conf.fmt_opts.ocp_indent_compat.v)
-          || Location.line_difference e0.pexp_loc last_arg.pexp_loc = 0
+          Location.line_difference e0.pexp_loc last_arg.pexp_loc = 0
         in
         if parens || not dock_fun_arg then (noop, pro) else (pro, noop)
       in
@@ -2757,8 +2756,8 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
                              ( fmt_pattern c ~pro:(if_newline "| ")
                                  (sub_pat ~ctx pc_lhs)
                              $ opt pc_guard (fun g ->
-                                   space_break $ str "when "
-                                   $ fmt_expression c (sub_exp ~ctx g) )
+                                 space_break $ str "when "
+                                 $ fmt_expression c (sub_exp ~ctx g) )
                              $ space_break $ str "->"
                              $ fmt_if parens_here (str " (") ) )
                      $ break 1 2
@@ -3445,8 +3444,8 @@ and fmt_case c ctx ~first ~last case =
           ( hvbox 0
               ( fmt_pattern c ~pro:p.bar ~parens:paren_lhs xlhs
               $ opt pc_guard (fun g ->
-                    break 1 2 $ str "when "
-                    $ fmt_expression c (sub_exp ~ctx g) ) )
+                  break 1 2 $ str "when " $ fmt_expression c (sub_exp ~ctx g) )
+              )
           $ p.break_before_arrow $ str "->" $ p.break_after_arrow
           $ p.open_paren_branch )
       $ p.break_after_opening_paren
@@ -3778,9 +3777,9 @@ and fmt_type_extension c ctx
            $ str " +="
            $ fmt_private_flag c ptyext_private
            $ list_fl ptyext_constructors (fun ~first ~last:_ x ->
-                 let bar_fits = if first then "" else "| " in
-                 cbreak ~fits:("", 1, bar_fits) ~breaks:("", 0, "| ")
-                 $ fmt_ctor x ) )
+               let bar_fits = if first then "" else "| " in
+               cbreak ~fits:("", 1, bar_fits) ~breaks:("", 0, "| ")
+               $ fmt_ctor x ) )
        $ fmt_item_attributes c ~pre:(Break (1, 0)) attrs_after )
 
 and fmt_type_exception ~pre c ctx
@@ -4092,46 +4091,46 @@ and fmt_class_types c ~pre ~sep cls =
 and fmt_class_exprs c cls =
   hvbox 0
   @@ list_fl cls (fun ~first ~last:_ cl ->
-         update_config_maybe_disabled_attrs c cl.pci_loc cl.pci_attributes
-         @@ fun c ->
-         let ctx = Cd cl in
-         let xargs = cl.pci_args in
-         let ext = cl.pci_attributes.attrs_extension in
-         let doc_before, doc_after, attrs_before, attrs_after =
-           let force_before = not (Cl.is_simple cl.pci_expr) in
-           fmt_docstring_around_item_attrs ~force_before c cl.pci_attributes
-         in
-         let class_expr =
-           let pro =
-             box_fun_decl_args c 2
-               ( hovbox 2
-                   ( str (if first then "class" else "and")
-                   $ fmt_if first (fmt_extension_suffix c ext)
-                   $ fmt_attributes c ~pre:(Break (1, 0)) attrs_before
-                   $ fmt_virtual_flag c cl.pci_virt
-                   $ space_break
-                   $ fmt_class_params c ctx cl.pci_params
-                   $ fmt_str_loc c cl.pci_name )
-               $ fmt_if (not (List.is_empty xargs)) space_break
-               $ wrap_fun_decl_args c (fmt_class_fun_args c xargs) )
-           in
-           let intro =
-             match cl.pci_constraint with
-             | Some ty ->
-                 fmt_class_type c
-                   ~pro:(pro $ str " :" $ space_break)
-                   (sub_cty ~ctx ty)
-             | None -> pro
-           in
-           hovbox 2
-             ( hovbox 2 (intro $ space_break $ str "=")
-             $ space_break
-             $ fmt_class_expr c (sub_cl ~ctx cl.pci_expr) )
-           $ fmt_item_attributes c ~pre:(Break (1, 0)) attrs_after
-         in
-         fmt_if (not first) (str "\n" $ force_break)
-         $ hovbox 0
-           @@ Cmts.fmt c cl.pci_loc (doc_before $ class_expr $ doc_after) )
+      update_config_maybe_disabled_attrs c cl.pci_loc cl.pci_attributes
+      @@ fun c ->
+      let ctx = Cd cl in
+      let xargs = cl.pci_args in
+      let ext = cl.pci_attributes.attrs_extension in
+      let doc_before, doc_after, attrs_before, attrs_after =
+        let force_before = not (Cl.is_simple cl.pci_expr) in
+        fmt_docstring_around_item_attrs ~force_before c cl.pci_attributes
+      in
+      let class_expr =
+        let pro =
+          box_fun_decl_args c 2
+            ( hovbox 2
+                ( str (if first then "class" else "and")
+                $ fmt_if first (fmt_extension_suffix c ext)
+                $ fmt_attributes c ~pre:(Break (1, 0)) attrs_before
+                $ fmt_virtual_flag c cl.pci_virt
+                $ space_break
+                $ fmt_class_params c ctx cl.pci_params
+                $ fmt_str_loc c cl.pci_name )
+            $ fmt_if (not (List.is_empty xargs)) space_break
+            $ wrap_fun_decl_args c (fmt_class_fun_args c xargs) )
+        in
+        let intro =
+          match cl.pci_constraint with
+          | Some ty ->
+              fmt_class_type c
+                ~pro:(pro $ str " :" $ space_break)
+                (sub_cty ~ctx ty)
+          | None -> pro
+        in
+        hovbox 2
+          ( hovbox 2 (intro $ space_break $ str "=")
+          $ space_break
+          $ fmt_class_expr c (sub_cl ~ctx cl.pci_expr) )
+        $ fmt_item_attributes c ~pre:(Break (1, 0)) attrs_after
+      in
+      fmt_if (not first) (str "\n" $ force_break)
+      $ hovbox 0
+        @@ Cmts.fmt c cl.pci_loc (doc_before $ class_expr $ doc_after) )
 
 and fmt_module c ctx ?rec_ ?epi ?(can_sparse = false) keyword ?(eqty = "=")
     name xargs xbody xmty ~attrs ~rec_flag =
@@ -4229,13 +4228,13 @@ and fmt_module c ctx ?rec_ ?epi ?(can_sparse = false) keyword ?(eqty = "=")
     $ fmt_item_attributes c ~pre:(Break (1, 0)) attrs_after
     $ doc_after
     $ opt epi (fun epi ->
-          fmt_or compact
-            (fmt_or
-               ( Option.is_some blk_b.epi
-               && not c.conf.fmt_opts.ocp_indent_compat.v )
-               (str " ") space_break )
-            (break 1 (-2))
-          $ epi ) )
+        fmt_or compact
+          (fmt_or
+             ( Option.is_some blk_b.epi
+             && not c.conf.fmt_opts.ocp_indent_compat.v )
+             (str " ") space_break )
+          (break 1 (-2))
+        $ epi ) )
 
 and fmt_module_declaration c ~rec_flag ~first {ast= pmd; _} =
   protect c (Md pmd)

lib/Fmt_odoc.ml

@@ -494,8 +494,8 @@ let fmt_tag_args ?arg ?txt c tag =
   at $ str tag
   $ opt arg (fun x -> char ' ' $ x)
   $ opt txt (function
-      | [] -> noop
-      | x -> space_break $ hovbox 0 (fmt_nestable_block_elements c x) )
+    | [] -> noop
+    | x -> space_break $ hovbox 0 (fmt_nestable_block_elements c x) )
 
 let wrap_see = function
   | `Url -> wrap (str "<") (str ">")

lib/Non_overlapping_interval_tree.ml

@@ -55,8 +55,8 @@ module Make (Itv : IN) = struct
            if Itv.contains root elt then
              let ancestors = root :: ancestors in
              ( match Map.find map root with
-             | Some children -> parents map children ~ancestors elt
-             | None -> ancestors )
+               | Some children -> parents map children ~ancestors elt
+               | None -> ancestors )
              |> Option.some
            else None ) )
 

lib/Normalize_extended_ast.ml

@@ -43,7 +43,7 @@ let dedup_cmts fragment ast comments =
 let normalize_comments ~normalize_cmt dedup fmt comments =
   dedup comments
   |> List.sort ~compare:(fun a b ->
-         Migrate_ast.Location.compare (Cmt.loc a) (Cmt.loc b) )
+      Migrate_ast.Location.compare (Cmt.loc a) (Cmt.loc b) )
   |> List.iter ~f:(fun cmt -> Format.fprintf fmt "%s," (normalize_cmt cmt))
 
 let normalize_parse_result ~normalize_cmt ast_kind ast comments =