Fix JSX elements closed directly before |] and }

CHANGES.md

@@ -4,6 +4,26 @@ Items marked with an asterisk (\*) are changes that are likely to format
 existing code differently from the previous release when using the default
 profile. This started with version 0.26.0.
 
+## unreleased
+
+### Fixed
+
+- Fix JSX elements closed directly before `|]` in array literals (e.g.
+  `[|<div>aa</div>|]`) and before `}` in record/braced expressions (e.g.
+  `{x = <div>a</div>}`), which previously failed to parse because the
+  lexer read `>|]` as the `>|` operator followed by `]`, and `>}` as the
+  single object-override closer token, instead of giving the `>` back to
+  close the JSX tag.
+
+- Fix object types whose opening `<` is not followed by a space before
+  the first method name (e.g. `<m : int>`), which previously failed to
+  parse because the lexer read `<m` as the start of a JSX element rather
+  than as `<` followed by the object type's first method name. Since a
+  type context can never contain JSX, this fused token is now
+  unambiguously reinterpreted as the object type's opening `<` plus its
+  first label. The already-working spaced form `< m : int >` is
+  unaffected.
+
 ## 0.29.0
 
 ### Highlight

lib/Fmt_ast.ml

@@ -2990,6 +2990,12 @@ 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
@@ -2999,9 +3005,11 @@ 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 " = "
-            $ fmt_expression c (sub_exp ~ctx f)
+            $ Params.parens_if force_parens c.conf
+                (fmt_expression c (sub_exp ~ctx f))
       in
       match l with
       | [] ->

test/mlx/mlx.t

@@ -290,6 +290,60 @@ JSX with infix operators:
   $ echo 'let _ = <Big>(<Lola />)</Big>' | fmt
   let _ = <Big><Lola /></Big>
 
+JSX element closed directly before "|]" in an array literal, or before "}" in a record/braced expression:
+  $ echo 'let _ = [|<div>aa</div>|]' | fmt
+  let _ = [| <div>aa</div> |]
+  $ echo 'let _ = [|<div>aa</div>; <div>bb</div>|]' | fmt
+  let _ = [| <div>aa</div>; <div>bb</div> |]
+  $ echo 'let _ = [<div>aa</div>]' | fmt
+  let _ = [ <div>aa</div> ]
+
+  $ echo 'let _ = {x = <div>a</div>}' | fmt
+  let _ = { x = <div>a</div> }
+  $ echo 'let _ = {x = <div>a</div>; y = 1}' | fmt
+  let _ = { x = <div>a</div>; y = 1 }
+  $ echo 'let r = {r with x = <div>a</div>}' | fmt
+  let r = { r with x = <div>a</div> }
+
+Object override still parses and formats stably, both spaced and unspaced:
+  $ echo 'let _ = object val x = 1 method m = {< x = 2 >} end' | fmt
+  let _ =
+    object
+      val x = 1
+      method m = {<x = 2>}
+    end
+  $ echo 'let _ = object val x = 1 method m = {<x = 2>} end' | fmt
+  let _ =
+    object
+      val x = 1
+      method m = {<x = 2>}
+    end
+
+An override field ending in an unparenthesized ">" comparison stays parenthesized so it re-parses:
+  $ echo 'let _ = object val x = true method m = {< x = (1 > 2) >} end' | fmt
+  let _ =
+    object
+      val x = true
+      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>}
+    end
+
+">|" still lexes as an ordinary operator everywhere else:
+  $ echo 'let (>|) a b = a
+  > let _ = 1>|2' | fmt
+  let ( >| ) a b = a
+  let _ = 1 >| 2
+  $ echo 'let (>|) a b = a
+  > let _ = [|1>|2|]' | fmt
+  let ( >| ) a b = a
+  let _ = [| 1 >| 2 |]
+
 Raw identifiers in JSX:
   $ echo 'let _ = <\#lazy />' | fmt
   let _ = <\#lazy />
@@ -329,3 +383,25 @@ regular applications:
   let _ = App.createElement ~children:[] ~children:[] () [@JSX]
   $ echo 'let _ = (((get_component ()) ~children:[] ()) [@JSX])' | fmt
   let _ = (get_component ()) ~children:[] () [@JSX]
+
+Object types whose opening "<" is not followed by a space:
+  $ echo 'let f (x : <m : int>) = x#m' | fmt
+  let f (x : < m : int >) = x#m
+  $ echo 'let f (x : <m : int; n : float>) = x#m' | fmt
+  let f (x : < m : int ; n : float >) = x#m
+  $ echo "let f (x : <m : 'a. 'a -> 'a>) = x#m" | fmt
+  let f (x : < m : 'a. 'a -> 'a >) = x#m
+  $ echo 'let f : <m : int> -> unit = fun _ -> ()' | fmt
+  let f : < m : int > -> unit = fun _ -> ()
+
+Regression guards: the spaced form, "< .. >", and the JSX expression form must keep working:
+  $ echo 'let f (x : < m : int >) = x#m' | fmt
+  let f (x : < m : int >) = x#m
+  $ echo 'let f (x : < .. >) = x' | fmt
+  let f (x : < .. >) = x
+  $ echo 'let f = <m />' | fmt
+  let f = <m />
+
+Idempotency check:
+  $ echo 'let f (x : <m : int>) = x#m' | fmt | fmt
+  let f (x : < m : int >) = x#m

vendor/parser-extended/dune

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

vendor/parser-extended/lexer.mll

@@ -747,7 +747,22 @@ rule token = parse
   | ">"  { GREATER }
   | "/>" { SLASHGREATER }
   | "}"  { RBRACE }
-  | ">}" { GREATERRBRACE }
+  | ">}"
+      { (* the dialect gives ">" back so the closing "}" lexes separately as RBRACE *)
+        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
+      }
+  | ">|]"
+      { (* the dialect gives ">" back so the closing "|]" lexes separately as BARRBRACKET *)
+        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
+      }
   | "[@" { LBRACKETAT }
   | "[@@"  { LBRACKETATAT }
   | "[@@@" { LBRACKETATATAT }

vendor/parser-extended/parser.mly

@@ -2655,17 +2655,17 @@ simple_expr:
       { Pexp_prefix($1, $2) }
   | op(BANG {"!"}) simple_expr
       { Pexp_prefix($1, $2) }
-  | LBRACELESS object_expr_content GREATERRBRACE
+  | LBRACELESS object_expr_content GREATER RBRACE
       { Pexp_override $2 }
   | LBRACELESS object_expr_content error
       { unclosed "{<" $loc($1) ">}" $loc($3) }
-  | LBRACELESS GREATERRBRACE
+  | LBRACELESS GREATER RBRACE
       { 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 GREATERRBRACE
+  | od=open_dot_declaration DOT LBRACELESS object_expr_content GREATER RBRACE
       { (* TODO: review the location of Pexp_override *)
         Pexp_open(od, mkexp ~loc:$sloc (Pexp_override $4)) }
   | mod_longident DOT LBRACELESS object_expr_content error
@@ -3949,6 +3949,9 @@ object_type:
         { let (f, c) = meth_list in Ptyp_object (f, c) }
     | LESS 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
+        { let (f, c) = meth_list in Ptyp_object (f, c) }
   )
   { $1 }
 ;
@@ -4051,27 +4054,36 @@ opt_ampersand:
 ;
 (* A method list (in an object type). *)
 meth_list:
-    head = field_semi         tail = meth_list
+    head = field_semi(mkrhs(label)) tail = meth_list
   | head = inherit_field SEMI tail = meth_list
       { let (f, c) = tail in (head :: f, c) }
-  | head = field_semi
+  | head = field_semi(mkrhs(label))
   | head = inherit_field SEMI
       { [head], OClosed }
-  | head = field
+  | head = field(mkrhs(label))
   | head = inherit_field
       { [head], OClosed }
   | DOTDOT
       { [], OOpen (make_loc $sloc) }
 ;
-%inline field:
-  mkrhs(label) COLON poly_type_no_attr attributes
+(* [mlx]: same as [meth_list], but starting from a fused "<" + first-label JSX_LIDENT token instead of a separately-lexed [label] *)
+meth_list_jsx:
+    head = field_semi(jsx_first_label) tail = meth_list
+      { let (f, c) = tail in (head :: f, c) }
+  | head = field_semi(jsx_first_label)
+      { [head], OClosed }
+  | head = field(jsx_first_label)
+      { [head], OClosed }
+;
+%inline field(label):
+  label COLON poly_type_no_attr attributes
     { let info = symbol_info $endpos in
       let attrs = add_info_attrs info $4 in
       Of.tag ~loc:(make_loc $sloc) ~attrs $1 $3 }
 ;
 
-%inline field_semi:
-  mkrhs(label) COLON poly_type_no_attr attributes SEMI attributes
+%inline field_semi(label):
+  label COLON poly_type_no_attr attributes SEMI attributes
     { let info =
         match rhs_info $endpos($4) with
         | Some _ as info_before_semi -> info_before_semi
@@ -4080,6 +4092,10 @@ meth_list:
       let attrs = add_info_attrs info ($4 @ $6) in
       Of.tag ~loc:(make_loc $sloc) ~attrs $1 $3 }
 ;
+(* [mlx]: the fused "<" + first-method-name JSX_LIDENT token, reinterpreted as an object-type label *)
+%inline jsx_first_label:
+  name = JSX_LIDENT { mkrhs name $sloc }
+;
 
 %inline inherit_field:
   ty = atomic_type

vendor/parser-standard/dune

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

vendor/parser-standard/lexer.mll

@@ -738,7 +738,22 @@ rule token = parse
   | ">"  { GREATER }
   | "/>" { SLASHGREATER }
   | "}"  { RBRACE }
-  | ">}" { GREATERRBRACE }
+  | ">}"
+      { (* the dialect gives ">" back so the closing "}" lexes separately as RBRACE *)
+        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
+      }
+  | ">|]"
+      { (* the dialect gives ">" back so the closing "|]" lexes separately as BARRBRACKET *)
+        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
+      }
   | "[@" { LBRACKETAT }
   | "[@@"  { LBRACKETATAT }
   | "[@@@" { LBRACKETATATAT }

vendor/parser-standard/parser.mly

@@ -2624,17 +2624,17 @@ simple_expr:
       { Pexp_apply($1, [Nolabel,$2]) }
   | op(BANG {"!"}) simple_expr
       { Pexp_apply($1, [Nolabel,$2]) }
-  | LBRACELESS object_expr_content GREATERRBRACE
+  | LBRACELESS object_expr_content GREATER RBRACE
       { Pexp_override $2 }
   | LBRACELESS object_expr_content error
       { unclosed "{<" $loc($1) ">}" $loc($3) }
-  | LBRACELESS GREATERRBRACE
+  | LBRACELESS GREATER RBRACE
       { Pexp_override [] }
   | simple_expr DOT mkrhs(label_longident)
       { Pexp_field($1, $3) }
   | od=open_dot_declaration DOT LPAREN seq_expr RPAREN
       { Pexp_struct_item(Str.open_ od, $4) }
-  | od=open_dot_declaration DOT LBRACELESS object_expr_content GREATERRBRACE
+  | od=open_dot_declaration DOT LBRACELESS object_expr_content GREATER RBRACE
       { (* TODO: review the location of Pexp_override *)
         Pexp_struct_item(Str.open_ od, mkexp ~loc:$sloc (Pexp_override $4)) }
   | mod_longident DOT LBRACELESS object_expr_content error
@@ -3904,6 +3904,9 @@ object_type:
         { let (f, c) = meth_list in Ptyp_object (f, c) }
     | LESS GREATER
         { Ptyp_object ([], Closed) }
+    (* [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
+        { let (f, c) = meth_list in Ptyp_object (f, c) }
   )
   { $1 }
 ;
@@ -4006,27 +4009,36 @@ opt_ampersand:
 ;
 (* A method list (in an object type). *)
 meth_list:
-    head = field_semi         tail = meth_list
+    head = field_semi(mkrhs(label)) tail = meth_list
   | head = inherit_field SEMI tail = meth_list
       { let (f, c) = tail in (head :: f, c) }
-  | head = field_semi
+  | head = field_semi(mkrhs(label))
   | head = inherit_field SEMI
       { [head], Closed }
-  | head = field
+  | head = field(mkrhs(label))
   | head = inherit_field
       { [head], Closed }
   | DOTDOT
       { [], Open }
 ;
-%inline field:
-  mkrhs(label) COLON poly_type_no_attr attributes
+(* [mlx]: same as [meth_list], but starting from a fused "<" + first-label JSX_LIDENT token instead of a separately-lexed [label] *)
+meth_list_jsx:
+    head = field_semi(jsx_first_label) tail = meth_list
+      { let (f, c) = tail in (head :: f, c) }
+  | head = field_semi(jsx_first_label)
+      { [head], Closed }
+  | head = field(jsx_first_label)
+      { [head], Closed }
+;
+%inline field(label):
+  label COLON poly_type_no_attr attributes
     { let info = symbol_info $endpos in
       let attrs = add_info_attrs info $4 in
       Of.tag ~loc:(make_loc $sloc) ~attrs $1 $3 }
 ;
 
-%inline field_semi:
-  mkrhs(label) COLON poly_type_no_attr attributes SEMI attributes
+%inline field_semi(label):
+  label COLON poly_type_no_attr attributes SEMI attributes
     { let info =
         match rhs_info $endpos($4) with
         | Some _ as info_before_semi -> info_before_semi
@@ -4035,6 +4047,10 @@ meth_list:
       let attrs = add_info_attrs info ($4 @ $6) in
       Of.tag ~loc:(make_loc $sloc) ~attrs $1 $3 }
 ;
+(* [mlx]: the fused "<" + first-method-name JSX_LIDENT token, reinterpreted as an object-type label *)
+%inline jsx_first_label:
+  name = JSX_LIDENT { mkrhs name $sloc }
+;
 
 %inline inherit_field:
   ty = atomic_type