Fix break-colon=before regression

This might also contain a bug fix compared to master.

lib/Fmt_ast.ml

@@ -747,19 +747,18 @@ and fmt_record_field c ?typ1 ?typ2 ?rhs lid1 =
 
 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 =
-      if colon_before then
-        let wrap x =
-          fits_breaks " " ~hint:(1000, 0) "" $ cbox 0 (str pro $ str " " $ x)
-        in
+  let wrap, inner_pro, box =
+    match xtyp.ast.ptyp_desc with
+    | (Ptyp_poly (_, { ptyp_desc= Ptyp_arrow _; _ })
+    | Ptyp_arrow _) when colon_before ->
+        let outer_pro = fits_breaks (pro ^ " ") (pro ^ "  ") 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
         wrap, None, false
-      else
-        let wrap x =
-          break 0 ~-1 $ x
-        in
-        wrap, Some pro, true
-    in
-    wrap (fmt_core_type c ?pro:inner_pro ?constraint_ctx ~box xtyp)
+    | _ ->
+        (fun k -> break 0 ~-1 $ k), Some pro, true
+  in
+  wrap (fmt_core_type c ?pro:inner_pro ?constraint_ctx ~box xtyp)
 
 and fmt_type_pcstr c ~ctx ?constraint_ctx cstr =
   let fmt_typ ~pro t = fmt_type_cstr c ~pro ?constraint_ctx (sub_typ ~ctx t) in

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.err

@@ -1,7 +1,7 @@
 Warning: tests/js_source.ml:161 exceeds the margin
-Warning: tests/js_source.ml:2671 exceeds the margin
-Warning: tests/js_source.ml:9568 exceeds the margin
-Warning: tests/js_source.ml:9672 exceeds the margin
-Warning: tests/js_source.ml:9731 exceeds the margin
-Warning: tests/js_source.ml:9814 exceeds the margin
-Warning: tests/js_source.ml:10320 exceeds the margin
+Warning: tests/js_source.ml:2670 exceeds the margin
+Warning: tests/js_source.ml:9567 exceeds the margin
+Warning: tests/js_source.ml:9671 exceeds the margin
+Warning: tests/js_source.ml:9730 exceeds the margin
+Warning: tests/js_source.ml:9813 exceeds the margin
+Warning: tests/js_source.ml:10319 exceeds the margin

test/passing/tests/js_source.ml.ocp

@@ -2430,8 +2430,7 @@ let eval
       (type c)
       (bop : (a, b, c) binop)
       (x : a constant)
-      (y : b constant)
-  : c constant
+      (y : b constant) : c constant
   =
   match bop, x, y with
   | Eq, Bool x, Bool y -> Bool (if x then y else not y)
@@ -9587,7 +9586,7 @@ 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.ref

@@ -2430,8 +2430,7 @@ let eval
       (type c)
       (bop : (a, b, c) binop)
       (x : a constant)
-      (y : b constant)
-  : c constant
+      (y : b constant) : c constant
   =
   match bop, x, y with
   | Eq, Bool x, Bool y -> Bool (if x then y else not y)
@@ -9587,7 +9586,7 @@ 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/ocp_indent_compat.ml

@@ -73,10 +73,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/polytypes-janestreet.ml.ref

@@ -1,14 +1,14 @@
 let t1 : 'a 'b. 'a t -> b t = ()
 
 let t2
-  : 'a 'b.
+  :  'a 'b.
   'a t________________________________ -> 'b t_______________________________________
   =
   ()
 ;;
 
 let t3
-  : 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that 'must 'wrap.
+  :  'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that 'must 'wrap.
   'a t_________________________________________________
   -> 'b t______________________________________________________________
   -> 'c t______________________________________________________________
@@ -18,9 +18,9 @@ let t3
 
 let t4
   : 'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that 'must 'wrap.
-  'a t_________________________________________________
-  * 'b t______________________________________________________________
-  * 'c t______________________________________________________________
+    'a t_________________________________________________
+    * 'b t______________________________________________________________
+    * 'c t______________________________________________________________
   =
   ()
 ;;

test/rpc/rpc_test.expected

@@ -96,7 +96,7 @@ let ssmap
 '
 Output:
 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
   =
   ()