Reduce the indentation of (polytype) type constraints (#2437)

CHANGES.md

@@ -11,6 +11,7 @@ profile. This started with version 0.26.0.
 - Documentation comments are now formatted by default (#2390, @Julow)
   Use the option `parse-docstrings = false` to disable.
 - \* Janestreet profile: do not break `fun _ -> function` (#2460, @tdelvecchio-jsc)
+- \* Reduce the indentation of (polytype) type constraints (#2437, @gpetiot)
 
 ### Fixed
 

lib/Fmt_ast.ml

@@ -4353,29 +4353,32 @@ and fmt_value_binding c ~rec_flag ?ext ?in_ ?epi
   in
   let doc1, atrs = doc_atrs lb_attrs in
   let doc2, atrs = doc_atrs atrs in
-  let fmt_cstr =
+  let fmt_newtypes, fmt_cstr =
     let fmt_sep x =
       match c.conf.fmt_opts.break_colon.v with
       | `Before -> fmt "@ " $ str x $ char ' '
       | `After -> char ' ' $ str x $ fmt "@ "
     in
     match lb_typ with
-    | `Polynewtype (pvars, xtyp) ->
-        fmt_sep ":"
-        $ hvbox 0
-            ( str "type "
-            $ list pvars " " (fmt_str_loc c)
-            $ fmt ".@ " $ fmt_core_type c xtyp )
+    | `Polynewtype (pvars, xtyp) -> (
+      match c.conf.fmt_opts.break_colon.v with
+      | `Before ->
+          ( noop
+          , fmt_sep ":"
+            $ hvbox 0
+                ( str "type "
+                $ list pvars " " (fmt_str_loc c)
+                $ fmt ".@ " $ fmt_core_type c xtyp ) )
+      | `After ->
+          ( fmt_sep ":"
+            $ hvbox 0 (str "type " $ list pvars " " (fmt_str_loc c) $ str ".")
+          , fmt "@ " $ fmt_core_type c xtyp ) )
     | `Coerce (xtyp1, xtyp2) ->
-        opt xtyp1 (fun xtyp1 -> fmt_sep ":" $ fmt_core_type c xtyp1)
-        $ fmt_sep ":>" $ fmt_core_type c xtyp2
-    | `Other xtyp -> fmt_type_cstr c xtyp
-    | `None -> noop
-  in
-  let cstr_indent =
-    match lb_typ with
-    | `Other {ast= {ptyp_desc= Ptyp_poly _; _}; _} -> 6
-    | _ -> 4
+        ( noop
+        , opt xtyp1 (fun xtyp1 -> fmt_sep ":" $ fmt_core_type c xtyp1)
+          $ fmt_sep ":>" $ fmt_core_type c xtyp2 )
+    | `Other xtyp -> (noop, fmt_type_cstr c xtyp)
+    | `None -> (noop, noop)
   in
   let indent =
     match lb_exp.ast.pexp_desc with
@@ -4416,7 +4419,7 @@ and fmt_value_binding c ~rec_flag ?ext ?in_ ?epi
           ( hvbox_if toplevel 0
               ( hvbox_if toplevel indent
                   ( hovbox 2
-                      ( hovbox cstr_indent
+                      ( hovbox 4
                           ( box_fun_decl_args c 4
                               ( hovbox 4
                                   ( fmt_str_loc c lb_op
@@ -4429,7 +4432,8 @@ and fmt_value_binding c ~rec_flag ?ext ?in_ ?epi
                                   (not (List.is_empty lb_args))
                                   ( fmt "@ "
                                   $ wrap_fun_decl_args c
-                                      (fmt_fun_args c lb_args) ) )
+                                      (fmt_fun_args c lb_args) )
+                              $ fmt_newtypes )
                           $ fmt_cstr )
                       $ fmt_if_k (not lb_pun)
                           (fmt_or_k c.conf.fmt_opts.ocp_indent_compat.v

lib/box_debug.ml

@@ -120,8 +120,7 @@ let _pp_format_lit fs =
   | Escaped_percent -> fprintf fs "@@%%"
   | Scan_indic c -> pp_keyword fs ("@" ^ String.make 1 c)
 
-let rec _format_string :
-    type a b c d e f.
+let rec _format_string : type a b c d e f.
     _ -> (a, b, c, d, e, f) CamlinternalFormatBasics.fmt -> unit =
   let open CamlinternalFormatBasics in
   fun fs -> function

test/passing/tests/break_colon.ml

@@ -76,8 +76,8 @@ let ssmap :
     -> unit =
   ()
 
-let long_function_name :
-    type a. a long_long_type -> a -> a -> a -> wrap_wrap_wrap -> unit =
+let long_function_name : type a.
+    a long_long_type -> a -> a -> a -> wrap_wrap_wrap -> unit =
  fun () -> ()
 
 let array_fold_transf (f : numbering -> 'a -> numbering * 'b) n (a : 'a array)

test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref

@@ -79,8 +79,8 @@ let ssmap :
   =
   ()
 
-let long_function_name :
-    type a. a long_long_type -> a -> a -> a -> wrap_wrap_wrap -> unit
+let long_function_name : type a.
+    a long_long_type -> a -> a -> a -> wrap_wrap_wrap -> unit
   =
  fun () -> ()
 

test/passing/tests/polytypes-default.ml.ref

@@ -1,25 +1,25 @@
 let t1 : 'a 'b. 'a t -> b t = ()
 
 let t2 :
-      'a 'b.
-      'a t________________________________ ->
-      'b t_______________________________________ =
+    'a 'b.
+    'a t________________________________ ->
+    'b t_______________________________________ =
   ()
 
 let t3 :
-      'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that
-      'must 'wrap.
-      'a t_________________________________________________ ->
-      'b t______________________________________________________________ ->
-      'c t______________________________________________________________ =
+    'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that 'must
+    'wrap.
+    'a t_________________________________________________ ->
+    'b t______________________________________________________________ ->
+    'c t______________________________________________________________ =
   ()
 
 let t4 :
-      'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that
-      'must 'wrap.
-      'a t_________________________________________________
-      * 'b t______________________________________________________________
-      * 'c t______________________________________________________________ =
+    'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that 'must
+    'wrap.
+    'a t_________________________________________________
+    * 'b t______________________________________________________________
+    * 'c t______________________________________________________________ =
   ()
 
 let foo : type a. a =
@@ -33,3 +33,17 @@ class c =
 let _ =
   let id : 'a. 'a -> 'a = fun x -> x in
   ()
+
+let equal_list :
+    'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool =
+ fun es1 es2 ->
+  try List.for_all2 equal es1 es2 with Invalid_argument _ -> false
+
+let rec equal_list :
+    'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool =
+ fun es1 es2 ->
+  try List.for_all2 equal es1 es2 with Invalid_argument _ -> false
+
+and equal : 'a. ('a, 't) gexpr marked -> ('a, 't) gexpr marked -> bool =
+ fun (type a) (e1 : (a, 't) gexpr marked) (e2 : (a, 't) gexpr marked) ->
+  match (Marked.unmark e1, Marked.unmark e2) with x -> x

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

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

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

@@ -38,3 +38,20 @@ let _ =
   let id : 'a. 'a -> 'a = fun x -> x in
   ()
 ;;
+
+let equal_list : 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool =
+  fun es1 es2 ->
+  try List.for_all2 equal es1 es2 with
+  | Invalid_argument _ -> false
+;;
+
+let rec equal_list : 'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool =
+  fun es1 es2 ->
+  try List.for_all2 equal es1 es2 with
+  | Invalid_argument _ -> false
+
+and equal : 'a. ('a, 't) gexpr marked -> ('a, 't) gexpr marked -> bool =
+  fun (type a) (e1 : (a, 't) gexpr marked) (e2 : (a, 't) gexpr marked) ->
+  match Marked.unmark e1, Marked.unmark e2 with
+  | x -> x
+;;

test/passing/tests/polytypes.ml

@@ -1,25 +1,25 @@
 let t1 : 'a 'b. 'a t -> b t = ()
 
 let t2 :
-      'a 'b.
-         'a t________________________________
-      -> 'b t_______________________________________ =
+    'a 'b.
+       'a t________________________________
+    -> 'b t_______________________________________ =
   ()
 
 let t3 :
-      'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that
-      'must 'wrap.
-         'a t_________________________________________________
-      -> 'b t______________________________________________________________
-      -> 'c t______________________________________________________________ =
+    'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that
+    'must 'wrap.
+       'a t_________________________________________________
+    -> 'b t______________________________________________________________
+    -> 'c t______________________________________________________________ =
   ()
 
 let t4 :
-      'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that
-      'must 'wrap.
-      'a t_________________________________________________
-      * 'b t______________________________________________________________
-      * 'c t______________________________________________________________ =
+    'long 'sequence 'of_ 'universally 'quantified 'type_ 'variables 'that
+    'must 'wrap.
+    'a t_________________________________________________
+    * 'b t______________________________________________________________
+    * 'c t______________________________________________________________ =
   ()
 
 let foo : type a. a =
@@ -33,3 +33,17 @@ class c =
 let _ =
   let id : 'a. 'a -> 'a = fun x -> x in
   ()
+
+let equal_list :
+    'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool =
+ fun es1 es2 ->
+  try List.for_all2 equal es1 es2 with Invalid_argument _ -> false
+
+let rec equal_list :
+    'a. ('a, 't) gexpr marked list -> ('a, 't) gexpr marked list -> bool =
+ fun es1 es2 ->
+  try List.for_all2 equal es1 es2 with Invalid_argument _ -> false
+
+and equal : 'a. ('a, 't) gexpr marked -> ('a, 't) gexpr marked -> bool =
+ fun (type a) (e1 : (a, 't) gexpr marked) (e2 : (a, 't) gexpr marked) ->
+  match (Marked.unmark e1, Marked.unmark e2) with x -> x

test/passing/tests/source.ml.err

@@ -1,2 +1,2 @@
 Warning: tests/source.ml:702 exceeds the margin
-Warning: tests/source.ml:2318 exceeds the margin
+Warning: tests/source.ml:2311 exceeds the margin

test/passing/tests/source.ml.ref

@@ -1206,8 +1206,8 @@ type _ ty_env =
 (* Comparing selectors *)
 type (_, _) eq = Eq : ('a, 'a) eq
 
-let rec eq_sel :
-    type a b c. (a, b) ty_sel -> (a, c) ty_sel -> (b, c) eq option =
+let rec eq_sel : type a b c.
+    (a, b) ty_sel -> (a, c) ty_sel -> (b, c) eq option =
  fun s1 s2 ->
   match (s1, s2) with
   | Thd, Thd -> Some Eq
@@ -1216,8 +1216,7 @@ let rec eq_sel :
   | _ -> None
 
 (* Auxiliary function to get the type of a case from its selector *)
-let rec get_case :
-    type a b e.
+let rec get_case : type a b e.
        (b, a) ty_sel
     -> (string * (e, b) ty_case) list
     -> string * (a, e) ty option =
@@ -1312,8 +1311,7 @@ let ty_abc =
     | `B s -> ("B", Some (Tdyn (String, s)))
     | `C -> ("C", None)
   (* Define inj in advance to be able to write the type annotation easily *)
-  and inj :
-      type c.
+  and inj : type c.
          (int -> string -> noarg -> unit, c) ty_sel * c
       -> [`A of int | `B of string | `C] = function
     | Thd, v -> `A v
@@ -1560,9 +1558,8 @@ type (_, _) tree =
 
 let tree1 = Tfork (Tfork (Ttip, Tnode 4), Tfork (Tnode 4, Tnode 3))
 
-let rec find :
-    type sh. ('a -> 'a -> bool) -> 'a -> (sh, 'a) tree -> (sh, 'a) path list
-    =
+let rec find : type sh.
+    ('a -> 'a -> bool) -> 'a -> (sh, 'a) tree -> (sh, 'a) path list =
  fun eq n t ->
   match t with
   | Ttip -> []
@@ -1623,17 +1620,16 @@ let rec sameNat : type a b. a nat -> b nat -> (a, b) equal option =
 
 (* Extra: associativity of addition *)
 
-let rec plus_func :
-    type a b m n. (a, b, m) plus -> (a, b, n) plus -> (m, n) equal =
+let rec plus_func : type a b m n.
+    (a, b, m) plus -> (a, b, n) plus -> (m, n) equal =
  fun p1 p2 ->
   match (p1, p2) with
   | PlusZ _, PlusZ _ -> Eq
   | PlusS p1', PlusS p2' ->
       let Eq = plus_func p1' p2' in
       Eq
 
-let rec plus_assoc :
-    type a b c ab bc m n.
+let rec plus_assoc : type a b c ab bc m n.
        (a, b, ab) plus
     -> (ab, c, m) plus
     -> (b, c, bc) plus
@@ -1724,8 +1720,7 @@ let rec elem : type h. int -> h avl -> bool =
   | Leaf -> false
   | Node (_, l, y, r) -> x = y || if x < y then elem x l else elem x r
 
-let rec rotr :
-    type n.
+let rec rotr : type n.
        n succ succ avl
     -> int
     -> n avl
@@ -1741,8 +1736,7 @@ let rec rotr :
   | Node (Less, a, x, Node (More, b, z, c)) ->
       Inl (Node (Same, Node (Same, a, x, b), z, Node (Less, c, y, tR)))
 
-let rec rotl :
-    type n.
+let rec rotl : type n.
        n avl
     -> int
     -> n succ succ avl
@@ -2223,8 +2217,7 @@ type closed = rnil
 
 type 'a rlam = ((pexp, closed, 'a) lam, (pval, closed, 'a) lam) sum
 
-let rec rule :
-    type a b.
+let rec rule : type a b.
     (pval, closed, (a, b) tarr) lam -> (pval, closed, a) lam -> b rlam =
  fun v1 v2 ->
   match (v1, v2) with
@@ -4099,16 +4092,14 @@ end = struct
   let _ = fun (_ : ('a, 'perms) t) -> ()
 
   let t_of_sexp :
-        'a 'perms. (sexp -> 'a) -> (sexp -> 'perms) -> sexp -> ('a, 'perms) t
-      =
+      'a 'perms. (sexp -> 'a) -> (sexp -> 'perms) -> sexp -> ('a, 'perms) t =
     let _tp_loc = "core_array.ml.Permissioned.t" in
     fun _of_a _of_perms t -> (array_of_sexp _of_a) t
 
   let _ = t_of_sexp
 
   let sexp_of_t :
-        'a 'perms. ('a -> sexp) -> ('perms -> sexp) -> ('a, 'perms) t -> sexp
-      =
+      'a 'perms. ('a -> sexp) -> ('perms -> sexp) -> ('a, 'perms) t -> sexp =
    fun _of_a _of_perms v -> (sexp_of_array _of_a) v
 
   let _ = sexp_of_t
@@ -8372,8 +8363,7 @@ type (_, _, _, _) u = U : (int, int, int, int) u
 
 type v = E | F | G
 
-let f :
-    type a b c d e f g.
+let f : type a b c d e f g.
        a t
        * b t
        * c t