diff --git a/CHANGES.md b/CHANGES.md
index 0f2a70ab84..2cf1cdb585 100644
--- a/CHANGES.md
+++ b/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.
+ `[|
aa
|]`) and before `}` in record/braced expressions (e.g.
+ `{x = a
}`), 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. ``), which previously failed to
+ parse because the lexer read `` is
+ unaffected.
+
## 0.29.0
### Highlight
diff --git a/lib/Fmt_ast.ml b/lib/Fmt_ast.ml
index 0ffc06143f..9392ab235f 100644
--- a/lib/Fmt_ast.ml
+++ b/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
| [] ->
diff --git a/test/mlx/mlx.t b/test/mlx/mlx.t
index 864da17933..d793baa3d9 100644
--- a/test/mlx/mlx.t
+++ b/test/mlx/mlx.t
@@ -290,6 +290,60 @@ JSX with infix operators:
$ echo 'let _ = ()' | fmt
let _ =
+JSX element closed directly before "|]" in an array literal, or before "}" in a record/braced expression:
+ $ echo 'let _ = [|aa
|]' | fmt
+ let _ = [| aa
|]
+ $ echo 'let _ = [|aa
; bb
|]' | fmt
+ let _ = [| aa
; bb
|]
+ $ echo 'let _ = [aa
]' | fmt
+ let _ = [ aa
]
+
+ $ echo 'let _ = {x = a
}' | fmt
+ let _ = { x = a
}
+ $ echo 'let _ = {x = a
; y = 1}' | fmt
+ let _ = { x = a
; y = 1 }
+ $ echo 'let r = {r with x = a
}' | fmt
+ let r = { r with x = a
}
+
+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 = {}
+ end
+ $ echo 'let _ = object val x = 1 method m = {} end' | fmt
+ let _ =
+ object
+ val x = 1
+ method m = {}
+ 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 = { 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 = { 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 : ) = x#m' | fmt
+ let f (x : < m : int >) = x#m
+ $ echo 'let f (x : ) = x#m' | fmt
+ let f (x : < m : int ; n : float >) = x#m
+ $ echo "let f (x : 'a>) = x#m" | fmt
+ let f (x : < m : 'a. 'a -> 'a >) = x#m
+ $ echo 'let f : -> 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 = ' | fmt
+ let f =
+
+Idempotency check:
+ $ echo 'let f (x : ) = x#m' | fmt | fmt
+ let f (x : < m : int >) = x#m
diff --git a/vendor/parser-extended/dune b/vendor/parser-extended/dune
index 5ffb0dd0e4..58fc950af5 100644
--- a/vendor/parser-extended/dune
+++ b/vendor/parser-extended/dune
@@ -31,6 +31,8 @@
EOL
--unused-token
GREATERRBRACKET
+ --unused-token
+ GREATERRBRACE
--fixed-exception
--table
--strategy
diff --git a/vendor/parser-extended/lexer.mll b/vendor/parser-extended/lexer.mll
index ad661aa8d7..a7c6d2a839 100644
--- a/vendor/parser-extended/lexer.mll
+++ b/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 }
diff --git a/vendor/parser-extended/parser.mly b/vendor/parser-extended/parser.mly
index 99b09f35ce..9ed6c0fd9e 100644
--- a/vendor/parser-extended/parser.mly
+++ b/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
diff --git a/vendor/parser-standard/dune b/vendor/parser-standard/dune
index 67979f5b34..fc9364d74e 100644
--- a/vendor/parser-standard/dune
+++ b/vendor/parser-standard/dune
@@ -31,6 +31,8 @@
EOL
--unused-token
GREATERRBRACKET
+ --unused-token
+ GREATERRBRACE
--fixed-exception
--table
--strategy
diff --git a/vendor/parser-standard/lexer.mll b/vendor/parser-standard/lexer.mll
index 04d1b531d2..27b95b9ceb 100644
--- a/vendor/parser-standard/lexer.mll
+++ b/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 }
diff --git a/vendor/parser-standard/parser.mly b/vendor/parser-standard/parser.mly
index 4cd56a3bbe..2d20e7a0e7 100644
--- a/vendor/parser-standard/parser.mly
+++ b/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