From b1788844c29b546142d48148bb4bc222d51aa886 Mon Sep 17 00:00:00 2001 From: Guillaume Petiot Date: Wed, 11 Oct 2023 09:42:25 +0100 Subject: [PATCH] Reduce the indentation of (polytype) type constraints (#2437) --- CHANGES.md | 1 + lib/Fmt_ast.ml | 40 ++++++++++--------- lib/box_debug.ml | 3 +- test/passing/tests/break_colon.ml | 4 +- ...ocp_indent_compat-break_colon_after.ml.ref | 4 +- test/passing/tests/polytypes-default.ml.ref | 40 +++++++++++++------ .../passing/tests/polytypes-janestreet.ml.err | 1 + .../passing/tests/polytypes-janestreet.ml.ref | 17 ++++++++ test/passing/tests/polytypes.ml | 40 +++++++++++++------ test/passing/tests/source.ml.err | 2 +- test/passing/tests/source.ml.ref | 40 +++++++------------ 11 files changed, 116 insertions(+), 76 deletions(-) create mode 100644 test/passing/tests/polytypes-janestreet.ml.err diff --git a/CHANGES.md b/CHANGES.md index 9751fb5b59..15e9d49c77 100644 --- a/CHANGES.md +++ b/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 diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index d59dc2d6ed..330dd29cdd 100644 --- a/lib/Fmt_ast.ml +++ b/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 diff --git a/lib/box_debug.ml b/lib/box_debug.ml index f4db9027ff..f76d968183 100644 --- a/lib/box_debug.ml +++ b/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 diff --git a/test/passing/tests/break_colon.ml b/test/passing/tests/break_colon.ml index 573c51e033..61c9741e50 100644 --- a/test/passing/tests/break_colon.ml +++ b/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) diff --git a/test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref b/test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref index 633d0168dc..5afc5d045f 100644 --- a/test/passing/tests/ocp_indent_compat-break_colon_after.ml.ref +++ b/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 () -> () diff --git a/test/passing/tests/polytypes-default.ml.ref b/test/passing/tests/polytypes-default.ml.ref index c14913a520..9358065892 100644 --- a/test/passing/tests/polytypes-default.ml.ref +++ b/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 diff --git a/test/passing/tests/polytypes-janestreet.ml.err b/test/passing/tests/polytypes-janestreet.ml.err new file mode 100644 index 0000000000..b477480650 --- /dev/null +++ b/test/passing/tests/polytypes-janestreet.ml.err @@ -0,0 +1 @@ +Warning: tests/polytypes.ml:47 exceeds the margin diff --git a/test/passing/tests/polytypes-janestreet.ml.ref b/test/passing/tests/polytypes-janestreet.ml.ref index 963ec381b0..a35e53e6b5 100644 --- a/test/passing/tests/polytypes-janestreet.ml.ref +++ b/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 +;; diff --git a/test/passing/tests/polytypes.ml b/test/passing/tests/polytypes.ml index 83cdbfef5d..9a9ae969df 100644 --- a/test/passing/tests/polytypes.ml +++ b/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 diff --git a/test/passing/tests/source.ml.err b/test/passing/tests/source.ml.err index 50f7e55a5d..16b867f5da 100644 --- a/test/passing/tests/source.ml.err +++ b/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 diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index 80b701989f..0ec00cfffc 100644 --- a/test/passing/tests/source.ml.ref +++ b/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,8 +1620,8 @@ 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 @@ -1632,8 +1629,7 @@ let rec plus_func : 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