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 d206a2aa14..0a96f5a392 100644 --- a/lib/Fmt_ast.ml +++ b/lib/Fmt_ast.ml @@ -1084,16 +1084,22 @@ 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 = + (* 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 @@ -1293,15 +1299,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 needs_parens = - match t.ptyp_desc with - | Ptyp_var _ | Ptyp_constr (_, []) -> false - | _ -> true - in - fmt "$" - $ Params.parens_if needs_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/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 ec97e85adf..b6786f6a0e 100644 --- a/test/passing/tests/quotations.mli +++ b/test/passing/tests/quotations.mli @@ -5,3 +5,81 @@ 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) + +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 **) + +(* Attributes *) + +type t = <[(int[@attr])]> + +type 'a t = <[('a list[@attr])]> + +(* Comments *) + +type t = <[int (* post *)]> + +type t = <[(* pre *) int]> + +type t = <[(* pre *) int (* post *)]> + +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 = $(* pre *) int (* post *) + +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..c09427793c 100644 --- a/test/passing/tests/quotations.mli.js-ref +++ b/test/passing/tests/quotations.mli.js-ref @@ -4,3 +4,61 @@ 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) +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 **) + +(* Attributes *) + +type t = <[(int[@attr])]> +type 'a t = <[('a list[@attr])]> + +(* Comments *) + +type t = <[int (* post *)]> +type t = <[(* pre *) int]> +type t = <[(* pre *) int (* post *)]> +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 = $(* pre *) int (* post *) +type t = $(int (* in *) list) + +(* Attributes & comments *) + +type t = $(int[@attr] (* post *)) +type t = $((* pre *) int[@attr]) 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 */ ;