Merge branch 'MAIN' into ast-class-expr-let

Author: Julow

CHANGES.md

@@ -58,6 +58,8 @@ profile. This started with version 0.26.0.
   The attribute is moved from `begin .. end [@attr]` to `begin [@attr] .. end`.
 - Fix missing parentheses around `let .. in [@attr]` (#2564, @Julow)
 - Display `a##b` instead of `a ## b` and similarly for operators that start with # (#2580, @v-gb)
+- \* Fix arrow type indentation with `break-separators=before` (#2598, @Julow)
+- Fix formatting of short `fun` expressions with the janestreet profile (#2593, @Julow)
 - Fix missing parentheses around a let in class expressions (#2599, @Julow)
 
 ### Changes

lib/Fmt_ast.ml

@@ -752,18 +752,19 @@ and fmt_type_cstr c ?(pro = ":") ?constraint_ctx xtyp =
   let colon_before = Poly.(c.conf.fmt_opts.break_colon.v = `Before) in
   let wrap, inner_pro, box =
     match xtyp.ast.ptyp_desc with
-    | (Ptyp_poly (_, {ptyp_desc= Ptyp_arrow _; _}) | Ptyp_arrow _)
-      when colon_before ->
+    | (Ptyp_poly _ | Ptyp_arrow _) when colon_before ->
         let outer_pro =
-          if c.conf.fmt_opts.ocp_indent_compat.v then
-            fits_breaks (pro ^ " ") (pro ^ "  ")
-          else str pro $ str " "
+          match (xtyp.ast.ptyp_desc, c.conf.fmt_opts.break_separators.v) with
+          | ( (Ptyp_poly (_, {ptyp_desc= Ptyp_arrow _; _}) | Ptyp_arrow _)
+            , `Before ) ->
+              fits_breaks (pro ^ " ") (pro ^ "  ")
+          | _ -> str pro $ str " "
         in
         let pre_break =
           if colon_before then fits_breaks " " ~hint:(1000, 0) ""
           else break 0 ~-1
         in
-        let wrap x = pre_break $ cbox 0 (outer_pro $ x) in
+        let wrap x = pre_break $ hvbox 0 (outer_pro $ x) in
         (wrap, None, false)
     | _ ->
         ( (fun k ->
@@ -832,7 +833,7 @@ and fmt_arrow_type c ~ctx ?indent ~parens ~parent_has_parens args fmt_ret_typ
    of the expression, i.e. if the expression is part of a `fun`
    expression. *)
 and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx
-    ({ast= typ; ctx} as xtyp) =
+    ({ast= typ; ctx= ctx0} as xtyp) =
   protect c (Typ typ)
   @@
   let {ptyp_desc; ptyp_attributes; ptyp_loc; _} = typ in
@@ -857,7 +858,7 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx
        c.conf
   @@
   let in_type_declaration =
-    match ctx with
+    match ctx0 with
     | Td {ptype_manifest= Some t; _} -> phys_equal t typ
     | _ -> false
   in
@@ -921,10 +922,26 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx
   | Ptyp_poly ([], _) ->
       impossible "produced by the parser, handled elsewhere"
   | Ptyp_poly (a1N, t) ->
+      let ctx_is_value_constraint = function Vc _ -> true | _ -> false in
+      let break, box_core_type =
+        match
+          (c.conf.fmt_opts.break_separators.v, c.conf.fmt_opts.break_colon.v)
+        with
+        | `Before, `Before when ctx_is_value_constraint ctx0 ->
+            (* Special formatting for leading [->] in let bindings. *)
+            let indent =
+              match t.ptyp_desc with Ptyp_arrow _ -> 3 | _ -> 2
+            in
+            (break 1 indent, Some false)
+        | _ -> (space_break, None)
+      in
       hovbox_if box 0
-        ( list a1N space_break (fun {txt; _} -> fmt_type_var txt)
-        $ str "." $ space_break
-        $ fmt_core_type c ~box:true (sub_typ ~ctx t) )
+        ( hovbox 0
+            ( list a1N space_break (fun {txt; _} -> fmt_type_var txt)
+            $ str "." )
+        $ break
+        $ fmt_core_type c ?box:box_core_type ~pro_space:false
+            (sub_typ ~ctx t) )
   | Ptyp_tuple typs ->
       hvbox 0
         (wrap_if parenze_constraint_ctx (str "(") (str ")")
@@ -1509,7 +1526,7 @@ and fmt_function ?(last_arg = false) ?force_closing_paren ~ctx ~ctx0
         let head = fmt_fun_args_typ args typ in
         let body ~pro = pro $ fmt_expression c (sub_exp ~ctx body) in
         let box, closing_paren_offset =
-          Params.Exp.box_fun_expr c.conf ~source:c.source ~ctx0 ~ctx ~parens
+          Params.Exp.box_fun_expr c.conf ~source:c.source ~ctx0 ~ctx
         in
         let closing_paren_offset =
           if should_box then closing_paren_offset else ~-2

lib/Params.ml

@@ -213,7 +213,7 @@ module Exp = struct
         ( kw_in_box
         $ hvbox_if should_box_args 0 (args $ fmt_opt annot $ fmt_opt epi) )
 
-  let box_fun_expr (c : Conf.t) ~source ~ctx0 ~ctx ~parens =
+  let box_fun_expr (c : Conf.t) ~source ~ctx0 ~ctx =
     let indent =
       if ctx_is_rhs_of_infix ~ctx0 ~ctx then 0
       else if Poly.equal c.fmt_opts.function_indent_nested.v `Always then
@@ -244,14 +244,7 @@ module Exp = struct
       else 2
     in
     let name = "Params.box_fun_expr" in
-    let mkbox =
-      match ctx0 with
-      | Str _ | Lb _ -> hvbox
-      | _ ->
-          (* JS: The body of a [fun] must break if the intro is too large,
-             except if the [fun] is small and parenthesed. *)
-          if ocp c && not parens then hvbox else hovbox
-    in
+    let mkbox = if ctx_is_let_or_fun ~ctx ctx0 then hvbox else hovbox in
     (mkbox ~name indent, ~-indent)
 
   (* if the function is the last argument of an apply and no other arguments

lib/Params.mli

@@ -58,7 +58,6 @@ module Exp : sig
     -> source:Source.t
     -> ctx0:Ast.t
     -> ctx:Ast.t
-    -> parens:bool
     -> (Fmt.t -> Fmt.t) * int
   (** return a box with an indent and minus the value of the indent to be used for a closing parenthesis *)
 

test/passing/tests/break_colon-before.ml.ref

@@ -70,10 +70,10 @@ let ssmap
   ()
 
 let ssmap
-    :    (module MapT
-            with type key = string
-             and type data = string
-             and type map = SSMap.map )
+    :     (module MapT
+             with type key = string
+              and type data = string
+              and type map = SSMap.map )
     -> unit =
   ()
 

test/passing/tests/js_source.ml

@@ -8241,3 +8241,21 @@ let _ =
     (* foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo *)
   else f
 ;;
+
+let _ =
+  match ids_queue with
+  | Some q ->
+    (* this is more efficient than a linear scan of [ids] *)
+    fun id -> not (Ident.HashQueue.mem q id)
+  | None -> fun id -> not (List.mem ~equal:Ident.equal ids id)
+;;
+
+type callbacks =
+  { html_debug_new_node_session_f :
+      'a.
+      ?kind:[ `ComputePre | `ExecNode | `ExecNodeNarrowing | `WTO ]
+      -> pp_name:(Format.formatter -> unit)
+      -> Procdesc.Node.t
+      -> f:(unit -> 'a)
+      -> 'a
+  }

test/passing/tests/js_source.ml.err

@@ -3,4 +3,4 @@ Warning: tests/js_source.ml:9564 exceeds the margin
 Warning: tests/js_source.ml:9668 exceeds the margin
 Warning: tests/js_source.ml:9727 exceeds the margin
 Warning: tests/js_source.ml:9810 exceeds the margin
-Warning: tests/js_source.ml:10309 exceeds the margin
+Warning: tests/js_source.ml:10308 exceeds the margin

test/passing/tests/js_source.ml.ocp

@@ -10235,8 +10235,7 @@ let _ =
     foooooooooooooooooo
     foooooooooooooooooo
     foooooooooooooooooo
-    foooooooooooooooooo ->
-    ()
+    foooooooooooooooooo -> ()
 ;;
 
 module type For_let_syntax_local =
@@ -10530,3 +10529,21 @@ let _ =
     (* foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo *)
   else f
 ;;
+
+let _ =
+  match ids_queue with
+  | Some q ->
+    (* this is more efficient than a linear scan of [ids] *)
+    fun id -> not (Ident.HashQueue.mem q id)
+  | None -> fun id -> not (List.mem ~equal:Ident.equal ids id)
+;;
+
+type callbacks =
+  { html_debug_new_node_session_f :
+      'a.
+        ?kind:[ `ComputePre | `ExecNode | `ExecNodeNarrowing | `WTO ]
+      -> pp_name:(Format.formatter -> unit)
+      -> Procdesc.Node.t
+      -> f:(unit -> 'a)
+      -> 'a
+  }

test/passing/tests/js_source.ml.ref

@@ -10235,8 +10235,7 @@ let _ =
     foooooooooooooooooo
     foooooooooooooooooo
     foooooooooooooooooo
-    foooooooooooooooooo ->
-    ()
+    foooooooooooooooooo -> ()
 ;;
 
 module type For_let_syntax_local =
@@ -10530,3 +10529,21 @@ let _ =
     (* foooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooooo *)
   else f
 ;;
+
+let _ =
+  match ids_queue with
+  | Some q ->
+    (* this is more efficient than a linear scan of [ids] *)
+    fun id -> not (Ident.HashQueue.mem q id)
+  | None -> fun id -> not (List.mem ~equal:Ident.equal ids id)
+;;
+
+type callbacks =
+  { html_debug_new_node_session_f :
+      'a.
+      ?kind:[ `ComputePre | `ExecNode | `ExecNodeNarrowing | `WTO ]
+      -> pp_name:(Format.formatter -> unit)
+      -> Procdesc.Node.t
+      -> f:(unit -> 'a)
+      -> 'a
+  }

test/passing/tests/polytypes-janestreet.ml.err

@@ -1 +1 @@
-Warning: tests/polytypes.ml:47 exceeds the margin
+Warning: tests/polytypes.ml:48 exceeds the margin