From c0df1fd5807c5125c22fa5bf2e30ccee05c6b8aa Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 27 Jun 2022 20:04:47 +0200 Subject: [PATCH 1/3] Prepare support for `ns.optional`. See https://github.com/rescript-lang/syntax/pull/588 --- jscomp/ml/printtyp.ml | 2 +- jscomp/ml/typecore.ml | 4 +- jscomp/ml/typedecl.ml | 2 +- jscomp/test/record_regression.res | 66 +++++++++---------- jscomp/test/res_debug.res | 4 +- lib/4.06.1/unstable/js_compiler.ml | 8 +-- lib/4.06.1/unstable/js_playground_compiler.ml | 8 +-- lib/4.06.1/whole_compiler.ml | 8 +-- 8 files changed, 51 insertions(+), 51 deletions(-) diff --git a/jscomp/ml/printtyp.ml b/jscomp/ml/printtyp.ml index 6f44b48f0d..9ed46506ed 100644 --- a/jscomp/ml/printtyp.ml +++ b/jscomp/ml/printtyp.ml @@ -926,7 +926,7 @@ and tree_of_constructor cd = (name, args, Some ret) and tree_of_label l = - let opt = l.ld_attributes |> List.exists (fun ({txt}, _) -> txt = "optional") in + let opt = l.ld_attributes |> List.exists (fun ({txt}, _) -> txt = "ns.optional") in let typ = match l.ld_type.desc with | Tconstr (p, [t1], _) when opt && Path.same p Predef.path_option -> t1 | _ -> l.ld_type in diff --git a/jscomp/ml/typecore.ml b/jscomp/ml/typecore.ml index 8815be4a88..ea98c3ddae 100644 --- a/jscomp/ml/typecore.ml +++ b/jscomp/ml/typecore.ml @@ -1155,7 +1155,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env | _ -> false in let process_optional_label (ld, pat) = let exp_optional_attr = - Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "optional") + Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "ns.optional") in let isFromPamatch = match pat.ppat_desc with | Ppat_construct ({txt = Lident s}, _) -> @@ -1881,7 +1881,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = | _ -> false in let process_optional_label (id, ld, e) = let exp_optional_attr = - Ext_list.exists e.pexp_attributes (fun ({txt },_) -> txt = "optional") + Ext_list.exists e.pexp_attributes (fun ({txt },_) -> txt = "ns.optional") in if label_is_optional ld && not exp_optional_attr then let lid = mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))) in diff --git a/jscomp/ml/typedecl.ml b/jscomp/ml/typedecl.ml index 5e9fa78458..eba808bbef 100644 --- a/jscomp/ml/typedecl.ml +++ b/jscomp/ml/typedecl.ml @@ -396,7 +396,7 @@ let transl_declaration env sdecl id = let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in Ttype_variant tcstrs, Type_variant cstrs | Ptype_record lbls -> - let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "optional") in + let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "ns.optional") in let optionalLabels = Ext_list.filter_map lbls (fun lbl -> if has_optional lbl.pld_attributes then Some lbl.pld_name.txt else None) in diff --git a/jscomp/test/record_regression.res b/jscomp/test/record_regression.res index 70bb5ca430..c15bd3ea13 100644 --- a/jscomp/test/record_regression.res +++ b/jscomp/test/record_regression.res @@ -1,6 +1,6 @@ // @@config({flags: ["-bs-diagnose"] }) -type t0 = {x: int, @optional y: int, @optional yy: option, z: int} +type t0 = {x: int, @ns.optional y: int, @ns.optional yy: option, z: int} let f1 = {x: 3, z: 2} @@ -31,30 +31,30 @@ let v2: r = {x: 3, y: None, z: 2} type config = { x: int, - @optional y0: int, - @optional y1: int, - @optional y2: int, - @optional y3: int, - @optional y4: int, - @optional y5: int, - @optional y6: int, - @optional y7: int, - @optional y8: int, - @optional y9: int, - @optional y10: int, - @optional y11: int, - @optional y12: int, - @optional y13: int, - @optional y14: int, - @optional y15: int, - @optional y16: int, - @optional y17: int, - @optional y18: int, - @optional y19: int, - @optional y20: int, - @optional y21: int, - @optional y22: int, - @optional y23: int, + @ns.optional y0: int, + @ns.optional y1: int, + @ns.optional y2: int, + @ns.optional y3: int, + @ns.optional y4: int, + @ns.optional y5: int, + @ns.optional y6: int, + @ns.optional y7: int, + @ns.optional y8: int, + @ns.optional y9: int, + @ns.optional y10: int, + @ns.optional y11: int, + @ns.optional y12: int, + @ns.optional y13: int, + @ns.optional y14: int, + @ns.optional y15: int, + @ns.optional y16: int, + @ns.optional y17: int, + @ns.optional y18: int, + @ns.optional y19: int, + @ns.optional y20: int, + @ns.optional y21: int, + @ns.optional y22: int, + @ns.optional y23: int, z: int, } @@ -64,8 +64,8 @@ let h: config = {...v, y1: 22} type small_config = { x: int, - @optional y0: int, - @optional y1: int, + @ns.optional y0: int, + @ns.optional y1: int, z: int, } @@ -78,25 +78,25 @@ let h11 = (v1): small_config => { } type partiallyOptional = { - @optional aa: int, + @ns.optional aa: int, bb: option, } let po = {aa: 3, bb: Some(4)} -let _ = {...po, aa: @optional None} +let _ = {...po, aa: @ns.optional None} -let setAA = (ao: option) => {aa: @optional ao, bb: None} +let setAA = (ao: option) => {aa: @ns.optional ao, bb: None} // Trigger representation mismatch error. // module M: { // type partiallyOptional = { -// @optional aa: int, +// @ns.optional aa: int, // bb: option, // } // } = { // type partiallyOptional = { -// @optional aa: int, -// @optional bb: int, +// @ns.optional aa: int, +// @ns.optional bb: int, // } // } diff --git a/jscomp/test/res_debug.res b/jscomp/test/res_debug.res index 31d08a546d..a74a48535f 100644 --- a/jscomp/test/res_debug.res +++ b/jscomp/test/res_debug.res @@ -29,7 +29,7 @@ let f = (window, a, b) => { type r = { x: int, - @optional y: int, + @ns.optional y: int, z : int } @@ -47,7 +47,7 @@ let v1 : r = { x : 3 let testMatch = v => switch v { | {y} => y - | {y: @optional None} => 42 + | {y: @ns.optional None} => 42 } let h = '😊' diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml index 576aba6a0b..de6d155178 100644 --- a/lib/4.06.1/unstable/js_compiler.ml +++ b/lib/4.06.1/unstable/js_compiler.ml @@ -33357,7 +33357,7 @@ and tree_of_constructor cd = (name, args, Some ret) and tree_of_label l = - let opt = l.ld_attributes |> List.exists (fun ({txt}, _) -> txt = "optional") in + let opt = l.ld_attributes |> List.exists (fun ({txt}, _) -> txt = "ns.optional") in let typ = match l.ld_type.desc with | Tconstr (p, [t1], _) when opt && Path.same p Predef.path_option -> t1 | _ -> l.ld_type in @@ -36187,7 +36187,7 @@ let transl_declaration env sdecl id = let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in Ttype_variant tcstrs, Type_variant cstrs | Ptype_record lbls -> - let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "optional") in + let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "ns.optional") in let optionalLabels = Ext_list.filter_map lbls (fun lbl -> if has_optional lbl.pld_attributes then Some lbl.pld_name.txt else None) in @@ -40056,7 +40056,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env | _ -> false in let process_optional_label (ld, pat) = let exp_optional_attr = - Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "optional") + Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "ns.optional") in let isFromPamatch = match pat.ppat_desc with | Ppat_construct ({txt = Lident s}, _) -> @@ -40782,7 +40782,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = | _ -> false in let process_optional_label (id, ld, e) = let exp_optional_attr = - Ext_list.exists e.pexp_attributes (fun ({txt },_) -> txt = "optional") + Ext_list.exists e.pexp_attributes (fun ({txt },_) -> txt = "ns.optional") in if label_is_optional ld && not exp_optional_attr then let lid = mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))) in diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml index 83e8f8bbdf..f8297e974a 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/lib/4.06.1/unstable/js_playground_compiler.ml @@ -33357,7 +33357,7 @@ and tree_of_constructor cd = (name, args, Some ret) and tree_of_label l = - let opt = l.ld_attributes |> List.exists (fun ({txt}, _) -> txt = "optional") in + let opt = l.ld_attributes |> List.exists (fun ({txt}, _) -> txt = "ns.optional") in let typ = match l.ld_type.desc with | Tconstr (p, [t1], _) when opt && Path.same p Predef.path_option -> t1 | _ -> l.ld_type in @@ -36187,7 +36187,7 @@ let transl_declaration env sdecl id = let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in Ttype_variant tcstrs, Type_variant cstrs | Ptype_record lbls -> - let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "optional") in + let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "ns.optional") in let optionalLabels = Ext_list.filter_map lbls (fun lbl -> if has_optional lbl.pld_attributes then Some lbl.pld_name.txt else None) in @@ -40056,7 +40056,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env | _ -> false in let process_optional_label (ld, pat) = let exp_optional_attr = - Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "optional") + Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "ns.optional") in let isFromPamatch = match pat.ppat_desc with | Ppat_construct ({txt = Lident s}, _) -> @@ -40782,7 +40782,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = | _ -> false in let process_optional_label (id, ld, e) = let exp_optional_attr = - Ext_list.exists e.pexp_attributes (fun ({txt },_) -> txt = "optional") + Ext_list.exists e.pexp_attributes (fun ({txt },_) -> txt = "ns.optional") in if label_is_optional ld && not exp_optional_attr then let lid = mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))) in diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index 303be704e0..4c89fe0d69 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -207888,7 +207888,7 @@ and tree_of_constructor cd = (name, args, Some ret) and tree_of_label l = - let opt = l.ld_attributes |> List.exists (fun ({txt}, _) -> txt = "optional") in + let opt = l.ld_attributes |> List.exists (fun ({txt}, _) -> txt = "ns.optional") in let typ = match l.ld_type.desc with | Tconstr (p, [t1], _) when opt && Path.same p Predef.path_option -> t1 | _ -> l.ld_type in @@ -210718,7 +210718,7 @@ let transl_declaration env sdecl id = let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in Ttype_variant tcstrs, Type_variant cstrs | Ptype_record lbls -> - let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "optional") in + let has_optional attrs = Ext_list.exists attrs (fun ({txt },_) -> txt = "ns.optional") in let optionalLabels = Ext_list.filter_map lbls (fun lbl -> if has_optional lbl.pld_attributes then Some lbl.pld_name.txt else None) in @@ -214587,7 +214587,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env | _ -> false in let process_optional_label (ld, pat) = let exp_optional_attr = - Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "optional") + Ext_list.exists pat.ppat_attributes (fun ({txt },_) -> txt = "ns.optional") in let isFromPamatch = match pat.ppat_desc with | Ppat_construct ({txt = Lident s}, _) -> @@ -215313,7 +215313,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected = | _ -> false in let process_optional_label (id, ld, e) = let exp_optional_attr = - Ext_list.exists e.pexp_attributes (fun ({txt },_) -> txt = "optional") + Ext_list.exists e.pexp_attributes (fun ({txt },_) -> txt = "ns.optional") in if label_is_optional ld && not exp_optional_attr then let lid = mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))) in From f2c8c7f73ccdd2bc7d54ab3178bc2a5be417b2ba Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 27 Jun 2022 21:29:19 +0200 Subject: [PATCH 2/3] Use the syntax module which adds support for `ns.optional`. --- lib/4.06.1/unstable/js_playground_compiler.ml | 280 +++++++++++++++--- .../unstable/js_playground_compiler.ml.d | 1 + lib/4.06.1/whole_compiler.ml | 280 +++++++++++++++--- lib/4.06.1/whole_compiler.ml.d | 1 + syntax | 2 +- 5 files changed, 477 insertions(+), 87 deletions(-) diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml b/lib/4.06.1/unstable/js_playground_compiler.ml index f8297e974a..35f8031251 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml +++ b/lib/4.06.1/unstable/js_playground_compiler.ml @@ -269770,6 +269770,7 @@ val filterFragileMatchAttributes : Parsetree.attributes -> Parsetree.attributes val isJsxExpression : Parsetree.expression -> bool val hasJsxAttribute : Parsetree.attributes -> bool +val hasOptionalAttribute : Parsetree.attributes -> bool val shouldIndentBinaryExpr : Parsetree.expression -> bool val shouldInlineRhsBinaryExpr : Parsetree.expression -> bool @@ -270001,7 +270002,7 @@ let filterParsingAttrs attrs = | ( { Location.txt = ( "ns.ternary" | "ns.braces" | "res.template" | "bs" | "ns.iflet" - | "ns.namedArgLoc" ); + | "ns.namedArgLoc" | "ns.optional" ); }, _ ) -> false @@ -270136,6 +270137,12 @@ let isIfLetExpr expr = true | _ -> false +let rec hasOptionalAttribute attrs = + match attrs with + | [] -> false + | ({Location.txt = "ns.optional"}, _) :: _ -> true + | _ :: attrs -> hasOptionalAttribute attrs + let hasAttributes attrs = List.exists (fun attr -> @@ -273144,7 +273151,7 @@ let isExprStart = function | _ -> false let isJsxAttributeStart = function - | Token.Lident _ | Question -> true + | Token.Lident _ | Question | Lbrace -> true | _ -> false let isStructureItemStart = function @@ -273670,6 +273677,22 @@ type problem = type parseError = Lexing.position * problem +end +module Res_string += struct +#1 "res_string.ml" +let hexTable = + [| '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9'; 'a'; 'b'; 'c'; 'd'; 'e'; 'f'; |] + [@ocamlformat "disable"] + +let convertDecimalToHex ~strDecimal = + try + let intNum = int_of_string strDecimal in + let c1 = Array.get hexTable (intNum lsr 4) in + let c2 = Array.get hexTable (intNum land 15) in + "x" ^ String.concat "" [String.make 1 c1; String.make 1 c2] + with Invalid_argument _ | Failure _ -> strDecimal + end module Res_utf8 : sig #1 "res_utf8.mli" @@ -274210,13 +274233,12 @@ let scanStringEscapeSequence ~startPos scanner = match scanner.ch with (* \ already consumed *) | 'n' | 't' | 'b' | 'r' | '\\' | ' ' | '\'' | '"' -> next scanner - | '0' .. '9' -> - (* decimal *) - scan ~n:3 ~base:10 ~max:255 - | 'o' -> - (* octal *) - next scanner; - scan ~n:3 ~base:8 ~max:255 + | '0' + when let c = peek scanner in + c < '0' || c > '9' -> + (* Allow \0 *) + next scanner + | '0' .. '9' -> scan ~n:3 ~base:10 ~max:255 | 'x' -> (* hex *) next scanner; @@ -274258,28 +274280,72 @@ let scanString scanner = (* assumption: we've just matched a quote *) let startPosWithQuote = position scanner in next scanner; + + (* If the text needs changing, a buffer is used *) + let buf = Buffer.create 0 in let firstCharOffset = scanner.offset in + let lastOffsetInBuf = ref firstCharOffset in + + let bringBufUpToDate ~startOffset = + let strUpToNow = + (String.sub scanner.src !lastOffsetInBuf + (startOffset - !lastOffsetInBuf) [@doesNotRaise]) + in + Buffer.add_string buf strUpToNow; + lastOffsetInBuf := startOffset + in + + let result ~firstCharOffset ~lastCharOffset = + if Buffer.length buf = 0 then + (String.sub [@doesNotRaise]) scanner.src firstCharOffset + (lastCharOffset - firstCharOffset) + else ( + bringBufUpToDate ~startOffset:lastCharOffset; + Buffer.contents buf) + in let rec scan () = match scanner.ch with | '"' -> let lastCharOffset = scanner.offset in next scanner; - (String.sub [@doesNotRaise]) scanner.src firstCharOffset - (lastCharOffset - firstCharOffset) + result ~firstCharOffset ~lastCharOffset | '\\' -> let startPos = position scanner in + let startOffset = scanner.offset + 1 in next scanner; scanStringEscapeSequence ~startPos scanner; - scan () + let endOffset = scanner.offset in + convertOctalToHex ~startOffset ~endOffset | ch when ch == hackyEOFChar -> let endPos = position scanner in scanner.err ~startPos:startPosWithQuote ~endPos Diagnostics.unclosedString; - (String.sub [@doesNotRaise]) scanner.src firstCharOffset - (scanner.offset - firstCharOffset) + let lastCharOffset = scanner.offset in + result ~firstCharOffset ~lastCharOffset | _ -> next scanner; scan () + and convertOctalToHex ~startOffset ~endOffset = + let len = endOffset - startOffset in + let isDigit = function + | '0' .. '9' -> true + | _ -> false + in + let txt = scanner.src in + let isNumericEscape = + len = 3 + && (isDigit txt.[startOffset] [@doesNotRaise]) + && (isDigit txt.[startOffset + 1] [@doesNotRaise]) + && (isDigit txt.[startOffset + 2] [@doesNotRaise]) + in + if isNumericEscape then ( + let strDecimal = (String.sub txt startOffset 3 [@doesNotRaise]) in + bringBufUpToDate ~startOffset; + let strHex = Res_string.convertDecimalToHex ~strDecimal in + lastOffsetInBuf := startOffset + 3; + Buffer.add_string buf strHex; + scan ()) + else scan () in Token.String (scan ()) @@ -275629,6 +275695,18 @@ let hasCommentBelow tbl loc = | [] -> false | exception Not_found -> false +let hasNestedJsxOrMoreThanOneChild expr = + let rec loop inRecursion expr = + match expr.Parsetree.pexp_desc with + | Pexp_construct + ({txt = Longident.Lident "::"}, Some {pexp_desc = Pexp_tuple [hd; tail]}) + -> + if inRecursion || ParsetreeViewer.isJsxExpression hd then true + else loop true tail + | _ -> false + in + loop false expr + let printMultilineCommentContent txt = (* Turns * |* first line @@ -276041,6 +276119,10 @@ let printConstant ?(templateLiteral = false) c = in Doc.text ("'" ^ str ^ "'") +let printOptionalLabel attrs = + if Res_parsetree_viewer.hasOptionalAttribute attrs then Doc.text "?" + else Doc.nil + let rec printStructure (s : Parsetree.structure) t = match s with | [] -> printCommentsInside t Location.none @@ -276944,10 +277026,16 @@ and printLabelDeclaration (ld : Parsetree.label_declaration) cmtTbl = let doc = printIdentLike ld.pld_name.txt in printComments doc cmtTbl ld.pld_name.loc in + let optional = printOptionalLabel ld.pld_attributes in Doc.group (Doc.concat [ - attrs; mutableFlag; name; Doc.text ": "; printTypExpr ld.pld_type cmtTbl; + attrs; + mutableFlag; + name; + optional; + Doc.text ": "; + printTypExpr ld.pld_type cmtTbl; ]) and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = @@ -277860,16 +277948,24 @@ and printPatternRecordRow row cmtTbl = match row with (* punned {x}*) | ( ({Location.txt = Longident.Lident ident} as longident), - {Parsetree.ppat_desc = Ppat_var {txt; _}} ) + {Parsetree.ppat_desc = Ppat_var {txt; _}; ppat_attributes} ) when ident = txt -> - printLidentPath longident cmtTbl + Doc.concat + [ + printOptionalLabel ppat_attributes; + printAttributes ppat_attributes cmtTbl; + printLidentPath longident cmtTbl; + ] | longident, pattern -> let locForComments = {longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end} in let rhsDoc = let doc = printPattern pattern cmtTbl in - if Parens.patternRecordRowRhs pattern then addParens doc else doc + let doc = + if Parens.patternRecordRowRhs pattern then addParens doc else doc + in + Doc.concat [printOptionalLabel pattern.ppat_attributes; doc] in let doc = Doc.group @@ -278234,7 +278330,8 @@ and printExpression (e : Parsetree.expression) cmtTbl = Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map - (fun row -> printRecordRow row cmtTbl punningAllowed) + (fun row -> + printExpressionRecordRow row cmtTbl punningAllowed) rows); ]); Doc.trailingComma; @@ -279224,6 +279321,12 @@ and printJsxExpression lident args cmtTbl = true | _ -> false in + let lineSep = + match children with + | Some expr -> + if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line + | None -> Doc.line + in Doc.group (Doc.concat [ @@ -279258,10 +279361,10 @@ and printJsxExpression lident args cmtTbl = Doc.line; (match children with | Some childrenExpression -> - printJsxChildren childrenExpression cmtTbl + printJsxChildren childrenExpression ~sep:lineSep cmtTbl | None -> Doc.nil); ]); - Doc.line; + lineSep; Doc.text "" in let closing = Doc.text "" in - (* let (children, _) = ParsetreeViewer.collectListExpressions expr in *) + let lineSep = + if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line + in Doc.group (Doc.concat [ opening; (match expr.pexp_desc with | Pexp_construct ({txt = Longident.Lident "[]"}, None) -> Doc.nil - | _ -> Doc.indent (Doc.concat [Doc.line; printJsxChildren expr cmtTbl])); - Doc.line; + | _ -> + Doc.indent + (Doc.concat [Doc.line; printJsxChildren expr ~sep:lineSep cmtTbl])); + lineSep; closing; ]) -and printJsxChildren (childrenExpr : Parsetree.expression) cmtTbl = +and printJsxChildren (childrenExpr : Parsetree.expression) ~sep cmtTbl = match childrenExpr.pexp_desc with | Pexp_construct ({txt = Longident.Lident "::"}, _) -> let children, _ = ParsetreeViewer.collectListExpressions childrenExpr in Doc.group - (Doc.join ~sep:Doc.line + (Doc.join ~sep (List.map (fun (expr : Parsetree.expression) -> let leadingLineCommentPresent = @@ -280146,7 +280253,7 @@ and printDirectionFlag flag = | Asttypes.Downto -> Doc.text " downto " | Asttypes.Upto -> Doc.text " to " -and printRecordRow (lbl, expr) cmtTbl punningAllowed = +and printExpressionRecordRow (lbl, expr) cmtTbl punningAllowed = let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in let doc = Doc.group @@ -280154,12 +280261,18 @@ and printRecordRow (lbl, expr) cmtTbl punningAllowed = | Pexp_ident {txt = Lident key; loc = _keyLoc} when punningAllowed && Longident.last lbl.txt = key -> (* print punned field *) - printLidentPath lbl cmtTbl + Doc.concat + [ + printAttributes expr.pexp_attributes cmtTbl; + printOptionalLabel expr.pexp_attributes; + printLidentPath lbl cmtTbl; + ] | _ -> Doc.concat [ printLidentPath lbl cmtTbl; Doc.text ": "; + printOptionalLabel expr.pexp_attributes; (let doc = printExpressionWithComments expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc @@ -280759,6 +280872,15 @@ let jsxAttr = (Location.mknoloc "JSX", Parsetree.PStr []) let uncurryAttr = (Location.mknoloc "bs", Parsetree.PStr []) let ternaryAttr = (Location.mknoloc "ns.ternary", Parsetree.PStr []) let ifLetAttr = (Location.mknoloc "ns.iflet", Parsetree.PStr []) +let optionalAttr = (Location.mknoloc "ns.optional", Parsetree.PStr []) + +let makeExpressionOptional ~optional (e : Parsetree.expression) = + if optional then {e with pexp_attributes = optionalAttr :: e.pexp_attributes} + else e +let makePatternOptional ~optional (p : Parsetree.pattern) = + if optional then {p with ppat_attributes = optionalAttr :: p.ppat_attributes} + else p + let suppressFragileMatchWarningAttr = ( Location.mknoloc "warning", Parsetree.PStr @@ -281630,7 +281752,11 @@ let rec parsePattern ?(alias = true) ?(or_ = true) p = | _ -> Parser.expect Rparen p; let loc = mkLoc startPos p.prevEndPos in - {pat with ppat_loc = loc})) + { + pat with + ppat_loc = loc; + ppat_attributes = attrs @ pat.Parsetree.ppat_attributes; + })) | Lbracket -> parseArrayPattern ~attrs p | Lbrace -> parseRecordPattern ~attrs p | Underscore -> @@ -281794,6 +281920,13 @@ and parseConstrainedPatternRegion p = | token when Grammar.isPatternStart token -> Some (parseConstrainedPattern p) | _ -> None +and parseOptionalLabel p = + match p.Parser.token with + | Question -> + Parser.next p; + true + | _ -> false + (* field ::= * | longident * | longident : pattern @@ -281804,26 +281937,37 @@ and parseConstrainedPatternRegion p = * | field , _ * | field , _, *) -and parseRecordPatternField p = +and parseRecordPatternRowField ~attrs p = let label = parseValuePath p in let pattern = match p.Parser.token with | Colon -> Parser.next p; - parsePattern p + let optional = parseOptionalLabel p in + let pat = parsePattern p in + makePatternOptional ~optional pat | _ -> - Ast_helper.Pat.var ~loc:label.loc + Ast_helper.Pat.var ~loc:label.loc ~attrs (Location.mkloc (Longident.last label.txt) label.loc) in (label, pattern) (* TODO: there are better representations than PatField|Underscore ? *) -and parseRecordPatternItem p = +and parseRecordPatternRow p = + let attrs = parseAttributes p in match p.Parser.token with | DotDotDot -> Parser.next p; - Some (true, PatField (parseRecordPatternField p)) - | Uident _ | Lident _ -> Some (false, PatField (parseRecordPatternField p)) + Some (true, PatField (parseRecordPatternRowField ~attrs p)) + | Uident _ | Lident _ -> + Some (false, PatField (parseRecordPatternRowField ~attrs p)) + | Question -> ( + Parser.next p; + match p.token with + | Uident _ | Lident _ -> + let lid, pat = parseRecordPatternRowField ~attrs p in + Some (false, PatField (lid, makePatternOptional ~optional:true pat)) + | _ -> None) | Underscore -> Parser.next p; Some (false, PatUnderscore) @@ -281834,7 +281978,7 @@ and parseRecordPattern ~attrs p = Parser.expect Lbrace p; let rawFields = parseCommaDelimitedReversedList p ~grammar:PatternRecord ~closing:Rbrace - ~f:parseRecordPatternItem + ~f:parseRecordPatternRow in Parser.expect Rbrace p; let fields, closedFlag = @@ -283164,6 +283308,7 @@ and parseJsxFragment p = * | ?lident * | lident = jsx_expr * | lident = ?jsx_expr + * | {...jsx_expr} *) and parseJsxProp p = match p.Parser.token with @@ -283202,6 +283347,28 @@ and parseJsxProp p = if optional then Asttypes.Optional name else Asttypes.Labelled name in Some (label, attrExpr)) + (* {...props} *) + | Lbrace -> ( + Parser.next p; + match p.Parser.token with + | DotDotDot -> ( + Parser.next p; + let loc = mkLoc p.Parser.startPos p.prevEndPos in + let propLocAttr = + (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) + in + let attrExpr = + let e = parsePrimaryExpr ~operand:(parseAtomicExpr p) p in + {e with pexp_attributes = propLocAttr :: e.pexp_attributes} + in + (* using label "spreadProps" to distinguish from others *) + let label = Asttypes.Labelled "spreadProps" in + match p.Parser.token with + | Rbrace -> + Parser.next p; + Some (label, attrExpr) + | _ -> None) + | _ -> None) | _ -> None and parseJsxProps p = @@ -283310,6 +283477,10 @@ and parseBracedOrRecordExpr p = let loc = mkLoc startPos p.prevEndPos in let braces = makeBracesAttr loc in {expr with pexp_attributes = braces :: expr.pexp_attributes})) + | Question -> + let expr = parseRecordExpr ~startPos [] p in + Parser.expect Rbrace p; + expr | Uident _ | Lident _ -> ( let startToken = p.token in let valueOrConstructor = parseValueOrConstructor p in @@ -283331,7 +283502,9 @@ and parseBracedOrRecordExpr p = expr | Colon -> ( Parser.next p; + let optional = parseOptionalLabel p in let fieldExpr = parseExpr p in + let fieldExpr = makeExpressionOptional ~optional fieldExpr in match p.token with | Rbrace -> Parser.next p; @@ -283468,7 +283641,7 @@ and parseBracedOrRecordExpr p = let braces = makeBracesAttr loc in {expr with pexp_attributes = braces :: expr.pexp_attributes} -and parseRecordRowWithStringKey p = +and parseRecordExprRowWithStringKey p = match p.Parser.token with | String s -> ( let loc = mkLoc p.startPos p.endPos in @@ -283482,7 +283655,8 @@ and parseRecordRowWithStringKey p = | _ -> Some (field, Ast_helper.Exp.ident ~loc:field.loc field)) | _ -> None -and parseRecordRow p = +and parseRecordExprRow p = + let attrs = parseAttributes p in let () = match p.Parser.token with | Token.DotDotDot -> @@ -283497,23 +283671,39 @@ and parseRecordRow p = match p.Parser.token with | Colon -> Parser.next p; + let optional = parseOptionalLabel p in let fieldExpr = parseExpr p in + let fieldExpr = makeExpressionOptional ~optional fieldExpr in Some (field, fieldExpr) | _ -> - let value = Ast_helper.Exp.ident ~loc:field.loc field in + let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in let value = match startToken with | Uident _ -> removeModuleNameFromPunnedFieldValue value | _ -> value in Some (field, value)) + | Question -> ( + Parser.next p; + match p.Parser.token with + | Lident _ | Uident _ -> + let startToken = p.token in + let field = parseValuePath p in + let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in + let value = + match startToken with + | Uident _ -> removeModuleNameFromPunnedFieldValue value + | _ -> value + in + Some (field, makeExpressionOptional ~optional:true value) + | _ -> None) | _ -> None and parseRecordExprWithStringKeys ~startPos firstRow p = let rows = firstRow :: parseCommaDelimitedRegion ~grammar:Grammar.RecordRowsStringKey - ~closing:Rbrace ~f:parseRecordRowWithStringKey p + ~closing:Rbrace ~f:parseRecordExprRowWithStringKey p in let loc = mkLoc startPos p.endPos in let recordStrExpr = @@ -283525,7 +283715,7 @@ and parseRecordExprWithStringKeys ~startPos firstRow p = and parseRecordExpr ~startPos ?(spread = None) rows p = let exprs = parseCommaDelimitedRegion ~grammar:Grammar.RecordRows ~closing:Rbrace - ~f:parseRecordRow p + ~f:parseRecordExprRow p in let rows = List.concat [rows; exprs] in let () = @@ -284799,15 +284989,19 @@ and parseFieldDeclarationRegion p = | Lident _ -> let lident, loc = parseLident p in let name = Location.mkloc lident loc in + let optional = parseOptionalLabel p in let typ = match p.Parser.token with | Colon -> Parser.next p; parsePolyTypeExpr p | _ -> - Ast_helper.Typ.constr ~loc:name.loc {name with txt = Lident name.txt} [] + Ast_helper.Typ.constr ~loc:name.loc ~attrs + {name with txt = Lident name.txt} + [] in let loc = mkLoc startPos typ.ptyp_loc.loc_end in + let attrs = if optional then optionalAttr :: attrs else attrs in Some (Ast_helper.Type.field ~attrs ~loc ~mut name typ) | _ -> None @@ -287637,7 +287831,7 @@ and printRecordDeclRowDoc (name, mut, opt, arg) = Doc.group (Doc.concat [ - (if opt then Doc.text "@optional " else Doc.nil); + (if opt then Doc.text "?" else Doc.nil); (if mut then Doc.text "mutable " else Doc.nil); printIdentLike ~allowUident:false name; Doc.text ": "; diff --git a/lib/4.06.1/unstable/js_playground_compiler.ml.d b/lib/4.06.1/unstable/js_playground_compiler.ml.d index 594a0b6c58..8c9562a770 100644 --- a/lib/4.06.1/unstable/js_playground_compiler.ml.d +++ b/lib/4.06.1/unstable/js_playground_compiler.ml.d @@ -596,6 +596,7 @@ ../lib/4.06.1/unstable/js_playground_compiler.ml: ./napkin/res_reporting.ml ../lib/4.06.1/unstable/js_playground_compiler.ml: ./napkin/res_scanner.ml ../lib/4.06.1/unstable/js_playground_compiler.ml: ./napkin/res_scanner.mli +../lib/4.06.1/unstable/js_playground_compiler.ml: ./napkin/res_string.ml ../lib/4.06.1/unstable/js_playground_compiler.ml: ./napkin/res_token.ml ../lib/4.06.1/unstable/js_playground_compiler.ml: ./napkin/res_utf8.ml ../lib/4.06.1/unstable/js_playground_compiler.ml: ./napkin/res_utf8.mli diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml index 4c89fe0d69..3e9444da24 100644 --- a/lib/4.06.1/whole_compiler.ml +++ b/lib/4.06.1/whole_compiler.ml @@ -275512,6 +275512,7 @@ val filterFragileMatchAttributes : Parsetree.attributes -> Parsetree.attributes val isJsxExpression : Parsetree.expression -> bool val hasJsxAttribute : Parsetree.attributes -> bool +val hasOptionalAttribute : Parsetree.attributes -> bool val shouldIndentBinaryExpr : Parsetree.expression -> bool val shouldInlineRhsBinaryExpr : Parsetree.expression -> bool @@ -275743,7 +275744,7 @@ let filterParsingAttrs attrs = | ( { Location.txt = ( "ns.ternary" | "ns.braces" | "res.template" | "bs" | "ns.iflet" - | "ns.namedArgLoc" ); + | "ns.namedArgLoc" | "ns.optional" ); }, _ ) -> false @@ -275878,6 +275879,12 @@ let isIfLetExpr expr = true | _ -> false +let rec hasOptionalAttribute attrs = + match attrs with + | [] -> false + | ({Location.txt = "ns.optional"}, _) :: _ -> true + | _ :: attrs -> hasOptionalAttribute attrs + let hasAttributes attrs = List.exists (fun attr -> @@ -278886,7 +278893,7 @@ let isExprStart = function | _ -> false let isJsxAttributeStart = function - | Token.Lident _ | Question -> true + | Token.Lident _ | Question | Lbrace -> true | _ -> false let isStructureItemStart = function @@ -279412,6 +279419,22 @@ type problem = type parseError = Lexing.position * problem +end +module Res_string += struct +#1 "res_string.ml" +let hexTable = + [| '0'; '1'; '2'; '3'; '4'; '5'; '6'; '7'; '8'; '9'; 'a'; 'b'; 'c'; 'd'; 'e'; 'f'; |] + [@ocamlformat "disable"] + +let convertDecimalToHex ~strDecimal = + try + let intNum = int_of_string strDecimal in + let c1 = Array.get hexTable (intNum lsr 4) in + let c2 = Array.get hexTable (intNum land 15) in + "x" ^ String.concat "" [String.make 1 c1; String.make 1 c2] + with Invalid_argument _ | Failure _ -> strDecimal + end module Res_utf8 : sig #1 "res_utf8.mli" @@ -279952,13 +279975,12 @@ let scanStringEscapeSequence ~startPos scanner = match scanner.ch with (* \ already consumed *) | 'n' | 't' | 'b' | 'r' | '\\' | ' ' | '\'' | '"' -> next scanner - | '0' .. '9' -> - (* decimal *) - scan ~n:3 ~base:10 ~max:255 - | 'o' -> - (* octal *) - next scanner; - scan ~n:3 ~base:8 ~max:255 + | '0' + when let c = peek scanner in + c < '0' || c > '9' -> + (* Allow \0 *) + next scanner + | '0' .. '9' -> scan ~n:3 ~base:10 ~max:255 | 'x' -> (* hex *) next scanner; @@ -280000,28 +280022,72 @@ let scanString scanner = (* assumption: we've just matched a quote *) let startPosWithQuote = position scanner in next scanner; + + (* If the text needs changing, a buffer is used *) + let buf = Buffer.create 0 in let firstCharOffset = scanner.offset in + let lastOffsetInBuf = ref firstCharOffset in + + let bringBufUpToDate ~startOffset = + let strUpToNow = + (String.sub scanner.src !lastOffsetInBuf + (startOffset - !lastOffsetInBuf) [@doesNotRaise]) + in + Buffer.add_string buf strUpToNow; + lastOffsetInBuf := startOffset + in + + let result ~firstCharOffset ~lastCharOffset = + if Buffer.length buf = 0 then + (String.sub [@doesNotRaise]) scanner.src firstCharOffset + (lastCharOffset - firstCharOffset) + else ( + bringBufUpToDate ~startOffset:lastCharOffset; + Buffer.contents buf) + in let rec scan () = match scanner.ch with | '"' -> let lastCharOffset = scanner.offset in next scanner; - (String.sub [@doesNotRaise]) scanner.src firstCharOffset - (lastCharOffset - firstCharOffset) + result ~firstCharOffset ~lastCharOffset | '\\' -> let startPos = position scanner in + let startOffset = scanner.offset + 1 in next scanner; scanStringEscapeSequence ~startPos scanner; - scan () + let endOffset = scanner.offset in + convertOctalToHex ~startOffset ~endOffset | ch when ch == hackyEOFChar -> let endPos = position scanner in scanner.err ~startPos:startPosWithQuote ~endPos Diagnostics.unclosedString; - (String.sub [@doesNotRaise]) scanner.src firstCharOffset - (scanner.offset - firstCharOffset) + let lastCharOffset = scanner.offset in + result ~firstCharOffset ~lastCharOffset | _ -> next scanner; scan () + and convertOctalToHex ~startOffset ~endOffset = + let len = endOffset - startOffset in + let isDigit = function + | '0' .. '9' -> true + | _ -> false + in + let txt = scanner.src in + let isNumericEscape = + len = 3 + && (isDigit txt.[startOffset] [@doesNotRaise]) + && (isDigit txt.[startOffset + 1] [@doesNotRaise]) + && (isDigit txt.[startOffset + 2] [@doesNotRaise]) + in + if isNumericEscape then ( + let strDecimal = (String.sub txt startOffset 3 [@doesNotRaise]) in + bringBufUpToDate ~startOffset; + let strHex = Res_string.convertDecimalToHex ~strDecimal in + lastOffsetInBuf := startOffset + 3; + Buffer.add_string buf strHex; + scan ()) + else scan () in Token.String (scan ()) @@ -281371,6 +281437,18 @@ let hasCommentBelow tbl loc = | [] -> false | exception Not_found -> false +let hasNestedJsxOrMoreThanOneChild expr = + let rec loop inRecursion expr = + match expr.Parsetree.pexp_desc with + | Pexp_construct + ({txt = Longident.Lident "::"}, Some {pexp_desc = Pexp_tuple [hd; tail]}) + -> + if inRecursion || ParsetreeViewer.isJsxExpression hd then true + else loop true tail + | _ -> false + in + loop false expr + let printMultilineCommentContent txt = (* Turns * |* first line @@ -281783,6 +281861,10 @@ let printConstant ?(templateLiteral = false) c = in Doc.text ("'" ^ str ^ "'") +let printOptionalLabel attrs = + if Res_parsetree_viewer.hasOptionalAttribute attrs then Doc.text "?" + else Doc.nil + let rec printStructure (s : Parsetree.structure) t = match s with | [] -> printCommentsInside t Location.none @@ -282686,10 +282768,16 @@ and printLabelDeclaration (ld : Parsetree.label_declaration) cmtTbl = let doc = printIdentLike ld.pld_name.txt in printComments doc cmtTbl ld.pld_name.loc in + let optional = printOptionalLabel ld.pld_attributes in Doc.group (Doc.concat [ - attrs; mutableFlag; name; Doc.text ": "; printTypExpr ld.pld_type cmtTbl; + attrs; + mutableFlag; + name; + optional; + Doc.text ": "; + printTypExpr ld.pld_type cmtTbl; ]) and printTypExpr (typExpr : Parsetree.core_type) cmtTbl = @@ -283602,16 +283690,24 @@ and printPatternRecordRow row cmtTbl = match row with (* punned {x}*) | ( ({Location.txt = Longident.Lident ident} as longident), - {Parsetree.ppat_desc = Ppat_var {txt; _}} ) + {Parsetree.ppat_desc = Ppat_var {txt; _}; ppat_attributes} ) when ident = txt -> - printLidentPath longident cmtTbl + Doc.concat + [ + printOptionalLabel ppat_attributes; + printAttributes ppat_attributes cmtTbl; + printLidentPath longident cmtTbl; + ] | longident, pattern -> let locForComments = {longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end} in let rhsDoc = let doc = printPattern pattern cmtTbl in - if Parens.patternRecordRowRhs pattern then addParens doc else doc + let doc = + if Parens.patternRecordRowRhs pattern then addParens doc else doc + in + Doc.concat [printOptionalLabel pattern.ppat_attributes; doc] in let doc = Doc.group @@ -283976,7 +284072,8 @@ and printExpression (e : Parsetree.expression) cmtTbl = Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map - (fun row -> printRecordRow row cmtTbl punningAllowed) + (fun row -> + printExpressionRecordRow row cmtTbl punningAllowed) rows); ]); Doc.trailingComma; @@ -284966,6 +285063,12 @@ and printJsxExpression lident args cmtTbl = true | _ -> false in + let lineSep = + match children with + | Some expr -> + if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line + | None -> Doc.line + in Doc.group (Doc.concat [ @@ -285000,10 +285103,10 @@ and printJsxExpression lident args cmtTbl = Doc.line; (match children with | Some childrenExpression -> - printJsxChildren childrenExpression cmtTbl + printJsxChildren childrenExpression ~sep:lineSep cmtTbl | None -> Doc.nil); ]); - Doc.line; + lineSep; Doc.text "" in let closing = Doc.text "" in - (* let (children, _) = ParsetreeViewer.collectListExpressions expr in *) + let lineSep = + if hasNestedJsxOrMoreThanOneChild expr then Doc.hardLine else Doc.line + in Doc.group (Doc.concat [ opening; (match expr.pexp_desc with | Pexp_construct ({txt = Longident.Lident "[]"}, None) -> Doc.nil - | _ -> Doc.indent (Doc.concat [Doc.line; printJsxChildren expr cmtTbl])); - Doc.line; + | _ -> + Doc.indent + (Doc.concat [Doc.line; printJsxChildren expr ~sep:lineSep cmtTbl])); + lineSep; closing; ]) -and printJsxChildren (childrenExpr : Parsetree.expression) cmtTbl = +and printJsxChildren (childrenExpr : Parsetree.expression) ~sep cmtTbl = match childrenExpr.pexp_desc with | Pexp_construct ({txt = Longident.Lident "::"}, _) -> let children, _ = ParsetreeViewer.collectListExpressions childrenExpr in Doc.group - (Doc.join ~sep:Doc.line + (Doc.join ~sep (List.map (fun (expr : Parsetree.expression) -> let leadingLineCommentPresent = @@ -285888,7 +285995,7 @@ and printDirectionFlag flag = | Asttypes.Downto -> Doc.text " downto " | Asttypes.Upto -> Doc.text " to " -and printRecordRow (lbl, expr) cmtTbl punningAllowed = +and printExpressionRecordRow (lbl, expr) cmtTbl punningAllowed = let cmtLoc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in let doc = Doc.group @@ -285896,12 +286003,18 @@ and printRecordRow (lbl, expr) cmtTbl punningAllowed = | Pexp_ident {txt = Lident key; loc = _keyLoc} when punningAllowed && Longident.last lbl.txt = key -> (* print punned field *) - printLidentPath lbl cmtTbl + Doc.concat + [ + printAttributes expr.pexp_attributes cmtTbl; + printOptionalLabel expr.pexp_attributes; + printLidentPath lbl cmtTbl; + ] | _ -> Doc.concat [ printLidentPath lbl cmtTbl; Doc.text ": "; + printOptionalLabel expr.pexp_attributes; (let doc = printExpressionWithComments expr cmtTbl in match Parens.expr expr with | Parens.Parenthesized -> addParens doc @@ -286501,6 +286614,15 @@ let jsxAttr = (Location.mknoloc "JSX", Parsetree.PStr []) let uncurryAttr = (Location.mknoloc "bs", Parsetree.PStr []) let ternaryAttr = (Location.mknoloc "ns.ternary", Parsetree.PStr []) let ifLetAttr = (Location.mknoloc "ns.iflet", Parsetree.PStr []) +let optionalAttr = (Location.mknoloc "ns.optional", Parsetree.PStr []) + +let makeExpressionOptional ~optional (e : Parsetree.expression) = + if optional then {e with pexp_attributes = optionalAttr :: e.pexp_attributes} + else e +let makePatternOptional ~optional (p : Parsetree.pattern) = + if optional then {p with ppat_attributes = optionalAttr :: p.ppat_attributes} + else p + let suppressFragileMatchWarningAttr = ( Location.mknoloc "warning", Parsetree.PStr @@ -287372,7 +287494,11 @@ let rec parsePattern ?(alias = true) ?(or_ = true) p = | _ -> Parser.expect Rparen p; let loc = mkLoc startPos p.prevEndPos in - {pat with ppat_loc = loc})) + { + pat with + ppat_loc = loc; + ppat_attributes = attrs @ pat.Parsetree.ppat_attributes; + })) | Lbracket -> parseArrayPattern ~attrs p | Lbrace -> parseRecordPattern ~attrs p | Underscore -> @@ -287536,6 +287662,13 @@ and parseConstrainedPatternRegion p = | token when Grammar.isPatternStart token -> Some (parseConstrainedPattern p) | _ -> None +and parseOptionalLabel p = + match p.Parser.token with + | Question -> + Parser.next p; + true + | _ -> false + (* field ::= * | longident * | longident : pattern @@ -287546,26 +287679,37 @@ and parseConstrainedPatternRegion p = * | field , _ * | field , _, *) -and parseRecordPatternField p = +and parseRecordPatternRowField ~attrs p = let label = parseValuePath p in let pattern = match p.Parser.token with | Colon -> Parser.next p; - parsePattern p + let optional = parseOptionalLabel p in + let pat = parsePattern p in + makePatternOptional ~optional pat | _ -> - Ast_helper.Pat.var ~loc:label.loc + Ast_helper.Pat.var ~loc:label.loc ~attrs (Location.mkloc (Longident.last label.txt) label.loc) in (label, pattern) (* TODO: there are better representations than PatField|Underscore ? *) -and parseRecordPatternItem p = +and parseRecordPatternRow p = + let attrs = parseAttributes p in match p.Parser.token with | DotDotDot -> Parser.next p; - Some (true, PatField (parseRecordPatternField p)) - | Uident _ | Lident _ -> Some (false, PatField (parseRecordPatternField p)) + Some (true, PatField (parseRecordPatternRowField ~attrs p)) + | Uident _ | Lident _ -> + Some (false, PatField (parseRecordPatternRowField ~attrs p)) + | Question -> ( + Parser.next p; + match p.token with + | Uident _ | Lident _ -> + let lid, pat = parseRecordPatternRowField ~attrs p in + Some (false, PatField (lid, makePatternOptional ~optional:true pat)) + | _ -> None) | Underscore -> Parser.next p; Some (false, PatUnderscore) @@ -287576,7 +287720,7 @@ and parseRecordPattern ~attrs p = Parser.expect Lbrace p; let rawFields = parseCommaDelimitedReversedList p ~grammar:PatternRecord ~closing:Rbrace - ~f:parseRecordPatternItem + ~f:parseRecordPatternRow in Parser.expect Rbrace p; let fields, closedFlag = @@ -288906,6 +289050,7 @@ and parseJsxFragment p = * | ?lident * | lident = jsx_expr * | lident = ?jsx_expr + * | {...jsx_expr} *) and parseJsxProp p = match p.Parser.token with @@ -288944,6 +289089,28 @@ and parseJsxProp p = if optional then Asttypes.Optional name else Asttypes.Labelled name in Some (label, attrExpr)) + (* {...props} *) + | Lbrace -> ( + Parser.next p; + match p.Parser.token with + | DotDotDot -> ( + Parser.next p; + let loc = mkLoc p.Parser.startPos p.prevEndPos in + let propLocAttr = + (Location.mkloc "ns.namedArgLoc" loc, Parsetree.PStr []) + in + let attrExpr = + let e = parsePrimaryExpr ~operand:(parseAtomicExpr p) p in + {e with pexp_attributes = propLocAttr :: e.pexp_attributes} + in + (* using label "spreadProps" to distinguish from others *) + let label = Asttypes.Labelled "spreadProps" in + match p.Parser.token with + | Rbrace -> + Parser.next p; + Some (label, attrExpr) + | _ -> None) + | _ -> None) | _ -> None and parseJsxProps p = @@ -289052,6 +289219,10 @@ and parseBracedOrRecordExpr p = let loc = mkLoc startPos p.prevEndPos in let braces = makeBracesAttr loc in {expr with pexp_attributes = braces :: expr.pexp_attributes})) + | Question -> + let expr = parseRecordExpr ~startPos [] p in + Parser.expect Rbrace p; + expr | Uident _ | Lident _ -> ( let startToken = p.token in let valueOrConstructor = parseValueOrConstructor p in @@ -289073,7 +289244,9 @@ and parseBracedOrRecordExpr p = expr | Colon -> ( Parser.next p; + let optional = parseOptionalLabel p in let fieldExpr = parseExpr p in + let fieldExpr = makeExpressionOptional ~optional fieldExpr in match p.token with | Rbrace -> Parser.next p; @@ -289210,7 +289383,7 @@ and parseBracedOrRecordExpr p = let braces = makeBracesAttr loc in {expr with pexp_attributes = braces :: expr.pexp_attributes} -and parseRecordRowWithStringKey p = +and parseRecordExprRowWithStringKey p = match p.Parser.token with | String s -> ( let loc = mkLoc p.startPos p.endPos in @@ -289224,7 +289397,8 @@ and parseRecordRowWithStringKey p = | _ -> Some (field, Ast_helper.Exp.ident ~loc:field.loc field)) | _ -> None -and parseRecordRow p = +and parseRecordExprRow p = + let attrs = parseAttributes p in let () = match p.Parser.token with | Token.DotDotDot -> @@ -289239,23 +289413,39 @@ and parseRecordRow p = match p.Parser.token with | Colon -> Parser.next p; + let optional = parseOptionalLabel p in let fieldExpr = parseExpr p in + let fieldExpr = makeExpressionOptional ~optional fieldExpr in Some (field, fieldExpr) | _ -> - let value = Ast_helper.Exp.ident ~loc:field.loc field in + let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in let value = match startToken with | Uident _ -> removeModuleNameFromPunnedFieldValue value | _ -> value in Some (field, value)) + | Question -> ( + Parser.next p; + match p.Parser.token with + | Lident _ | Uident _ -> + let startToken = p.token in + let field = parseValuePath p in + let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in + let value = + match startToken with + | Uident _ -> removeModuleNameFromPunnedFieldValue value + | _ -> value + in + Some (field, makeExpressionOptional ~optional:true value) + | _ -> None) | _ -> None and parseRecordExprWithStringKeys ~startPos firstRow p = let rows = firstRow :: parseCommaDelimitedRegion ~grammar:Grammar.RecordRowsStringKey - ~closing:Rbrace ~f:parseRecordRowWithStringKey p + ~closing:Rbrace ~f:parseRecordExprRowWithStringKey p in let loc = mkLoc startPos p.endPos in let recordStrExpr = @@ -289267,7 +289457,7 @@ and parseRecordExprWithStringKeys ~startPos firstRow p = and parseRecordExpr ~startPos ?(spread = None) rows p = let exprs = parseCommaDelimitedRegion ~grammar:Grammar.RecordRows ~closing:Rbrace - ~f:parseRecordRow p + ~f:parseRecordExprRow p in let rows = List.concat [rows; exprs] in let () = @@ -290541,15 +290731,19 @@ and parseFieldDeclarationRegion p = | Lident _ -> let lident, loc = parseLident p in let name = Location.mkloc lident loc in + let optional = parseOptionalLabel p in let typ = match p.Parser.token with | Colon -> Parser.next p; parsePolyTypeExpr p | _ -> - Ast_helper.Typ.constr ~loc:name.loc {name with txt = Lident name.txt} [] + Ast_helper.Typ.constr ~loc:name.loc ~attrs + {name with txt = Lident name.txt} + [] in let loc = mkLoc startPos typ.ptyp_loc.loc_end in + let attrs = if optional then optionalAttr :: attrs else attrs in Some (Ast_helper.Type.field ~attrs ~loc ~mut name typ) | _ -> None @@ -294281,7 +294475,7 @@ and printRecordDeclRowDoc (name, mut, opt, arg) = Doc.group (Doc.concat [ - (if opt then Doc.text "@optional " else Doc.nil); + (if opt then Doc.text "?" else Doc.nil); (if mut then Doc.text "mutable " else Doc.nil); printIdentLike ~allowUident:false name; Doc.text ": "; diff --git a/lib/4.06.1/whole_compiler.ml.d b/lib/4.06.1/whole_compiler.ml.d index 6710b2af5e..7fb25a19ec 100644 --- a/lib/4.06.1/whole_compiler.ml.d +++ b/lib/4.06.1/whole_compiler.ml.d @@ -622,6 +622,7 @@ ../lib/4.06.1/whole_compiler.ml: ./napkin/res_reporting.ml ../lib/4.06.1/whole_compiler.ml: ./napkin/res_scanner.ml ../lib/4.06.1/whole_compiler.ml: ./napkin/res_scanner.mli +../lib/4.06.1/whole_compiler.ml: ./napkin/res_string.ml ../lib/4.06.1/whole_compiler.ml: ./napkin/res_token.ml ../lib/4.06.1/whole_compiler.ml: ./napkin/res_utf8.ml ../lib/4.06.1/whole_compiler.ml: ./napkin/res_utf8.mli diff --git a/syntax b/syntax index 0720d56a9a..0d219e7fd4 160000 --- a/syntax +++ b/syntax @@ -1 +1 @@ -Subproject commit 0720d56a9a8c00cf044636a9491956f352bcf729 +Subproject commit 0d219e7fd44f531acd2a42f42a89af24a28f0797 From f819ad6b7bc80cd4fee87cc702a9561401e67647 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 27 Jun 2022 21:40:52 +0200 Subject: [PATCH 3/3] Current syntax master 75124cc4fab93f0b8555f0eb922457da31a6451a --- syntax | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/syntax b/syntax index 0d219e7fd4..75124cc4fa 160000 --- a/syntax +++ b/syntax @@ -1 +1 @@ -Subproject commit 0d219e7fd44f531acd2a42f42a89af24a28f0797 +Subproject commit 75124cc4fab93f0b8555f0eb922457da31a6451a