From d15696e9df4f4aaa7e344c4d80bbbca0e91c08bd Mon Sep 17 00:00:00 2001 From: Jakub Bachurski Date: Thu, 16 Apr 2026 11:42:25 +0100 Subject: [PATCH 1/5] Add tests --- test/passing/tests/quotations.mli | 62 ++++++++++++++++++++++++ test/passing/tests/quotations.mli.js-ref | 50 +++++++++++++++++++ 2 files changed, 112 insertions(+) diff --git a/test/passing/tests/quotations.mli b/test/passing/tests/quotations.mli index ec97e85adf..c698578603 100644 --- a/test/passing/tests/quotations.mli +++ b/test/passing/tests/quotations.mli @@ -5,3 +5,65 @@ type t = <[int]> type 'a t = <[$'a list -> $'a option]> val foo : <[int]> expr + +type 'a t = <[$'a]> + +type 'a t = $(<['a]>) + +type 'a t = + <[ ($'a -> $'a -> $'a -> $'a) + -> ($'a -> $'a -> $'a -> $'a) + -> ($'a -> $'a -> $'a -> $'a) + -> ($'a -> $'a -> $'a -> $'a) ]> + +(* These cases are probably impossible *) +type 'a t = $(int * float) + +type 'a t = $(#(int * float)) + +(** Quotes **) + +(* Attributes *) + +type t = <[(int[@attr])]> + +type 'a t = <[('a list[@attr])]> + +(* Comments *) + +type t = <[int (* post *)]> + +type t = <[(* pre *) int]> + +type t = <[int (* in *) list]> + +(* Attributes & comments *) + +type t = <[(int[@attr] (* post *))]> + +type t = <[((* pre *) int[@attr])]> + +(** Splices **) + +(* Attributes *) + +type t = <[$(int[@attr])]> + +type 'a t = <[$(('a list[@attr]))]> + +type 'a t = + <[($'a option[@attr]) -> ($'a option[@attr]) -> ($'a list[@attr])]> + +(* Comments *) + +type t = $int (* post *) + +type t = $(* pre *) int + +type t = $(int (* in *) list) + +(* Attributes & comments *) + +type t = $(int[@attr] (* post *)) + +type t = $((* pre *) int[@attr]) diff --git a/test/passing/tests/quotations.mli.js-ref b/test/passing/tests/quotations.mli.js-ref index 2cfa2583d8..30c7f9cbf7 100644 --- a/test/passing/tests/quotations.mli.js-ref +++ b/test/passing/tests/quotations.mli.js-ref @@ -4,3 +4,53 @@ type t = <[int]> type 'a t = <[$'a list -> $'a option]> val foo : <[int]> expr + +type 'a t = <[$'a]> +type 'a t = $(<['a]>) + +type 'a t = + <[ ($'a -> $'a -> $'a -> $'a) + -> ($'a -> $'a -> $'a -> $'a) + -> ($'a -> $'a -> $'a -> $'a) + -> ($'a -> $'a -> $'a -> $'a) ]> + +(* These cases are probably impossible *) +type 'a t = $(int * float) +type 'a t = $(#(int * float)) + +(** Quotes **) + +(* Attributes *) + +type t = <[(int[@attr])]> +type 'a t = <[('a list[@attr])]> + +(* Comments *) + +type t = <[int (* post *)]> +type t = <[(* pre *) int]> +type t = <[int (* in *) list]> + +(* Attributes & comments *) + +type t = <[(int[@attr] (* post *))]> +type t = <[((* pre *) int[@attr])]> + +(** Splices **) + +(* Attributes *) + +type t = <[$(int[@attr])]> +type 'a t = <[$(('a list[@attr]))]> +type 'a t = <[($'a option[@attr]) -> ($'a option[@attr]) -> ($'a list[@attr])]> + +(* Comments *) + +type t = $int (* post *) +type t = $(* pre *) int +type t = $(int (* in *) list) + +(* Attributes & comments *) + +type t = $(int[@attr] (* post *)) +type t = $((* pre *) int[@attr]) From 9032c83a5127edc136018a25bb94de5ce437fc61 Mon Sep 17 00:00:00 2001 From: Jakub Bachurski Date: Thu, 16 Apr 2026 13:15:33 +0100 Subject: [PATCH 2/5] Quote & splice type formatting with attributes & comments --- lib/Fmt_ast.ml | 15 ++++++++++----- test/passing/tests/quotations.ml | 8 ++++++++ test/passing/tests/quotations.ml.js-ref | 8 ++++++++ test/passing/tests/quotations.mli | 6 +++++- test/passing/tests/quotations.mli.js-ref | 4 +++- 5 files changed, 34 insertions(+), 7 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index d206a2aa14..752e69eed9 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1294,13 +1294,18 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx | Ptyp_quote t -> wrap_fits_breaks c.conf "<[" "]>" (fmt_core_type c (sub_typ ~ctx t)) | Ptyp_splice t -> - let needs_parens = - match t.ptyp_desc with - | Ptyp_var _ | Ptyp_constr (_, []) -> false - | _ -> true + let _, t_atrs = doc_atrs t.ptyp_attributes in + let parens = + (* Do not add parentheses around: *) + match (t.ptyp_desc, t_atrs) with + (* - atoms *) + | (Ptyp_var _ | Ptyp_constr (_, [])), _ -> false + (* - expressions with attributes, which should add them anyway *) + | _, _ :: _ -> false + | _, [] -> true in fmt "$" - $ Params.parens_if needs_parens c.conf + $ Params.parens_if parens c.conf (fmt_core_type c (sub_typ ~ctx:(Typ typ) t)) and fmt_labeled_tuple_type c lbl xtyp = diff --git a/test/passing/tests/quotations.ml b/test/passing/tests/quotations.ml index 503abbc527..8a4ea80063 100644 --- a/test/passing/tests/quotations.ml +++ b/test/passing/tests/quotations.ml @@ -123,3 +123,11 @@ let _ = ;; let _ = <[ fun x -> $((fun y -> y) (<[ x ]> [@nontail])) [@inlined] ]> [@boxed] + +(* Splices with comments and attributes *) + +let f x y z w = <[ $(x [@attr]) + $(* pre *) y + $z (* post *) + $w ]> + +(* Splices $ should be consistent with prefix operators *) + +let g ( ! ) x y z w = !(x [@attr]) + !(* pre *) y + !z (* post *) + !w diff --git a/test/passing/tests/quotations.ml.js-ref b/test/passing/tests/quotations.ml.js-ref index 503abbc527..8a4ea80063 100644 --- a/test/passing/tests/quotations.ml.js-ref +++ b/test/passing/tests/quotations.ml.js-ref @@ -123,3 +123,11 @@ let _ = ;; let _ = <[ fun x -> $((fun y -> y) (<[ x ]> [@nontail])) [@inlined] ]> [@boxed] + +(* Splices with comments and attributes *) + +let f x y z w = <[ $(x [@attr]) + $(* pre *) y + $z (* post *) + $w ]> + +(* Splices $ should be consistent with prefix operators *) + +let g ( ! ) x y z w = !(x [@attr]) + !(* pre *) y + !z (* post *) + !w diff --git a/test/passing/tests/quotations.mli b/test/passing/tests/quotations.mli index c698578603..c4d19937ee 100644 --- a/test/passing/tests/quotations.mli +++ b/test/passing/tests/quotations.mli @@ -35,6 +35,8 @@ type t = <[int (* post *)]> type t = <[(* pre *) int]> +type t = <[(* pre *) int (* post *)]> + type t = <[int (* in *) list]> (* Attributes & comments *) @@ -49,7 +51,7 @@ type t = <[((* pre *) int[@attr])]> type t = <[$(int[@attr])]> -type 'a t = <[$(('a list[@attr]))]> +type 'a t = <[$('a list[@attr])]> type 'a t = <[($'a option[@attr]) -> ($'a option[@attr]) -> ($'a list[@attr])]> @@ -60,6 +62,8 @@ type t = $int (* post *) type t = $(* pre *) int +type t = $(* pre *) int (* post *) + type t = $(int (* in *) list) (* Attributes & comments *) diff --git a/test/passing/tests/quotations.mli.js-ref b/test/passing/tests/quotations.mli.js-ref index 30c7f9cbf7..845dcdac59 100644 --- a/test/passing/tests/quotations.mli.js-ref +++ b/test/passing/tests/quotations.mli.js-ref @@ -29,6 +29,7 @@ type 'a t = <[('a list[@attr])]> type t = <[int (* post *)]> type t = <[(* pre *) int]> +type t = <[(* pre *) int (* post *)]> type t = <[int (* in *) list]> (* Attributes & comments *) @@ -41,13 +42,14 @@ type t = <[((* pre *) int[@attr])]> (* Attributes *) type t = <[$(int[@attr])]> -type 'a t = <[$(('a list[@attr]))]> +type 'a t = <[$('a list[@attr])]> type 'a t = <[($'a option[@attr]) -> ($'a option[@attr]) -> ($'a list[@attr])]> (* Comments *) type t = $int (* post *) type t = $(* pre *) int +type t = $(* pre *) int (* post *) type t = $(int (* in *) list) (* Attributes & comments *) From fedbda2356061b1bbd74b475e5f8280ac3e0ac57 Mon Sep 17 00:00:00 2001 From: David Vulakh Date: Tue, 21 Apr 2026 10:31:28 -0400 Subject: [PATCH 3/5] move splice parsing closer to parser's also use the standard parenze method for determining whether to parenthesize and fix the double-parenthisization bug more broadly Signed-off-by: David Vulakh --- lib/Ast.ml | 4 +++ lib/Fmt_ast.ml | 36 ++++++++----------- test/passing/tests/attributes.ml | 4 +-- .../passing/tests/dropped_attribute.ml.js-ref | 2 +- test/passing/tests/dropped_attribute.ml.ref | 2 +- test/passing/tests/modes_attrs.ml.js-ref | 4 +-- test/passing/tests/modes_attrs.ml.ref | 6 ++-- test/passing/tests/quotations.mli | 14 +++++++- test/passing/tests/quotations.mli.js-ref | 8 ++++- test/passing/tests/shortcut_ext_attr.ml | 2 +- .../passing/tests/shortcut_ext_attr.ml.js-ref | 2 +- test/passing/tests/source.ml.js-ref | 2 +- test/passing/tests/source.ml.ref | 2 +- vendor/parser-extended/parser.mly | 25 ++++++++++++- 14 files changed, 75 insertions(+), 38 deletions(-) diff --git a/lib/Ast.ml b/lib/Ast.ml index b7fbfcdd2d..b95ee3f050 100644 --- a/lib/Ast.ml +++ b/lib/Ast.ml @@ -2091,6 +2091,10 @@ end = struct ; ctx= Typ {ptyp_desc= Ptyp_arrow (args, _, _); _} } when List.exists args ~f:(fun arg -> arg.pap_type == typ) -> true + | {ast= {ptyp_desc; _}; ctx= Typ {ptyp_desc= Ptyp_splice _; _}} -> ( + match ptyp_desc with + | Ptyp_var _ | Ptyp_constr (_, []) | Ptyp_variant _ -> false + | _ -> true ) | _ -> ( match ambig_prec (sub_ast ~ctx (Typ typ)) with | `Ambiguous -> true diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index 752e69eed9..ff55d9261c 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1084,16 +1084,15 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx let tydecl_param_atrs, atrs = if tydecl_param then (atrs, []) else ([], atrs) in + let atr_parens = match atrs with [] -> false | _ :: _ -> true in Cmts.fmt c ptyp_loc @@ (fun k -> k $ fmt_docstring c ~pro:(fmt "@ ") doc) - @@ ( match atrs with - | [] -> Fn.id - | _ -> - fun k -> - hvbox 0 - (Params.parens c.conf (k $ fmt_attributes c ~pre:Cut atrs)) ) + @@ (fun k -> + hvbox_if atr_parens 0 + (Params.parens_if atr_parens c.conf + (k $ fmt_attributes c ~pre:Cut atrs) ) ) @@ - let parens = (not tydecl_param) && parenze_typ xtyp in + let parens = (not atr_parens) && (not tydecl_param) && parenze_typ xtyp in hvbox_if box 0 @@ Params.parens_if ( match typ.ptyp_desc with @@ -1185,6 +1184,14 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx let typ = sub_typ ~ctx typ in fmt_labeled_tuple_type c lbl typ ) ) ) ) | Ptyp_unboxed_tuple typs -> + (*= + (* This is slightly a hack: we usually ignore parentheses from [parenze_typ], but + [$#(] won't lex correctly, and so needs parens. *) + (match xtyp.ctx with + | Typ {ptyp_desc = Ptyp_splice _ ; _} -> wrap "(" ")" + | _ -> Fn.id + ) @@ + *) hvbox 1 (wrap_fits_breaks ~space:false c.conf "#(" ")" (list typs "@ * " (fun (lbl, typ) -> @@ -1293,20 +1300,7 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx ) ) | Ptyp_quote t -> wrap_fits_breaks c.conf "<[" "]>" (fmt_core_type c (sub_typ ~ctx t)) - | Ptyp_splice t -> - let _, t_atrs = doc_atrs t.ptyp_attributes in - let parens = - (* Do not add parentheses around: *) - match (t.ptyp_desc, t_atrs) with - (* - atoms *) - | (Ptyp_var _ | Ptyp_constr (_, [])), _ -> false - (* - expressions with attributes, which should add them anyway *) - | _, _ :: _ -> false - | _, [] -> true - in - fmt "$" - $ Params.parens_if parens c.conf - (fmt_core_type c (sub_typ ~ctx:(Typ typ) t)) + | Ptyp_splice t -> fmt "$" $ fmt_core_type c (sub_typ ~ctx:(Typ typ) t) and fmt_labeled_tuple_type c lbl xtyp = match lbl with diff --git a/test/passing/tests/attributes.ml b/test/passing/tests/attributes.ml index 6b30dc43a0..4b87c97cd8 100644 --- a/test/passing/tests/attributes.ml +++ b/test/passing/tests/attributes.ml @@ -149,7 +149,7 @@ let () = () and[@warning "-32"] f = () -external x : a -> b -> ((a -> b)[@test]) = "" +external x : a -> b -> (a -> b[@test]) = "" let f = fun [@test] x y -> () @@ -158,7 +158,7 @@ let f y = fun [@test] y -> () let (f [@test]) = fun y -> fun [@test] y -> () module type T = sig - class subst : ((ident -> ident)[@attr]) -> (ident -> ident) -> object + class subst : (ident -> ident[@attr]) -> (ident -> ident) -> object inherit mapper end[@attr] end diff --git a/test/passing/tests/dropped_attribute.ml.js-ref b/test/passing/tests/dropped_attribute.ml.js-ref index 907cc898c6..cae30ced91 100644 --- a/test/passing/tests/dropped_attribute.ml.js-ref +++ b/test/passing/tests/dropped_attribute.ml.js-ref @@ -1,7 +1,7 @@ (* Attributes [[@annot2]] and [[@annot4]] used to be dropped by ocamlformat *) module _ : sig - val foo : ((module T with type t = 'a)[@annot2]) -> unit + val foo : (module T with type t = 'a[@annot2]) -> unit end = struct let foo (type a) (module M : T with type t = a[@annot4]) = () end diff --git a/test/passing/tests/dropped_attribute.ml.ref b/test/passing/tests/dropped_attribute.ml.ref index 78e12a3a46..503ad28bde 100644 --- a/test/passing/tests/dropped_attribute.ml.ref +++ b/test/passing/tests/dropped_attribute.ml.ref @@ -2,7 +2,7 @@ ocamlformat *) module _ : sig - val foo : ((module T with type t = 'a)[@annot2]) -> unit + val foo : (module T with type t = 'a[@annot2]) -> unit end = struct let foo (type a) (module M : T with type t = a[@annot4]) = () end diff --git a/test/passing/tests/modes_attrs.ml.js-ref b/test/passing/tests/modes_attrs.ml.js-ref index 7d5f8ad5b7..c5972a2535 100644 --- a/test/passing/tests/modes_attrs.ml.js-ref +++ b/test/passing/tests/modes_attrs.ml.js-ref @@ -41,7 +41,7 @@ type t = | A of t1 @@ m1 m2 * (t2[@attr]) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 | A of t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3[@attr]) @ m5 -> t4 @ m6) @@ m7 m8 | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (t4[@attr]) @ m6) @@ m7 m8 - | A of t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3 @ m5 -> t4 @ m6)[@attr]) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6[@attr]) @@ m7 m8 | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 [@attr] type t = @@ -49,7 +49,7 @@ type t = | A : t1 @@ m1 m2 * (t2[@attr]) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t | A : t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3[@attr]) @ m5 -> t4 @ m6) @@ m7 m8 -> t | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (t4[@attr]) @ m6) @@ m7 m8 -> t - | A : t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3 @ m5 -> t4 @ m6)[@attr]) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6[@attr]) @@ m7 m8 -> t | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t [@attr] (* value descriptions *) diff --git a/test/passing/tests/modes_attrs.ml.ref b/test/passing/tests/modes_attrs.ml.ref index 8b59896f05..651658dc71 100644 --- a/test/passing/tests/modes_attrs.ml.ref +++ b/test/passing/tests/modes_attrs.ml.ref @@ -59,7 +59,7 @@ type t = | A of t1 @@ m1 m2 * (t2[@attr]) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 | A of t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3[@attr]) @ m5 -> t4 @ m6) @@ m7 m8 | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (t4[@attr]) @ m6) @@ m7 m8 - | A of t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3 @ m5 -> t4 @ m6)[@attr]) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6[@attr]) @@ m7 m8 | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 [@attr] type t = @@ -75,9 +75,7 @@ type t = | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (t4[@attr]) @ m6) @@ m7 m8 -> t - | A : - t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3 @ m5 -> t4 @ m6)[@attr]) @@ m7 m8 - -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6[@attr]) @@ m7 m8 -> t | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t [@attr] diff --git a/test/passing/tests/quotations.mli b/test/passing/tests/quotations.mli index c4d19937ee..d5828ebfc2 100644 --- a/test/passing/tests/quotations.mli +++ b/test/passing/tests/quotations.mli @@ -19,7 +19,19 @@ type 'a t = (* These cases are probably impossible *) type 'a t = $(int * float) -type 'a t = $(#(int * float)) +type 'a t = $#(int * float) + +type 'a t = $[`a | `b] + +type 'a t = $[> `a | `b] + +type 'a t = $[< `a | `b] + +type 'a t = $(module M) + +type 'a t = $(< .. >) + +type 'a t = $(<[t]>) (** Quotes **) diff --git a/test/passing/tests/quotations.mli.js-ref b/test/passing/tests/quotations.mli.js-ref index 845dcdac59..8a0231307a 100644 --- a/test/passing/tests/quotations.mli.js-ref +++ b/test/passing/tests/quotations.mli.js-ref @@ -16,7 +16,13 @@ type 'a t = (* These cases are probably impossible *) type 'a t = $(int * float) -type 'a t = $(#(int * float)) +type 'a t = $#(int * float) +type 'a t = $[ `a | `b ] +type 'a t = $[> `a | `b ] +type 'a t = $[< `a | `b ] +type 'a t = $(module M) +type 'a t = $(< .. >) +type 'a t = $(<[t]>) (** Quotes **) diff --git a/test/passing/tests/shortcut_ext_attr.ml b/test/passing/tests/shortcut_ext_attr.ml index b7bdebcfb2..4570fc31ee 100644 --- a/test/passing/tests/shortcut_ext_attr.ml +++ b/test/passing/tests/shortcut_ext_attr.ml @@ -72,7 +72,7 @@ class type t = object end[@foo] (* Type expressions *) -type t = [%foo: ((module M)[@foo])] +type t = [%foo: (module M[@foo])] (* Module expressions *) module M = (functor [@foo] (M : S) -> (val x) [@foo] (struct end [@foo])) diff --git a/test/passing/tests/shortcut_ext_attr.ml.js-ref b/test/passing/tests/shortcut_ext_attr.ml.js-ref index b63aadfaf1..7abe4d94c6 100644 --- a/test/passing/tests/shortcut_ext_attr.ml.js-ref +++ b/test/passing/tests/shortcut_ext_attr.ml.js-ref @@ -66,7 +66,7 @@ class type t = object end[@foo] (* Type expressions *) -type t = [%foo: ((module M)[@foo])] +type t = [%foo: (module M[@foo])] (* Module expressions *) module M = (functor [@foo] (M : S) -> (val x) [@foo] (struct end [@foo])) diff --git a/test/passing/tests/source.ml.js-ref b/test/passing/tests/source.ml.js-ref index 7de837de07..aa0b424cd1 100644 --- a/test/passing/tests/source.ml.js-ref +++ b/test/passing/tests/source.ml.js-ref @@ -152,7 +152,7 @@ class type t = object end[@foo] (* Type expressions *) -type t = [%foo: ((module M)[@foo])] +type t = [%foo: (module M[@foo])] (* Module expressions *) module M = (functor [@foo] (M : S) -> (val x) [@foo] (struct end [@foo])) diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index 4d3417f524..4f00234791 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -176,7 +176,7 @@ class type t = object end[@foo] (* Type expressions *) -type t = [%foo: ((module M)[@foo])] +type t = [%foo: (module M[@foo])] (* Module expressions *) module M = (functor [@foo] (M : S) -> (val x) [@foo] (struct end [@foo])) diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly index 087a5c4f0f..3ea0474286 100644 --- a/vendor/parser-extended/parser.mly +++ b/vendor/parser-extended/parser.mly @@ -4680,14 +4680,37 @@ restricted to tail position by its %prec annotation. *) Some label, ty } spliceable_type: - /* delimited_type_supporting_local_open does not exist */ + /* delimited_type_supporting_local_open does not exist; inline its cases here + so splices accept the same delimited forms as parser-standard. */ | LPAREN core_type RPAREN { $2 } + | LPAREN MODULE ext_attributes package_core_type RPAREN + { wrap_typ_attrs ~loc:$sloc (reloc_typ ~loc:$sloc $4) $3 } | mktyp( /* begin mktyp group */ tid = mkrhs(type_longident) { Ptyp_constr (tid, []) } | QUOTE mkrhs(ident {Some $1}) { Ptyp_var ($2, None) } + | LBRACKET tag_field RBRACKET + { Ptyp_variant([$2], Closed, None) } + | LBRACKET BAR row_field_list RBRACKET + { Ptyp_variant($3, Closed, None) } + | LBRACKET row_field BAR row_field_list RBRACKET + { Ptyp_variant($2 :: $4, Closed, None) } + | LBRACKETGREATER BAR? row_field_list RBRACKET + { Ptyp_variant($3, Open, None) } + | LBRACKETGREATER RBRACKET + { Ptyp_variant([], Open, None) } + | LBRACKETLESS BAR? row_field_list RBRACKET + { Ptyp_variant($3, Closed, Some []) } + | LBRACKETLESS BAR? row_field_list GREATER name_tag_list RBRACKET + { Ptyp_variant($3, Closed, Some $5) } + | HASHLPAREN unboxed_tuple_type_body RPAREN + { if Erase_jane_syntax.should_erase () + then Ptyp_tuple $2 + else Ptyp_unboxed_tuple $2 } + | LESSLBRACKET core_type RBRACKETGREATER + { Ptyp_quote $2 } ) { $1 } /* end mktyp group */ ; From aae73e85b4fcad7e356875aece37f64fec70564e Mon Sep 17 00:00:00 2001 From: David Vulakh Date: Tue, 21 Apr 2026 10:38:21 -0400 Subject: [PATCH 4/5] remove old commented code Signed-off-by: David Vulakh --- lib/Fmt_ast.ml | 8 -------- 1 file changed, 8 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index ff55d9261c..bccadc8f9f 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1184,14 +1184,6 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx let typ = sub_typ ~ctx typ in fmt_labeled_tuple_type c lbl typ ) ) ) ) | Ptyp_unboxed_tuple typs -> - (*= - (* This is slightly a hack: we usually ignore parentheses from [parenze_typ], but - [$#(] won't lex correctly, and so needs parens. *) - (match xtyp.ctx with - | Typ {ptyp_desc = Ptyp_splice _ ; _} -> wrap "(" ")" - | _ -> Fn.id - ) @@ - *) hvbox 1 (wrap_fits_breaks ~space:false c.conf "#(" ")" (list typs "@ * " (fun (lbl, typ) -> From 129c987f33bdfe4dbf618d4bc2371d09e212fcef Mon Sep 17 00:00:00 2001 From: David Vulakh Date: Wed, 22 Apr 2026 10:22:55 -0400 Subject: [PATCH 5/5] add back some redundant parens even though they are syntactically redundant, their absence is often visually confusing, and this pr is not the place to find a general fix Signed-off-by: David Vulakh --- lib/Fmt_ast.ml | 9 ++++++++- test/passing/tests/attributes.ml | 4 ++-- test/passing/tests/dropped_attribute.ml.js-ref | 2 +- test/passing/tests/dropped_attribute.ml.ref | 2 +- test/passing/tests/modes_attrs.ml.js-ref | 4 ++-- test/passing/tests/modes_attrs.ml.ref | 6 ++++-- test/passing/tests/quotations.mli | 2 +- test/passing/tests/quotations.mli.js-ref | 2 +- test/passing/tests/shortcut_ext_attr.ml | 2 +- test/passing/tests/shortcut_ext_attr.ml.js-ref | 2 +- test/passing/tests/source.ml.js-ref | 2 +- test/passing/tests/source.ml.ref | 2 +- 12 files changed, 24 insertions(+), 15 deletions(-) diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml index bccadc8f9f..0a96f5a392 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1092,7 +1092,14 @@ and fmt_core_type c ?(box = true) ?pro ?(pro_space = true) ?constraint_ctx (Params.parens_if atr_parens c.conf (k $ fmt_attributes c ~pre:Cut atrs) ) ) @@ - let parens = (not atr_parens) && (not tydecl_param) && parenze_typ xtyp in + let parens = + (* The line below conceptually makes sense and removes many syntactically + redundant parens, but the resulting formatting is sometimes less + clear. Ideally, we should develop some heuristic for when the + redundant parens are visually helpful and remove them otherwise *) + (*= (not atr_parens) && *) + (not tydecl_param) && parenze_typ xtyp + in hvbox_if box 0 @@ Params.parens_if ( match typ.ptyp_desc with diff --git a/test/passing/tests/attributes.ml b/test/passing/tests/attributes.ml index 4b87c97cd8..6b30dc43a0 100644 --- a/test/passing/tests/attributes.ml +++ b/test/passing/tests/attributes.ml @@ -149,7 +149,7 @@ let () = () and[@warning "-32"] f = () -external x : a -> b -> (a -> b[@test]) = "" +external x : a -> b -> ((a -> b)[@test]) = "" let f = fun [@test] x y -> () @@ -158,7 +158,7 @@ let f y = fun [@test] y -> () let (f [@test]) = fun y -> fun [@test] y -> () module type T = sig - class subst : (ident -> ident[@attr]) -> (ident -> ident) -> object + class subst : ((ident -> ident)[@attr]) -> (ident -> ident) -> object inherit mapper end[@attr] end diff --git a/test/passing/tests/dropped_attribute.ml.js-ref b/test/passing/tests/dropped_attribute.ml.js-ref index cae30ced91..907cc898c6 100644 --- a/test/passing/tests/dropped_attribute.ml.js-ref +++ b/test/passing/tests/dropped_attribute.ml.js-ref @@ -1,7 +1,7 @@ (* Attributes [[@annot2]] and [[@annot4]] used to be dropped by ocamlformat *) module _ : sig - val foo : (module T with type t = 'a[@annot2]) -> unit + val foo : ((module T with type t = 'a)[@annot2]) -> unit end = struct let foo (type a) (module M : T with type t = a[@annot4]) = () end diff --git a/test/passing/tests/dropped_attribute.ml.ref b/test/passing/tests/dropped_attribute.ml.ref index 503ad28bde..78e12a3a46 100644 --- a/test/passing/tests/dropped_attribute.ml.ref +++ b/test/passing/tests/dropped_attribute.ml.ref @@ -2,7 +2,7 @@ ocamlformat *) module _ : sig - val foo : (module T with type t = 'a[@annot2]) -> unit + val foo : ((module T with type t = 'a)[@annot2]) -> unit end = struct let foo (type a) (module M : T with type t = a[@annot4]) = () end diff --git a/test/passing/tests/modes_attrs.ml.js-ref b/test/passing/tests/modes_attrs.ml.js-ref index c5972a2535..7d5f8ad5b7 100644 --- a/test/passing/tests/modes_attrs.ml.js-ref +++ b/test/passing/tests/modes_attrs.ml.js-ref @@ -41,7 +41,7 @@ type t = | A of t1 @@ m1 m2 * (t2[@attr]) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 | A of t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3[@attr]) @ m5 -> t4 @ m6) @@ m7 m8 | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (t4[@attr]) @ m6) @@ m7 m8 - | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6[@attr]) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3 @ m5 -> t4 @ m6)[@attr]) @@ m7 m8 | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 [@attr] type t = @@ -49,7 +49,7 @@ type t = | A : t1 @@ m1 m2 * (t2[@attr]) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t | A : t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3[@attr]) @ m5 -> t4 @ m6) @@ m7 m8 -> t | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (t4[@attr]) @ m6) @@ m7 m8 -> t - | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6[@attr]) @@ m7 m8 -> t + | A : t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3 @ m5 -> t4 @ m6)[@attr]) @@ m7 m8 -> t | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t [@attr] (* value descriptions *) diff --git a/test/passing/tests/modes_attrs.ml.ref b/test/passing/tests/modes_attrs.ml.ref index 651658dc71..8b59896f05 100644 --- a/test/passing/tests/modes_attrs.ml.ref +++ b/test/passing/tests/modes_attrs.ml.ref @@ -59,7 +59,7 @@ type t = | A of t1 @@ m1 m2 * (t2[@attr]) @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 | A of t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3[@attr]) @ m5 -> t4 @ m6) @@ m7 m8 | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (t4[@attr]) @ m6) @@ m7 m8 - | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6[@attr]) @@ m7 m8 + | A of t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3 @ m5 -> t4 @ m6)[@attr]) @@ m7 m8 | A of t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 [@attr] type t = @@ -75,7 +75,9 @@ type t = | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> (t4[@attr]) @ m6) @@ m7 m8 -> t - | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6[@attr]) @@ m7 m8 -> t + | A : + t1 @@ m1 m2 * t2 @@ m3 m4 * ((t3 @ m5 -> t4 @ m6)[@attr]) @@ m7 m8 + -> t | A : t1 @@ m1 m2 * t2 @@ m3 m4 * (t3 @ m5 -> t4 @ m6) @@ m7 m8 -> t [@attr] diff --git a/test/passing/tests/quotations.mli b/test/passing/tests/quotations.mli index d5828ebfc2..b6786f6a0e 100644 --- a/test/passing/tests/quotations.mli +++ b/test/passing/tests/quotations.mli @@ -63,7 +63,7 @@ type t = <[((* pre *) int[@attr])]> type t = <[$(int[@attr])]> -type 'a t = <[$('a list[@attr])]> +type 'a t = <[$(('a list)[@attr])]> type 'a t = <[($'a option[@attr]) -> ($'a option[@attr]) -> ($'a list[@attr])]> diff --git a/test/passing/tests/quotations.mli.js-ref b/test/passing/tests/quotations.mli.js-ref index 8a0231307a..c09427793c 100644 --- a/test/passing/tests/quotations.mli.js-ref +++ b/test/passing/tests/quotations.mli.js-ref @@ -48,7 +48,7 @@ type t = <[((* pre *) int[@attr])]> (* Attributes *) type t = <[$(int[@attr])]> -type 'a t = <[$('a list[@attr])]> +type 'a t = <[$(('a list)[@attr])]> type 'a t = <[($'a option[@attr]) -> ($'a option[@attr]) -> ($'a list[@attr])]> (* Comments *) diff --git a/test/passing/tests/shortcut_ext_attr.ml b/test/passing/tests/shortcut_ext_attr.ml index 4570fc31ee..b7bdebcfb2 100644 --- a/test/passing/tests/shortcut_ext_attr.ml +++ b/test/passing/tests/shortcut_ext_attr.ml @@ -72,7 +72,7 @@ class type t = object end[@foo] (* Type expressions *) -type t = [%foo: (module M[@foo])] +type t = [%foo: ((module M)[@foo])] (* Module expressions *) module M = (functor [@foo] (M : S) -> (val x) [@foo] (struct end [@foo])) diff --git a/test/passing/tests/shortcut_ext_attr.ml.js-ref b/test/passing/tests/shortcut_ext_attr.ml.js-ref index 7abe4d94c6..b63aadfaf1 100644 --- a/test/passing/tests/shortcut_ext_attr.ml.js-ref +++ b/test/passing/tests/shortcut_ext_attr.ml.js-ref @@ -66,7 +66,7 @@ class type t = object end[@foo] (* Type expressions *) -type t = [%foo: (module M[@foo])] +type t = [%foo: ((module M)[@foo])] (* Module expressions *) module M = (functor [@foo] (M : S) -> (val x) [@foo] (struct end [@foo])) diff --git a/test/passing/tests/source.ml.js-ref b/test/passing/tests/source.ml.js-ref index aa0b424cd1..7de837de07 100644 --- a/test/passing/tests/source.ml.js-ref +++ b/test/passing/tests/source.ml.js-ref @@ -152,7 +152,7 @@ class type t = object end[@foo] (* Type expressions *) -type t = [%foo: (module M[@foo])] +type t = [%foo: ((module M)[@foo])] (* Module expressions *) module M = (functor [@foo] (M : S) -> (val x) [@foo] (struct end [@foo])) diff --git a/test/passing/tests/source.ml.ref b/test/passing/tests/source.ml.ref index 4f00234791..4d3417f524 100644 --- a/test/passing/tests/source.ml.ref +++ b/test/passing/tests/source.ml.ref @@ -176,7 +176,7 @@ class type t = object end[@foo] (* Type expressions *) -type t = [%foo: (module M[@foo])] +type t = [%foo: ((module M)[@foo])] (* Module expressions *) module M = (functor [@foo] (M : S) -> (val x) [@foo] (struct end [@foo]))