Quote/splice formatting fixes for attributes & comments

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

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

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

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

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])

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])

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 */
 ;