Fix override parsing and preserve comments in JSX applications

CHANGES.md

@@ -15,6 +15,14 @@ profile. This started with version 0.26.0.
 
 ### Fixed
 
+- Restore parsing and formatting of unparenthesized object-override field
+  expressions, including comparisons, boolean operators, conditionals, and
+  local bindings, while preserving JSX elements closed directly before `}`.
+
+- Preserve comments on the unit argument of hand-written `[@JSX]`
+  applications by retaining application syntax, including when nested in JSX
+  children, spreads, or props.
+
 - Fix `Version.current` being `"unknown"` in programs other than
   `ocamlformat-mlx` that link `ocamlformat-mlx-lib`, which made them reject a
   matching `version=` in `.ocamlformat`. It now reports the version of the
@@ -1969,4 +1977,3 @@ profile. This started with version 0.26.0.
 ## 0.1 (2017-10-19)
 
 - Initial release.
-

lib/Fmt_ast.ml

@@ -59,13 +59,23 @@ let cmt_checker {cmts; _} =
 
 let break_between c = Ast.break_between c.source (cmt_checker c)
 
-let is_jsx_element e =
-  match e.pexp_attributes with
-  | [{attr_name={txt="JSX";_}; attr_payload=PStr []; _}] -> true
-  | _ -> false
-
 module Jsx = Ocamlformat_parser_extended.Jsx_helper
 
+let classify_jsx_element c ~attrs e0 args =
+  Jsx.classify_element ~attrs e0 args
+  |> Option.filter ~f:(fun {Jsx.unit_loc; _} ->
+         (* JSX omits the unit argument, so keep applications that comment it. *)
+         not
+           (Cmts.has_before c.cmts unit_loc
+           || Cmts.has_within c.cmts unit_loc
+           || Cmts.has_after c.cmts unit_loc))
+
+let is_jsx_element c e =
+  match e.pexp_desc with
+  | Pexp_apply (e0, args) ->
+      Option.is_some (classify_jsx_element c ~attrs:e.pexp_attributes e0 args)
+  | _ -> false
+
 type block =
   { opn: Fmt.t option
   ; pro: Fmt.t option
@@ -2303,8 +2313,8 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
              $ fmt_expression c ~box (sub_exp ~ctx e)
              $ fmt_atrs ) )
   | Pexp_apply (e0, e1N1) -> (
-      match Jsx.classify_element ~attrs:pexp_attributes e0 e1N1 with
-      | Some {Jsx.tag; tag_loc; props; children_loc; children; loc= jsx_loc} ->
+      match classify_jsx_element c ~attrs:pexp_attributes e0 e1N1 with
+      | Some {Jsx.tag; tag_loc; props; children_loc; children; loc= jsx_loc; _} ->
         let start_tag = str ("<" ^ tag) $ Cmts.fmt_after c tag_loc in
         let end_tag = str ("</" ^ tag ^ ">") in
         let props =
@@ -2317,7 +2327,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
               | Pexp_ident {txt=Lident id; loc=_} when String.equal id label.txt ->
                 flabel
               | _ ->
-                if is_jsx_element e then
+                if is_jsx_element c e then
                   flabel $ str "=(" $ fmt_expression c (sub_exp ~ctx e) $ str ")"
                 else
                   flabel $ str "=" $ fmt_expression c (sub_exp ~ctx e)
@@ -2344,7 +2354,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
             hvbox 0 (
               list children (break 1 0)
               (fun e ->
-                if is_jsx_element e then
+                if is_jsx_element c e then
                   fmt_expression c ~parens:false (sub_exp ~ctx e)
                 else
                   fmt_expression c (sub_exp ~ctx e))
@@ -2360,7 +2370,7 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
             else noop
           in
           let child_expr =
-            if is_jsx_element e then
+            if is_jsx_element c e then
               fmt_expression c ~parens:false (sub_exp ~ctx e)
             else
               fmt_expression c (sub_exp ~ctx e)
@@ -3010,12 +3020,6 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
                  pcstr_fields
              $ fmt_atrs ) )
   | Pexp_override l -> (
-      (* a bare [>] comparison in an override field is ambiguous with the closer, so force parens *)
-      let is_bare_greater_comparison f =
-        match f.pexp_desc with
-        | Pexp_infix ({txt= ">"; _}, _, _) -> true
-        | _ -> false
-      in
       let fmt_field ({txt; loc}, f) =
         let eol = break 1 3 in
         let txt = Longident.lident txt in
@@ -3025,11 +3029,9 @@ and fmt_expression c ?(box = true) ?(pro = noop) ?eol ?parens
                && List.is_empty f.pexp_attributes ->
             Cmts.fmt c ~eol loc @@ fmt_longident c txt'
         | _ ->
-            let force_parens = is_bare_greater_comparison f in
             Cmts.fmt c ~eol loc @@ fmt_longident c txt
             $ str " = "
-            $ Params.parens_if force_parens c.conf
-                (fmt_expression c (sub_exp ~ctx f))
+            $ fmt_expression c (sub_exp ~ctx f)
       in
       match l with
       | [] ->

test/mlx/mlx.t

@@ -319,19 +319,19 @@ Object override still parses and formats stably, both spaced and unspaced:
       method m = {<x = 2>}
     end
 
-An override field ending in an unparenthesized ">" comparison stays parenthesized so it re-parses:
+Override comparisons can be printed without unnecessary parentheses:
   $ echo 'let _ = object val x = true method m = {< x = (1 > 2) >} end' | fmt
   let _ =
     object
       val x = true
-      method m = {<x = (1 > 2)>}
+      method m = {<x = 1 > 2>}
     end
   $ echo 'let _ = object val x = true val y = 1 method m = {< x = (1 > 2); y = 5 >} end' | fmt
   let _ =
     object
       val x = true
       val y = 1
-      method m = {<x = (1 > 2); y = 5>}
+      method m = {<x = 1 > 2; y = 5>}
     end
 
 ">|" still lexes as an ordinary operator everywhere else:

test/mlx/regressions.t

@@ -0,0 +1,69 @@
+Setup:
+  $ alias fmt="ocamlformat-mlx - --impl --enable-outside-detected-project"
+
+Ordinary override expressions parse and format without special parentheses:
+
+  $ echo 'let _ = {<x = true && false>}' | fmt
+  let _ = {<x = true && false>}
+  $ echo 'let _ = {<x = (true && false)>}' | fmt | fmt
+  let _ = {<x = true && false>}
+  $ echo 'let _ = {<x = if true then 1 else 2>}' | fmt
+  let _ = {<x = if true then 1 else 2>}
+  $ echo 'let _ = {<x = (if true then 1 else 2)>}' | fmt | fmt
+  let _ = {<x = if true then 1 else 2>}
+  $ echo 'let _ = {<x = let a = 1 in a > 2>}' | fmt
+  let _ =
+    {<x = let a = 1 in
+          a > 2>}
+  $ echo 'let _ = {<x = 1 > 2 && true; y = false || 3 > 4>}' | fmt | fmt
+  let _ = {<x = 1 > 2 && true; y = false || 3 > 4>}
+  $ echo 'let _ = {<x = fun a -> a > 2>}' | fmt
+  let _ = {<x = fun a -> a > 2>}
+  $ echo 'let _ = {<x = match a with Some x -> x > 2 | None -> false>}' | fmt
+  let _ = {<x = match a with Some x -> x > 2 | None -> false>}
+  $ echo 'let _ = {<x = try f () > 2 with _ -> false>}' | fmt
+  let _ = {<x = try f () > 2 with _ -> false>}
+
+Empty/local overrides and whitespace before the brace remain supported:
+
+  $ echo 'let _ = {<>} let _ = M.{<x = 1 > 2>}' | fmt
+  let _ = {<>}
+  let _ = M.({<x = 1 > 2>})
+  $ printf 'let _ = {<x = true && false>\n}\n' | fmt
+  let _ = {<x = true && false>}
+  $ echo 'let _ = {x = {<y = true && false>}}' | fmt
+  let _ = { x = {<y = true && false>} }
+
+JSX and object types still close directly before braces:
+
+  $ echo 'let _ = {x = <div>...xs</div>}' | fmt | fmt
+  let _ = { x = <div>...xs</div> }
+  $ echo 'type t = {x : <m : int>}' | fmt | fmt
+  type t = { x : < m : int > }
+
+Comments on the unit argument must not disappear when sugaring an application into JSX:
+
+  $ echo 'let _ = (App.createElement ~children:xs (* keep *) ()) [@JSX]' | fmt | fmt
+  let _ = App.createElement ~children:xs (* keep *) () [@JSX]
+  $ echo 'let _ = (App.createElement ~children:xs ((* keep *))) [@JSX]' | fmt | fmt
+  let _ = App.createElement ~children:xs ( (* keep *) ) [@JSX]
+  $ echo 'let _ = (App.createElement ~children:xs () (* keep *)) [@JSX]' | fmt | fmt
+  let _ = (* keep *) <App>...xs</App>
+  $ echo 'let _ = (App.createElement ((* keep *)) ~children:xs) [@JSX]' | fmt | fmt
+  let _ = App.createElement ( (* keep *) ) ~children:xs [@JSX]
+  $ echo 'let _ = (App.createElement ~children:[] (* keep *) ()) [@JSX]' | fmt | fmt
+  let _ = App.createElement ~children:[] (* keep *) () [@JSX]
+
+Uncommented applications still normalize to a children spread:
+
+  $ echo 'let _ = (App.createElement ~children:xs ()) [@JSX]' | fmt | fmt
+  let _ = <App>...xs</App>
+
+Applications retained for their comments need parentheses inside JSX as well:
+
+  $ echo 'let _ = <div>((App.createElement ~children:xs (* keep *) ()) [@JSX])</div>' | fmt | fmt
+  let _ = <div>(App.createElement ~children:xs (* keep *) () [@JSX])</div>
+  $ echo 'let _ = <div>...((App.createElement ~children:xs (* keep *) ()) [@JSX])</div>' | fmt | fmt
+  let _ = <div>...(App.createElement ~children:xs (* keep *) () [@JSX])</div>
+  $ echo 'let _ = <div prop=((App.createElement ~children:xs (* keep *) ()) [@JSX]) />' | fmt | fmt
+  let _ = <div prop=(App.createElement ~children:xs (* keep *) () [@JSX]) />

vendor/parser-extended/dune

@@ -31,8 +31,6 @@
   EOL
   --unused-token
   GREATERRBRACKET
-  --unused-token
-  GREATERRBRACE
   --fixed-exception
   --table
   --strategy

vendor/parser-extended/jsx_helper.ml

@@ -88,6 +88,7 @@ type jsx_children = Children of expression list | Spread of expression
 type element = {
   tag : string;
   tag_loc : Location.t;
+  unit_loc : Location.t;
   props : (arg_label * expression) list;
   children_loc : Location.t;
   children : jsx_children;
@@ -133,8 +134,9 @@ let classify_element ~attrs e0 args =
         | ( Nolabel,
             { pexp_desc = Pexp_construct ({ txt = Lident "()"; _ }, None);
               pexp_attributes = [];
+              pexp_loc;
               _ } ) ->
-          (() :: units, children, props)
+          (pexp_loc :: units, children, props)
         | ( Labelled { txt = "children"; _ },
             { pexp_desc = Pexp_list es; pexp_attributes = []; pexp_loc; _ } )
           ->
@@ -159,8 +161,8 @@ let classify_element ~attrs e0 args =
   match (attrs, tag, units, children) with
   | ( [ { attr_name = { txt = "JSX"; _ }; attr_payload = PStr []; attr_loc } ],
       Some (tag, tag_loc),
-      [ () ],
+      [ unit_loc ],
       [ (children_loc, children) ] )
     when List.for_all is_prop props ->
-    Some { tag; tag_loc; props; children_loc; children; loc = attr_loc }
+    Some { tag; tag_loc; unit_loc; props; children_loc; children; loc = attr_loc }
   | _ -> None

vendor/parser-extended/lexer.mll

@@ -748,13 +748,13 @@ rule token = parse
   | ">"  { GREATER }
   | "/>" { SLASHGREATER }
   | "}"  { RBRACE }
-  | ">}"
-      { (* the dialect gives ">" back so the closing "}" lexes separately as RBRACE *)
+  | ">" (blank | newline)* "}"
+      { (* Keep the closer distinct from infix ">", but leave "}" for the enclosing record, object override, or indexing expression. *)
         lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_start_pos + 1;
         let lex_start_p = lexbuf.lex_start_p in
         lexbuf.lex_curr_p <-
           { lex_start_p with pos_cnum = lex_start_p.pos_cnum + 1 };
-        GREATER
+        GREATER_BEFORE_RBRACE
       }
   | ">|]"
       { (* the dialect gives ">" back so the closing "|]" lexes separately as BARRBRACKET *)

vendor/parser-extended/parser.mly

@@ -797,7 +797,7 @@ let mk_directive ~loc name arg =
 %token FUNCTOR                "functor"
 %token GREATER                ">"
 %token SLASHGREATER           "/>"
-%token GREATERRBRACE          ">}"
+%token GREATER_BEFORE_RBRACE   "> (before })"
 %token GREATERRBRACKET        ">]"
 %token IF                     "if"
 %token IN                     "in"
@@ -2656,17 +2656,17 @@ simple_expr:
       { Pexp_prefix($1, $2) }
   | op(BANG {"!"}) simple_expr
       { Pexp_prefix($1, $2) }
-  | LBRACELESS object_expr_content GREATER RBRACE
+  | LBRACELESS object_expr_content override_close
       { Pexp_override $2 }
   | LBRACELESS object_expr_content error
       { unclosed "{<" $loc($1) ">}" $loc($3) }
-  | LBRACELESS GREATER RBRACE
+  | LBRACELESS override_close
       { Pexp_override [] }
   | simple_expr DOT mkrhs(label_longident)
       { Pexp_field($1, $3) }
   | od=open_dot_declaration DOT LPAREN seq_expr RPAREN
       { Pexp_open(od, $4) }
-  | od=open_dot_declaration DOT LBRACELESS object_expr_content GREATER RBRACE
+  | od=open_dot_declaration DOT LBRACELESS object_expr_content override_close
       { (* TODO: review the location of Pexp_override *)
         Pexp_open(od, mkexp ~loc:$sloc (Pexp_override $4)) }
   | mod_longident DOT LBRACELESS object_expr_content error
@@ -2730,19 +2730,27 @@ simple_expr:
     LPAREN MODULE ext_attributes module_expr COLON error
       { unclosed "(" $loc($3) ")" $loc($8) }
 ;
+%inline override_close:
+  GREATER_BEFORE_RBRACE RBRACE { () }
+;
+(* GREATER_BEFORE_RBRACE consumes only ">"; the brace belongs to the enclosing production. *)
+%inline closing_greater:
+  | GREATER { () }
+  | GREATER_BEFORE_RBRACE { () }
+;
 jsx_element:
     tag=jsx_longident(JSX_UIDENT, JSX_LIDENT) props=llist(jsx_prop) SLASHGREATER {
       let children = Exp.mk ~loc:Location.none (Pexp_list []) in
       Jsx_helper.make_jsx_element () ~raise ~loc:$loc(tag) ~tag ~end_tag:None ~props ~children }
   | tag=jsx_longident(JSX_UIDENT, JSX_LIDENT) props=llist(jsx_prop)
-    GREATER children=llist(simple_expr) end_tag=jsx_longident(JSX_UIDENT_E, JSX_LIDENT_E) end_tag_=GREATER {
+    GREATER children=llist(simple_expr) end_tag=jsx_longident(JSX_UIDENT_E, JSX_LIDENT_E) end_tag_=closing_greater {
       let children = mkexp ~loc:$loc(children) (Pexp_list children) in
       let _ = end_tag_ in
       Jsx_helper.make_jsx_element ()
         ~raise ~loc:$loc(tag) ~tag ~end_tag:(Some (end_tag, $loc(end_tag_))) ~props ~children
     }
   | tag=jsx_longident(JSX_UIDENT, JSX_LIDENT) props=llist(jsx_prop)
-    GREATER DOTDOTDOT children=simple_expr end_tag=jsx_longident(JSX_UIDENT_E, JSX_LIDENT_E) end_tag_=GREATER {
+    GREATER DOTDOTDOT children=simple_expr end_tag=jsx_longident(JSX_UIDENT_E, JSX_LIDENT_E) end_tag_=closing_greater {
       let _ = end_tag_ in
       Jsx_helper.make_jsx_element ()
         ~raise ~loc:$loc(tag) ~tag ~end_tag:(Some (end_tag, $loc(end_tag_))) ~props ~children
@@ -3952,12 +3960,12 @@ delimited_type_supporting_local_open:
 
 object_type:
   | mktyp(
-      LESS meth_list = meth_list GREATER
+      LESS meth_list = meth_list closing_greater
         { let (f, c) = meth_list in Ptyp_object (f, c) }
-    | LESS GREATER
+    | LESS closing_greater
         { Ptyp_object ([], OClosed) }
     (* [mlx]: a type context can never contain JSX, so a lexer-fused "<" + first-label token can be reinterpreted as the opening "<" of an object type *)
-    | meth_list = meth_list_jsx GREATER
+    | meth_list = meth_list_jsx closing_greater
         { let (f, c) = meth_list in Ptyp_object (f, c) }
   )
   { $1 }

vendor/parser-standard/dune

@@ -31,8 +31,6 @@
   EOL
   --unused-token
   GREATERRBRACKET
-  --unused-token
-  GREATERRBRACE
   --fixed-exception
   --table
   --strategy

vendor/parser-standard/lexer.mll

@@ -739,13 +739,13 @@ rule token = parse
   | ">"  { GREATER }
   | "/>" { SLASHGREATER }
   | "}"  { RBRACE }
-  | ">}"
-      { (* the dialect gives ">" back so the closing "}" lexes separately as RBRACE *)
+  | ">" (blank | newline)* "}"
+      { (* Keep the closer distinct from infix ">", but leave "}" for the enclosing record, object override, or indexing expression. *)
         lexbuf.Lexing.lex_curr_pos <- lexbuf.Lexing.lex_start_pos + 1;
         let lex_start_p = lexbuf.lex_start_p in
         lexbuf.lex_curr_p <-
           { lex_start_p with pos_cnum = lex_start_p.pos_cnum + 1 };
-        GREATER
+        GREATER_BEFORE_RBRACE
       }
   | ">|]"
       { (* the dialect gives ">" back so the closing "|]" lexes separately as BARRBRACKET *)