diff --git a/CHANGELOG.md b/CHANGELOG.md index 602f717fff..2e6e4f8f00 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -22,6 +22,7 @@ - Added infra to modernise AST: theres' Parsetree, Parsetree0 (legacy), and conversion functions to keep compatibility with PPX. https://github.com/rescript-lang/rescript/pull/7185 - Ast cleanup: remove exp object and exp unreachable. https://github.com/rescript-lang/rescript/pull/7189 - Ast cleanup: explicit representation for optional record fields in types. https://github.com/rescript-lang/rescript/pull/7190 https://github.com/rescript-lang/rescript/pull/7191 +- AST cleanup: first-class expression and patterns for records with optional fields. https://github.com/rescript-lang/rescript/pull/7192 # 12.0.0-alpha.5 diff --git a/analysis/reanalyze/src/Arnold.ml b/analysis/reanalyze/src/Arnold.ml index e5fb0b7a7d..7c56cecaf8 100644 --- a/analysis/reanalyze/src/Arnold.ml +++ b/analysis/reanalyze/src/Arnold.ml @@ -947,7 +947,8 @@ module Compile = struct |> List.map (fun ( _desc, - (recordLabelDefinition : Typedtree.record_label_definition) ) + (recordLabelDefinition : Typedtree.record_label_definition), + _ ) -> match recordLabelDefinition with | Kept _typeExpr -> None diff --git a/analysis/reanalyze/src/DeadValue.ml b/analysis/reanalyze/src/DeadValue.ml index 0a242b22a2..ef3ab19018 100644 --- a/analysis/reanalyze/src/DeadValue.ml +++ b/analysis/reanalyze/src/DeadValue.ml @@ -192,7 +192,7 @@ let rec collectExpr super self (e : Typedtree.expression) = DeadType.addTypeReference ~posTo ~posFrom:locFrom.loc_start | Texp_record {fields} -> fields - |> Array.iter (fun (_, record_label_definition) -> + |> Array.iter (fun (_, record_label_definition, _) -> match record_label_definition with | Typedtree.Overridden (_, ({exp_loc} as e)) when exp_loc.loc_ghost -> @@ -219,7 +219,7 @@ let collectPattern : _ -> _ -> Typedtree.pattern -> Typedtree.pattern = (match pat.pat_desc with | Typedtree.Tpat_record (cases, _clodsedFlag) -> cases - |> List.iter (fun (_loc, {Types.lbl_loc = {loc_start = posTo}}, _pat) -> + |> List.iter (fun (_loc, {Types.lbl_loc = {loc_start = posTo}}, _pat, _) -> if !Config.analyzeTypes then DeadType.addTypeReference ~posFrom ~posTo) | _ -> ()); diff --git a/analysis/reanalyze/src/SideEffects.ml b/analysis/reanalyze/src/SideEffects.ml index d028c4b20f..d356ac23ae 100644 --- a/analysis/reanalyze/src/SideEffects.ml +++ b/analysis/reanalyze/src/SideEffects.ml @@ -75,7 +75,8 @@ and exprOptNoSideEffects eo = | None -> true | Some e -> e |> exprNoSideEffects -and fieldNoSideEffects ((_ld, rld) : _ * Typedtree.record_label_definition) = +and fieldNoSideEffects + ((_ld, rld, _) : _ * Typedtree.record_label_definition * _) = match rld with | Kept _typeExpr -> true | Overridden (_lid, e) -> e |> exprNoSideEffects diff --git a/analysis/src/CompletionExpressions.ml b/analysis/src/CompletionExpressions.ml index 8b5b233e35..e5858d1ee6 100644 --- a/analysis/src/CompletionExpressions.ml +++ b/analysis/src/CompletionExpressions.ml @@ -60,7 +60,7 @@ let rec traverseExpr (exp : Parsetree.expression) ~exprPath ~pos let fieldWithCursor = ref None in let fieldWithExprHole = ref None in fields - |> List.iter (fun (fname, exp) -> + |> List.iter (fun (fname, exp, _) -> match ( fname.Location.txt, exp.Parsetree.pexp_loc |> CursorPosition.classifyLoc ~pos ) @@ -72,7 +72,7 @@ let rec traverseExpr (exp : Parsetree.expression) ~exprPath ~pos | _ -> ()); let seenFields = fields - |> List.filter_map (fun (fieldName, _f) -> + |> List.filter_map (fun (fieldName, _f, _) -> match fieldName with | {Location.txt = Longident.Lident fieldName} -> Some fieldName | _ -> None) diff --git a/analysis/src/CompletionFrontEnd.ml b/analysis/src/CompletionFrontEnd.ml index f5957a8ed4..8cae05d0ca 100644 --- a/analysis/src/CompletionFrontEnd.ml +++ b/analysis/src/CompletionFrontEnd.ml @@ -473,7 +473,7 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor ?contextPath p | Ppat_record (fields, _) -> fields - |> List.iter (fun (fname, p) -> + |> List.iter (fun (fname, p, _) -> match fname with | {Location.txt = Longident.Lident fname} -> scopePattern @@ -879,7 +879,8 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor Pstr_eval ( { pexp_desc = - Pexp_record (({txt = Lident "from"}, fromExpr) :: _, _); + Pexp_record + (({txt = Lident "from"}, fromExpr, _) :: _, _); }, _ ); }; diff --git a/analysis/src/CompletionPatterns.ml b/analysis/src/CompletionPatterns.ml index 296e457c94..c7d4e1646e 100644 --- a/analysis/src/CompletionPatterns.ml +++ b/analysis/src/CompletionPatterns.ml @@ -112,7 +112,7 @@ and traversePattern (pat : Parsetree.pattern) ~patternPath ~locHasCursor let fieldWithCursor = ref None in let fieldWithPatHole = ref None in fields - |> List.iter (fun (fname, f) -> + |> List.iter (fun (fname, f, _) -> match ( fname.Location.txt, f.Parsetree.ppat_loc @@ -125,7 +125,7 @@ and traversePattern (pat : Parsetree.pattern) ~patternPath ~locHasCursor | _ -> ()); let seenFields = fields - |> List.filter_map (fun (fieldName, _f) -> + |> List.filter_map (fun (fieldName, _f, _) -> match fieldName with | {Location.txt = Longident.Lident fieldName} -> Some fieldName | _ -> None) diff --git a/analysis/src/DumpAst.ml b/analysis/src/DumpAst.ml index 0515dc9fcd..8e21853308 100644 --- a/analysis/src/DumpAst.ml +++ b/analysis/src/DumpAst.ml @@ -104,7 +104,7 @@ let rec printPattern pattern ~pos ~indentation = ^ addIndentation (indentation + 1) ^ "fields:\n" ^ (fields - |> List.map (fun ((Location.{txt} as loc), pat) -> + |> List.map (fun ((Location.{txt} as loc), pat, _) -> addIndentation (indentation + 2) ^ (loc |> printLocDenominatorLoc ~pos) ^ (Utils.flattenLongIdent txt |> ident |> str) @@ -245,7 +245,7 @@ and printExprItem expr ~pos ~indentation = ^ addIndentation (indentation + 1) ^ "fields:\n" ^ (fields - |> List.map (fun ((Location.{txt} as loc), expr) -> + |> List.map (fun ((Location.{txt} as loc), expr, _) -> addIndentation (indentation + 2) ^ (loc |> printLocDenominatorLoc ~pos) ^ (Utils.flattenLongIdent txt |> ident |> str) diff --git a/analysis/src/Hint.ml b/analysis/src/Hint.ml index 8537a447d4..b922dae2b5 100644 --- a/analysis/src/Hint.ml +++ b/analysis/src/Hint.ml @@ -44,7 +44,7 @@ let inlay ~path ~pos ~maxLength ~debug = match pat.ppat_desc with | Ppat_tuple pl -> pl |> List.iter processPattern | Ppat_record (fields, _) -> - fields |> List.iter (fun (_, p) -> processPattern p) + fields |> List.iter (fun (_, p, _) -> processPattern p) | Ppat_array fields -> fields |> List.iter processPattern | Ppat_var {loc} -> push loc Type | _ -> () diff --git a/analysis/src/ProcessCmt.ml b/analysis/src/ProcessCmt.ml index 55019b8e6f..6ea7ea699c 100644 --- a/analysis/src/ProcessCmt.ml +++ b/analysis/src/ProcessCmt.ml @@ -459,7 +459,7 @@ let rec forStructureItem ~env ~(exported : Exported.t) item = pats |> List.iter (fun p -> handlePattern [] p) | Tpat_or (p, _, _) -> handlePattern [] p | Tpat_record (items, _) -> - items |> List.iter (fun (_, _, p) -> handlePattern [] p) + items |> List.iter (fun (_, _, p, _) -> handlePattern [] p) | Tpat_lazy p -> handlePattern [] p | Tpat_variant (_, Some p, _) -> handlePattern [] p | Tpat_variant (_, None, _) | Tpat_any | Tpat_constant _ -> () diff --git a/analysis/src/ProcessExtra.ml b/analysis/src/ProcessExtra.ml index e153c76cba..1710d5fd32 100644 --- a/analysis/src/ProcessExtra.ml +++ b/analysis/src/ProcessExtra.ml @@ -237,7 +237,7 @@ let addForRecord ~env ~extra ~recordType items = | Tconstr (path, _args, _memo) -> let t = getTypeAtPath ~env path in items - |> List.iter (fun ({Asttypes.txt; loc}, _, _) -> + |> List.iter (fun ({Asttypes.txt; loc}, _, _, _) -> (* let name = Longident.last(txt); *) let name = handleConstructor txt in let nameLoc = Utils.endOfLocation loc (String.length name) in @@ -394,9 +394,9 @@ let expr ~env ~(extra : extra) (iter : Tast_iterator.iterator) | Texp_record {fields} -> addForRecord ~env ~extra ~recordType:expression.exp_type (fields |> Array.to_list - |> Utils.filterMap (fun (desc, item) -> + |> Utils.filterMap (fun (desc, item, opt) -> match item with - | Typedtree.Overridden (loc, _) -> Some (loc, desc, ()) + | Typedtree.Overridden (loc, _) -> Some (loc, desc, (), opt) | _ -> None)) | Texp_constant constant -> addLocItem extra expression.exp_loc (Constant constant) diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index 58564aa1fc..6a82b5d98b 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -226,7 +226,8 @@ let command ~debug ~emitter ~path = Ast_iterator.default_iterator.pat iterator p | Ppat_record (cases, _) -> cases - |> List.iter (fun (label, _) -> emitter |> emitRecordLabel ~label ~debug); + |> List.iter (fun (label, _, _) -> + emitter |> emitRecordLabel ~label ~debug); Ast_iterator.default_iterator.pat iterator p | Ppat_construct (name, _) -> emitter |> emitVariant ~name ~debug; @@ -309,7 +310,7 @@ let command ~debug ~emitter ~path = Ast_iterator.default_iterator.expr iterator e | Pexp_record (cases, _) -> cases - |> List.filter_map (fun ((label : Longident.t Location.loc), _) -> + |> List.filter_map (fun ((label : Longident.t Location.loc), _, _) -> match label.txt with | Longident.Lident s when not (Utils.isFirstCharUppercase s) -> Some label diff --git a/analysis/src/SignatureHelp.ml b/analysis/src/SignatureHelp.ml index c2e148de87..8d97c1b096 100644 --- a/analysis/src/SignatureHelp.ml +++ b/analysis/src/SignatureHelp.ml @@ -637,8 +637,10 @@ let signatureHelp ~path ~pos ~currentFile ~debug ~allowForConstructorPayloads = fields |> List.find_map (fun - (({loc; txt}, expr) : - Longident.t Location.loc * Parsetree.expression) + (({loc; txt}, expr, _) : + Longident.t Location.loc + * Parsetree.expression + * bool) -> if posBeforeCursor >= Pos.ofLexing loc.loc_start @@ -679,8 +681,8 @@ let signatureHelp ~path ~pos ~currentFile ~debug ~allowForConstructorPayloads = fields |> List.find_map (fun - (({loc; txt}, pat) : - Longident.t Location.loc * Parsetree.pattern) + (({loc; txt}, pat, _) : + Longident.t Location.loc * Parsetree.pattern * bool) -> if posBeforeCursor >= Pos.ofLexing loc.loc_start diff --git a/analysis/src/Xform.ml b/analysis/src/Xform.ml index b433054d9d..b765e511c9 100644 --- a/analysis/src/Xform.ml +++ b/analysis/src/Xform.ml @@ -78,10 +78,10 @@ module IfThenElse = struct | None -> None | Some patList -> Some (mkPat (Ppat_tuple patList))) | Pexp_record (items, None) -> ( - let itemToPat (x, e) = + let itemToPat (x, e, o) = match expToPat e with | None -> None - | Some p -> Some (x, p) + | Some p -> Some (x, p, o) in match listToPat ~itemToPat items with | None -> None diff --git a/compiler/common/pattern_printer.ml b/compiler/common/pattern_printer.ml index 2aad4b98d2..a0008a9626 100644 --- a/compiler/common/pattern_printer.ml +++ b/compiler/common/pattern_printer.ml @@ -32,7 +32,8 @@ let untype typed = | Tpat_record (subpatterns, closed_flag) -> let fields = List.map - (fun (_, lbl, p) -> (mknoloc (Longident.Lident lbl.lbl_name), loop p)) + (fun (_, lbl, p, opt) -> + (mknoloc (Longident.Lident lbl.lbl_name), loop p, opt)) subpatterns in mkpat (Ppat_record (fields, closed_flag)) diff --git a/compiler/frontend/ast_derive_js_mapper.ml b/compiler/frontend/ast_derive_js_mapper.ml index 43c4b30369..b845c43749 100644 --- a/compiler/frontend/ast_derive_js_mapper.ml +++ b/compiler/frontend/ast_derive_js_mapper.ml @@ -44,7 +44,8 @@ let handle_config (config : Parsetree.expression option) = ( Pexp_construct ({txt = Lident (("true" | "false") as x)}, None) | Pexp_ident {txt = Lident ("newType" as x)} ); - } ); + }, + _ ); ], None ) -> not (x = "false") @@ -193,7 +194,7 @@ let init () = txt = Longident.Lident txt; } in - (label, Exp.field exp_param label))) + (label, Exp.field exp_param label, false))) None); ] )) in @@ -205,7 +206,7 @@ let init () = let label = {Asttypes.loc; txt = Longident.Lident txt} in - (label, js_field exp_param label))) + (label, js_field exp_param label, false))) None in let from_js = diff --git a/compiler/frontend/ast_external_process.ml b/compiler/frontend/ast_external_process.ml index c728a5ed20..8dc5f3ff26 100644 --- a/compiler/frontend/ast_external_process.ml +++ b/compiler/frontend/ast_external_process.ml @@ -266,8 +266,8 @@ let parse_external_attributes (no_arguments : bool) (prim_name_check : string) fields |> List.iter (fun - ((l, exp) : - Longident.t Location.loc * Parsetree.expression) + ((l, exp, _) : + Longident.t Location.loc * Parsetree.expression * bool) -> match (l, exp.pexp_desc) with | ( {txt = Lident "from"; _}, @@ -293,8 +293,10 @@ let parse_external_attributes (no_arguments : bool) (prim_name_check : string) with_fields |> List.filter_map (fun - ((l, exp) : - Longident.t Location.loc * Parsetree.expression) + ((l, exp, _) : + Longident.t Location.loc + * Parsetree.expression + * bool) -> match exp.pexp_desc with | Pexp_constant (Pconst_string (s, _)) -> ( diff --git a/compiler/frontend/ast_tuple_pattern_flatten.ml b/compiler/frontend/ast_tuple_pattern_flatten.ml index 8958e3e871..c6efc507a4 100644 --- a/compiler/frontend/ast_tuple_pattern_flatten.ml +++ b/compiler/frontend/ast_tuple_pattern_flatten.ml @@ -65,7 +65,7 @@ let flattern_tuple_pattern_vb (self : Bs_ast_mapper.mapper) :: acc) | _ -> {pvb_pat; pvb_expr; pvb_loc = vb.pvb_loc; pvb_attributes} :: acc) | Ppat_record (lid_pats, _), Pexp_pack {pmod_desc = Pmod_ident id} -> - Ext_list.map_append lid_pats acc (fun (lid, pat) -> + Ext_list.map_append lid_pats acc (fun (lid, pat, _) -> match lid.txt with | Lident s -> { diff --git a/compiler/frontend/ast_uncurry_gen.ml b/compiler/frontend/ast_uncurry_gen.ml index a50b444976..f0eef18c5b 100644 --- a/compiler/frontend/ast_uncurry_gen.ml +++ b/compiler/frontend/ast_uncurry_gen.ml @@ -57,7 +57,9 @@ let to_method_callback loc (self : Bs_ast_mapper.mapper) label ( Nolabel, Exp.constraint_ ~loc (Exp.record ~loc - [({loc; txt = Ast_literal.Lid.hidden_field arity_s}, body)] + [ + ({loc; txt = Ast_literal.Lid.hidden_field arity_s}, body, false); + ] None) (Typ.constr ~loc { diff --git a/compiler/frontend/ast_util.ml b/compiler/frontend/ast_util.ml index 8053c71171..7a8765f503 100644 --- a/compiler/frontend/ast_util.ml +++ b/compiler/frontend/ast_util.ml @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression) list +type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression * bool) list let js_property loc obj (name : string) = Parsetree.Pexp_send (obj, {loc; txt = name}) @@ -31,7 +31,7 @@ let record_as_js_object loc (self : Bs_ast_mapper.mapper) (label_exprs : label_exprs) : Parsetree.expression_desc = let labels, args, arity = Ext_list.fold_right label_exprs ([], [], 0) - (fun ({txt; loc}, e) (labels, args, i) -> + (fun ({txt; loc}, e, _) (labels, args, i) -> match txt with | Lident x -> ( {Asttypes.loc; txt = x} :: labels, diff --git a/compiler/frontend/ast_util.mli b/compiler/frontend/ast_util.mli index 93c29f9f98..0f659d339a 100644 --- a/compiler/frontend/ast_util.mli +++ b/compiler/frontend/ast_util.mli @@ -28,7 +28,7 @@ - convert a uncuried application to normal *) -type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression) list +type label_exprs = (Longident.t Asttypes.loc * Parsetree.expression * bool) list val record_as_js_object : Location.t -> Bs_ast_mapper.mapper -> label_exprs -> Parsetree.expression_desc diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml index c430696860..2fda74cbab 100644 --- a/compiler/frontend/bs_ast_mapper.ml +++ b/compiler/frontend/bs_ast_mapper.ml @@ -69,6 +69,7 @@ type mapper = { with_constraint: mapper -> with_constraint -> with_constraint; } +let id x = x let map_fst f (x, y) = (f x, y) let map_snd f (x, y) = (x, f y) let map_tuple f1 f2 (x, y) = (f1 x, f2 y) @@ -331,7 +332,7 @@ module E = struct variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) | Pexp_record (l, eo) -> record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) + (List.map (map_tuple3 (map_loc sub) (sub.expr sub) id) l) (map_opt (sub.expr sub) eo) | Pexp_field (e, lid) -> field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) @@ -397,7 +398,7 @@ module P = struct | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) | Ppat_record (lpl, cf) -> record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) + (List.map (map_tuple3 (map_loc sub) (sub.pat sub) id) lpl) cf | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index fb6dfe9859..856b35abb9 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -99,7 +99,11 @@ module Pat : sig val construct : ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern val variant : ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern val record : - ?loc:loc -> ?attrs:attrs -> (lid * pattern) list -> closed_flag -> pattern + ?loc:loc -> + ?attrs:attrs -> + (lid * pattern * bool) list -> + closed_flag -> + pattern val array : ?loc:loc -> ?attrs:attrs -> pattern list -> pattern val or_ : ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern val constraint_ : ?loc:loc -> ?attrs:attrs -> pattern -> core_type -> pattern @@ -150,7 +154,7 @@ module Exp : sig val record : ?loc:loc -> ?attrs:attrs -> - (lid * expression) list -> + (lid * expression * bool) list -> expression option -> expression val field : ?loc:loc -> ?attrs:attrs -> expression -> lid -> expression diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index d5ae6d8901..b524431edf 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -302,7 +302,7 @@ module E = struct iter_opt (sub.expr sub) arg | Pexp_variant (_lab, eo) -> iter_opt (sub.expr sub) eo | Pexp_record (l, eo) -> - List.iter (iter_tuple (iter_loc sub) (sub.expr sub)) l; + List.iter (iter_tuple3 (iter_loc sub) (sub.expr sub) (fun _ -> ())) l; iter_opt (sub.expr sub) eo | Pexp_field (e, lid) -> sub.expr sub e; @@ -380,7 +380,7 @@ module P = struct iter_opt (sub.pat sub) p | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p | Ppat_record (lpl, _cf) -> - List.iter (iter_tuple (iter_loc sub) (sub.pat sub)) lpl + List.iter (iter_tuple3 (iter_loc sub) (sub.pat sub) (fun _ -> ())) lpl | Ppat_array pl -> List.iter (sub.pat sub) pl | Ppat_or (p1, p2) -> sub.pat sub p1; diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 96274ea2c5..4b1d4dca22 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -61,6 +61,7 @@ type mapper = { with_constraint: mapper -> with_constraint -> with_constraint; } +let id x = x let map_fst f (x, y) = (f x, y) let map_snd f (x, y) = (x, f y) let map_tuple f1 f2 (x, y) = (f1 x, f2 y) @@ -294,7 +295,7 @@ module E = struct variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) | Pexp_record (l, eo) -> record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) + (List.map (map_tuple3 (map_loc sub) (sub.expr sub) id) l) (map_opt (sub.expr sub) eo) | Pexp_field (e, lid) -> field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) @@ -360,7 +361,7 @@ module P = struct | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) | Ppat_record (lpl, cf) -> record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) + (List.map (map_tuple3 (map_loc sub) (sub.pat sub) (fun x -> x)) lpl) cf | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) @@ -534,7 +535,8 @@ module PpxContext = struct ( lid "cookies", make_list (make_pair make_string (fun x -> x)) - (StringMap.bindings !cookies) ) + (StringMap.bindings !cookies), + false ) let mk fields = ( {txt = "ocaml.ppx.context"; loc = Location.none}, @@ -543,11 +545,11 @@ module PpxContext = struct let make ~tool_name () = let fields = [ - (lid "tool_name", make_string tool_name); - (lid "include_dirs", make_list make_string !Clflags.include_dirs); - (lid "load_path", make_list make_string !Config.load_path); - (lid "open_modules", make_list make_string !Clflags.open_modules); - (lid "debug", make_bool !Clflags.debug); + (lid "tool_name", make_string tool_name, false); + (lid "include_dirs", make_list make_string !Clflags.include_dirs, false); + (lid "load_path", make_list make_string !Config.load_path, false); + (lid "open_modules", make_list make_string !Clflags.open_modules, false); + (lid "debug", make_bool !Clflags.debug, false); get_cookies (); ] in @@ -616,14 +618,14 @@ module PpxContext = struct in List.iter (function - | {txt = Lident name}, x -> field name x + | {txt = Lident name}, x, _ -> field name x | _ -> ()) fields let update_cookies fields = let fields = Ext_list.filter fields (function - | {txt = Lident "cookies"}, _ -> false + | {txt = Lident "cookies"}, _, _ -> false | _ -> true) in fields @ [get_cookies ()] diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index c12a88f2a9..76ba9e5392 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -301,7 +301,13 @@ module E = struct variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) | Pexp_record (l, eo) -> record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) + (Ext_list.map l (fun (lid, e) -> + let lid1 = map_loc sub lid in + let e1 = sub.expr sub e in + let optional, attrs = + Parsetree0.get_optional_attr e1.pexp_attributes + in + (lid1, {e1 with pexp_attributes = attrs}, optional))) (map_opt (sub.expr sub) eo) | Pexp_field (e, lid) -> field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) @@ -370,7 +376,13 @@ module P = struct | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) | Ppat_record (lpl, cf) -> record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) + (Ext_list.map lpl (fun (lid, p) -> + let lid1 = map_loc sub lid in + let p1 = sub.pat sub p in + let optional, attrs = + Parsetree0.get_optional_attr p1.ppat_attributes + in + (lid1, {p1 with ppat_attributes = attrs}, optional))) cf | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index d8e12e9c6f..2ad44c96b2 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -300,7 +300,13 @@ module E = struct variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) | Pexp_record (l, eo) -> record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) + (Ext_list.map l (fun (lid, e, optional) -> + let lid1 = map_loc sub lid in + let e1 = sub.expr sub e in + let attr = + Parsetree0.add_optional_attr ~optional e1.pexp_attributes + in + (lid1, {e1 with pexp_attributes = attr}))) (map_opt (sub.expr sub) eo) | Pexp_field (e, lid) -> field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) @@ -367,7 +373,13 @@ module P = struct | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) | Ppat_record (lpl, cf) -> record ~loc ~attrs - (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) + (Ext_list.map lpl (fun (lid, p, optional) -> + let lid1 = map_loc sub lid in + let p1 = sub.pat sub p in + let attr = + Parsetree0.add_optional_attr ~optional p1.ppat_attributes + in + (lid1, {p1 with ppat_attributes = attr}))) cf | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) diff --git a/compiler/ml/ast_payload.ml b/compiler/ml/ast_payload.ml index 8a9d37854d..a2142f3af0 100644 --- a/compiler/ml/ast_payload.ml +++ b/compiler/ml/ast_payload.ml @@ -209,10 +209,12 @@ let ident_or_record_as_config loc (x : t) : Ext_list.map label_exprs (fun u -> match u with | ( {txt = Lident name; loc}, - {Parsetree.pexp_desc = Pexp_ident {txt = Lident name2}} ) + {Parsetree.pexp_desc = Pexp_ident {txt = Lident name2}}, + _ ) when name2 = name -> ({Asttypes.txt = name; loc}, None) - | {txt = Lident name; loc}, y -> ({Asttypes.txt = name; loc}, Some y) + | {txt = Lident name; loc}, y, _ -> + ({Asttypes.txt = name; loc}, Some y) | _ -> Location.raise_errorf ~loc "Qualified label is not allowed") | Some _ -> unrecognized_config_record loc "`with` is not supported, discarding"; diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index 8c894832b8..bf4da4cfde 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -185,7 +185,7 @@ let rec add_pattern bv pat = add_opt add_pattern bv op | Ppat_record (pl, _) -> List.iter - (fun (lbl, p) -> + (fun (lbl, p, _) -> add bv lbl; add_pattern bv p) pl @@ -238,7 +238,7 @@ let rec add_expr bv exp = | Pexp_variant (_, opte) -> add_opt add_expr bv opte | Pexp_record (lblel, opte) -> List.iter - (fun (lbl, e) -> + (fun (lbl, e, _) -> add bv lbl; add_expr bv e) lblel; diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 63c5880ef1..89e7f6f477 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -84,9 +84,9 @@ let find_name (attr : Parsetree.attribute) = Some s | _ -> None -let blk_record (fields : (label * _) array) mut = +let blk_record (fields : (label * _ * _) array) mut = let all_labels_info = - Ext_array.map fields (fun (lbl, _) -> + Ext_array.map fields (fun (lbl, _, _) -> ( Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name, lbl.lbl_optional )) in @@ -95,7 +95,7 @@ let blk_record (fields : (label * _) array) mut = let blk_record_ext fields mutable_flag = let all_labels_info = Array.map - (fun ((lbl : label), _) -> + (fun ((lbl : label), _, _) -> Ext_list.find_def lbl.Types.lbl_attributes find_name lbl.lbl_name) fields in @@ -104,7 +104,7 @@ let blk_record_ext fields mutable_flag = let blk_record_inlined fields name num_nonconst ~tag ~attrs mutable_flag = let fields = Array.map - (fun ((lbl : label), _) -> + (fun ((lbl : label), _, _) -> ( Ext_list.find_def lbl.lbl_attributes find_name lbl.lbl_name, lbl.lbl_optional )) fields diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index cd0c26537f..cf163b461d 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -63,17 +63,17 @@ val find_name : Parsetree.attribute -> Asttypes.label option val tag_of_tag_info : tag_info -> int val mutable_flag_of_tag_info : tag_info -> mutable_flag val blk_record : - (Types.label_description * Typedtree.record_label_definition) array -> + (Types.label_description * Typedtree.record_label_definition * bool) array -> mutable_flag -> tag_info val blk_record_ext : - (Types.label_description * Typedtree.record_label_definition) array -> + (Types.label_description * Typedtree.record_label_definition * bool) array -> mutable_flag -> tag_info val blk_record_inlined : - (Types.label_description * Typedtree.record_label_definition) array -> + (Types.label_description * Typedtree.record_label_definition * bool) array -> string -> int -> tag:int -> diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 8ff391dbbf..2cd1a25db0 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -214,16 +214,16 @@ let ctx_matcher p = | Tpat_tuple args when List.length args = len -> (p, args @ rem) | Tpat_any -> (p, omegas @ rem) | _ -> raise NoMatch) - | Tpat_record (((_, lbl, _) :: _ as l), _) -> ( + | Tpat_record (((_, lbl, _, _) :: _ as l), _) -> ( (* Records are normalized *) let len = Array.length lbl.lbl_all in fun q rem -> match q.pat_desc with - | Tpat_record (((_, lbl', _) :: _ as l'), _) + | Tpat_record (((_, lbl', _, _) :: _ as l'), _) when Array.length lbl'.lbl_all = len -> let l' = all_record_args l' in - (p, List.fold_right (fun (_, _, p) r -> p :: r) l' rem) - | Tpat_any -> (p, List.fold_right (fun (_, _, p) r -> p :: r) l rem) + (p, List.fold_right (fun (_, _, p, _) r -> p :: r) l' rem) + | Tpat_any -> (p, List.fold_right (fun (_, _, p, _) r -> p :: r) l rem) | _ -> raise NoMatch) | Tpat_lazy omega -> ( fun q rem -> @@ -623,7 +623,7 @@ let rec extract_vars r p = | Tpat_alias (p, id, _) -> extract_vars (IdentSet.add id r) p | Tpat_tuple pats -> List.fold_left extract_vars r pats | Tpat_record (lpats, _) -> - List.fold_left (fun r (_, _, p) -> extract_vars r p) r lpats + List.fold_left (fun r (_, _, p, _) -> extract_vars r p) r lpats | Tpat_construct (_, _, pats) -> List.fold_left extract_vars r pats | Tpat_array pats -> List.fold_left extract_vars r pats | Tpat_variant (_, Some p, _) -> extract_vars r p @@ -1500,7 +1500,7 @@ let divide_tuple arity p ctx pm = let record_matching_line num_fields lbl_pat_list = let patv = Array.make num_fields omega in - List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; + List.iter (fun (_, lbl, pat, _) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list; Array.to_list patv let get_args_record num_fields p rem = @@ -1515,7 +1515,7 @@ let matcher_record num_fields p rem = | Tpat_or (_, _, _) -> raise OrPat | Tpat_any | Tpat_var _ -> record_matching_line num_fields [] @ rem | Tpat_record ([], _) when num_fields = 0 -> rem - | Tpat_record (((_, lbl, _) :: _ as lbl_pat_list), _) + | Tpat_record (((_, lbl, _, _) :: _ as lbl_pat_list), _) when Array.length lbl.lbl_all = num_fields -> record_matching_line num_fields lbl_pat_list @ rem | _ -> raise NoMatch @@ -2641,7 +2641,7 @@ and do_compile_matching repr partial ctx arg pmh = compile_no_test (divide_tuple (List.length patl) (normalize_pat pat)) ctx_combine repr partial ctx pm - | Tpat_record ((_, lbl, _) :: _, _) -> + | Tpat_record ((_, lbl, _, _) :: _, _) -> compile_no_test (divide_record lbl.lbl_all (normalize_pat pat)) ctx_combine repr partial ctx pm @@ -2721,7 +2721,8 @@ let find_in_pat pred = find_rec p | Tpat_tuple ps | Tpat_construct (_, _, ps) | Tpat_array ps -> List.exists find_rec ps - | Tpat_record (lpats, _) -> List.exists (fun (_, _, p) -> find_rec p) lpats + | Tpat_record (lpats, _) -> + List.exists (fun (_, _, p, _) -> find_rec p) lpats | Tpat_or (p, q, _) -> find_rec p || find_rec q | Tpat_constant _ | Tpat_var _ | Tpat_any | Tpat_variant (_, None, _) -> false @@ -2741,7 +2742,7 @@ let have_mutable_field p = match p with | Tpat_record (lps, _) -> List.exists - (fun (_, lbl, _) -> + (fun (_, lbl, _, _) -> match lbl.Types.lbl_mut with | Mutable -> true | Immutable -> false) diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index ad1c5b2d2a..bae9eec88f 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -158,7 +158,8 @@ let all_coherent column = _ ) -> false) | Tpat_tuple l1, Tpat_tuple l2 -> List.length l1 = List.length l2 - | Tpat_record ((_, lbl1, _) :: _, _), Tpat_record ((_, lbl2, _) :: _, _) -> + | ( Tpat_record ((_, lbl1, _, _) :: _, _), + Tpat_record ((_, lbl2, _, _) :: _, _) ) -> Array.length lbl1.lbl_all = Array.length lbl2.lbl_all | Tpat_any, _ | _, Tpat_any @@ -269,9 +270,9 @@ let records_args l1 l2 = let rec combine r1 r2 l1 l2 = match (l1, l2) with | [], [] -> (List.rev r1, List.rev r2) - | [], (_, _, p2) :: rem2 -> combine (omega :: r1) (p2 :: r2) [] rem2 - | (_, _, p1) :: rem1, [] -> combine (p1 :: r1) (omega :: r2) rem1 [] - | (_, lbl1, p1) :: rem1, (_, lbl2, p2) :: rem2 -> + | [], (_, _, p2, _) :: rem2 -> combine (omega :: r1) (p2 :: r2) [] rem2 + | (_, _, p1, _) :: rem1, [] -> combine (p1 :: r1) (omega :: r2) rem1 [] + | (_, lbl1, p1, _) :: rem1, (_, lbl2, p2, _) :: rem2 -> if lbl1.lbl_pos < lbl2.lbl_pos then combine (p1 :: r1) (omega :: r2) rem1 l2 else if lbl1.lbl_pos > lbl2.lbl_pos then @@ -407,12 +408,12 @@ let rec pretty_val ppf v = | Tpat_record (lvs, _) -> ( let filtered_lvs = Ext_list.filter lvs (function - | _, _, {pat_desc = Tpat_any} -> false (* do not show lbl=_ *) + | _, _, {pat_desc = Tpat_any}, _ -> false (* do not show lbl=_ *) | _ -> true) in match filtered_lvs with | [] -> fprintf ppf "_" - | (_, _lbl, _) :: _q -> + | (_, _lbl, _, _) :: _q -> let elision_mark _ = () in fprintf ppf "@[{%a%t}@]" pretty_lvals filtered_lvs elision_mark) | Tpat_array vs -> fprintf ppf "@[[%a]@]" (pretty_vals ",") vs @@ -451,8 +452,8 @@ and pretty_vals sep ppf = function and pretty_lvals ppf = function | [] -> () - | [(_, lbl, v)] -> fprintf ppf "%s: %a" lbl.lbl_name pretty_val v - | (_, lbl, v) :: rest -> + | [(_, lbl, v, _)] -> fprintf ppf "%s: %a" lbl.lbl_name pretty_val v + | (_, lbl, v, _) :: rest -> fprintf ppf "%s: %a,@ %a" lbl.lbl_name pretty_val v pretty_lvals rest let top_pretty ppf v = fprintf ppf "@[%a@]@?" pretty_val v @@ -508,24 +509,25 @@ let record_arg p = (* Raise Not_found when pos is not present in arg *) let get_field pos arg = - let _, _, p = List.find (fun (_, lbl, _) -> pos = lbl.lbl_pos) arg in + let _, _, p, _ = List.find (fun (_, lbl, _, _) -> pos = lbl.lbl_pos) arg in p let extract_fields omegas arg = List.map - (fun (_, lbl, _) -> try get_field lbl.lbl_pos arg with Not_found -> omega) + (fun (_, lbl, _, _) -> + try get_field lbl.lbl_pos arg with Not_found -> omega) omegas let all_record_args lbls = match lbls with - | (_, {lbl_all}, _) :: _ -> + | (_, {lbl_all}, _, opt) :: _ -> let t = Array.map - (fun lbl -> (mknoloc (Longident.Lident "?temp?"), lbl, omega)) + (fun lbl -> (mknoloc (Longident.Lident "?temp?"), lbl, omega, opt)) lbl_all in List.iter - (fun ((id, lbl, pat) as x) -> + (fun ((id, lbl, pat, o) as x) -> let lbl_is_optional () = match lbl.lbl_repres with | Record_inlined _ -> false @@ -538,7 +540,7 @@ let all_record_args lbls = _, [({pat_desc = Tpat_constant _} as c)] ) when lbl_is_optional () -> - (id, lbl, c) + (id, lbl, c, o) | Tpat_construct ( {txt = Longident.Ldot (Longident.Lident "*predef*", "Some")}, _, @@ -555,7 +557,7 @@ let all_record_args lbls = when Ast_untagged_variants.is_nullary_variant cstr.cd_args -> let _, tag = Ast_untagged_variants.get_cstr_loc_tag cstr in if Ast_untagged_variants.tag_can_be_undefined tag then x - else (id, lbl, pat_construct) + else (id, lbl, pat_construct, o) | Some cstr -> ( match Ast_untagged_variants.get_block_type ~env:pat.pat_env cstr @@ -564,7 +566,7 @@ let all_record_args lbls = when not (Ast_untagged_variants.block_type_can_be_undefined block_type) -> - (id, lbl, pat_construct) + (id, lbl, pat_construct, o) | _ -> x)) | _ -> x in @@ -617,7 +619,8 @@ let rec normalize_pat q = | Tpat_record (largs, closed) -> make_pat (Tpat_record - (List.map (fun (lid, lbl, _) -> (lid, lbl, omega)) largs, closed)) + ( List.map (fun (lid, lbl, _, opt) -> (lid, lbl, omega, opt)) largs, + closed )) q.pat_type q.pat_env | Tpat_lazy _ -> make_pat (Tpat_lazy omega) q.pat_type q.pat_env | Tpat_or _ -> fatal_error "Parmatch.normalize_pat" @@ -640,11 +643,11 @@ let discr_pat q pss = | (({pat_desc = Tpat_record (largs, closed)} as p) :: _) :: pss -> let new_omegas = List.fold_right - (fun (lid, lbl, _) r -> + (fun (lid, lbl, _, opt) r -> try let _ = get_field lbl.lbl_pos r in r - with Not_found -> (lid, lbl, omega) :: r) + with Not_found -> (lid, lbl, omega, opt) :: r) largs (record_arg acc) in acc_pat @@ -680,15 +683,15 @@ let do_set_args erase_mutable q r = make_pat (Tpat_record ( List.map2 - (fun (lid, lbl, _) arg -> + (fun (lid, lbl, _, opt) arg -> if erase_mutable && match lbl.lbl_mut with | Mutable -> true | Immutable -> false - then (lid, lbl, omega) - else (lid, lbl, arg)) + then (lid, lbl, omega, opt) + else (lid, lbl, arg, opt)) omegas args, closed )) q.pat_type q.pat_env @@ -981,7 +984,8 @@ let pats_of_type ?(always = false) env ty = let labels = snd (Env.find_type_descrs path env) in let fields = List.map - (fun ld -> (mknoloc (Longident.Lident "?pat_of_label?"), ld, omega)) + (fun ld -> + (mknoloc (Longident.Lident "?pat_of_label?"), ld, omega, false)) labels in [make_pat (Tpat_record (fields, Closed)) ty env] @@ -1187,7 +1191,7 @@ let rec has_instance p = | Tpat_or (p1, p2, _) -> has_instance p1 || has_instance p2 | Tpat_construct (_, _, ps) | Tpat_tuple ps | Tpat_array ps -> has_instances ps - | Tpat_record (lps, _) -> has_instances (List.map (fun (_, _, x) -> x) lps) + | Tpat_record (lps, _) -> has_instances (List.map (fun (_, _, x, _) -> x) lps) | Tpat_lazy p -> has_instance p and has_instances = function @@ -1861,11 +1865,14 @@ and record_lubs l1 l2 = match (l1, l2) with | [], _ -> l2 | _, [] -> l1 - | (lid1, lbl1, p1) :: rem1, (lid2, lbl2, p2) :: rem2 -> - if lbl1.lbl_pos < lbl2.lbl_pos then (lid1, lbl1, p1) :: lub_rec rem1 l2 + | (lid1, lbl1, p1, o1) :: rem1, (lid2, lbl2, p2, o2) :: rem2 -> + if lbl1.lbl_pos < lbl2.lbl_pos then + (lid1, lbl1, p1, o1) :: lub_rec rem1 l2 else if lbl2.lbl_pos < lbl1.lbl_pos then - (lid2, lbl2, p2) :: lub_rec l1 rem2 - else (lid1, lbl1, lub p1 p2) :: lub_rec rem1 rem2 + (lid2, lbl2, p2, o2) :: lub_rec l1 rem2 + else + let o = if o1 = o2 then o1 else raise Empty in + (lid1, lbl1, lub p1 p2, o) :: lub_rec rem1 rem2 in lub_rec l1 l2 @@ -2003,10 +2010,10 @@ module Conv = struct | Tpat_record (subpatterns, _closed_flag) -> let fields = List.map - (fun (_, lbl, p) -> + (fun (_, lbl, p, optional) -> let id = fresh lbl.lbl_name in Hashtbl.add labels id lbl; - (mknoloc (Longident.Lident id), loop p)) + (mknoloc (Longident.Lident id), loop p, optional)) subpatterns in mkpat (Ppat_record (fields, Open)) @@ -2139,7 +2146,7 @@ let rec collect_paths_from_pat r p = | Tpat_construct (_, {cstr_tag = Cstr_extension _}, ps) -> List.fold_left collect_paths_from_pat r ps | Tpat_record (lps, _) -> - List.fold_left (fun r (_, _, p) -> collect_paths_from_pat r p) r lps + List.fold_left (fun r (_, _, p, _) -> collect_paths_from_pat r p) r lps | Tpat_variant (_, Some p, _) | Tpat_alias (p, _, _) -> collect_paths_from_pat r p | Tpat_or (p1, p2, _) -> @@ -2258,7 +2265,9 @@ let inactive ~partial pat = List.for_all (fun p -> loop p) ps | Tpat_alias (p, _, _) | Tpat_variant (_, Some p, _) -> loop p | Tpat_record (ldps, _) -> - List.for_all (fun (_, lbl, p) -> lbl.lbl_mut = Immutable && loop p) ldps + List.for_all + (fun (_, lbl, p, _) -> lbl.lbl_mut = Immutable && loop p) + ldps | Tpat_or (p, q, _) -> loop p && loop q in loop pat diff --git a/compiler/ml/parmatch.mli b/compiler/ml/parmatch.mli index c3fd33ea68..a5ca1d436c 100644 --- a/compiler/ml/parmatch.mli +++ b/compiler/ml/parmatch.mli @@ -31,8 +31,8 @@ val omegas : int -> pattern list val omega_list : 'a list -> pattern list val normalize_pat : pattern -> pattern val all_record_args : - (Longident.t loc * label_description * pattern) list -> - (Longident.t loc * label_description * pattern) list + (Longident.t loc * label_description * pattern * bool) list -> + (Longident.t loc * label_description * pattern * bool) list val const_compare : constant -> constant -> int val le_pat : pattern -> pattern -> bool diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index f4841e5e24..3da8d64769 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -183,7 +183,8 @@ and pattern_desc = (* `A (None) `A P (Some P) *) - | Ppat_record of (Longident.t loc * pattern) list * closed_flag + | Ppat_record of + (Longident.t loc * pattern * bool (* optional *)) list * closed_flag (* { l1=P1; ...; ln=Pn } (flag = Closed) { l1=P1; ...; ln=Pn; _} (flag = Open) @@ -260,7 +261,9 @@ and expression_desc = (* `A (None) `A E (Some E) *) - | Pexp_record of (Longident.t loc * expression) list * expression option + | Pexp_record of + (Longident.t loc * expression * bool (* optional *)) list + * expression option (* { l1=P1; ...; ln=Pn } (None) { E0 with l1=P1; ...; ln=Pn } (Some E0) diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml index a3a8b36d58..56eab619d6 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -396,15 +396,16 @@ and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = | Ppat_type li -> pp f "#%a" longident_loc li | Ppat_record (l, closed) -> - let longident_x_pattern f (li, p) = + let longident_x_pattern f (li, p, opt) = + let opt_str = if opt then "?" else "" in match (li,p) with | ({txt=Lident s;_ }, {ppat_desc=Ppat_var {txt;_}; ppat_attributes=[]; _}) when s = txt -> - pp f "@[<2>%a@]" longident_loc li + pp f "@[<2>%a%s@]" longident_loc li opt_str | _ -> - pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p + pp f "@[<2>%a%s@;=@;%a@]" longident_loc li opt_str (pattern1 ctxt) p in begin match closed with | Closed -> @@ -712,13 +713,14 @@ and simple_expr ctxt f x = (core_type ctxt) ct | Pexp_variant (l, None) -> pp f "`%s" l | Pexp_record (l, eo) -> - let longident_x_expression f ( li, e) = + let longident_x_expression f ( li, e, opt) = + let opt_str = if opt then "?" else "" in match e with | {pexp_desc=Pexp_ident {txt;_}; pexp_attributes=[]; _} when li.txt = txt -> - pp f "@[%a@]" longident_loc li + pp f "@[%a%s@]" longident_loc li opt_str | _ -> - pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e + pp f "@[%a@;=@;%s%a@]" longident_loc li opt_str (simple_expr ctxt) e in pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *) (option ~last:" with@;" (simple_expr ctxt)) eo diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index a60cbd8ab7..0977e7f8a2 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -637,8 +637,8 @@ and label_decl i ppf {pld_name; pld_mutable; pld_type; pld_loc; pld_attributes} line (i + 1) ppf "%a" fmt_string_loc pld_name; core_type (i + 1) ppf pld_type -and longident_x_pattern i ppf (li, p) = - line i ppf "%a\n" fmt_longident_loc li; +and longident_x_pattern i ppf (li, p, opt) = + line i ppf "%a%s\n" fmt_longident_loc li (if opt then "?" else ""); pattern (i + 1) ppf p and case i ppf {pc_lhs; pc_guard; pc_rhs} = @@ -661,8 +661,8 @@ and string_x_expression i ppf (s, e) = line i ppf " %a\n" fmt_string_loc s; expression (i + 1) ppf e -and longident_x_expression i ppf (li, e) = - line i ppf "%a\n" fmt_longident_loc li; +and longident_x_expression i ppf (li, e, opt) = + line i ppf "%a%s\n" fmt_longident_loc li (if opt then "?" else ""); expression (i + 1) ppf e and label_x_expression i ppf (l, e) = diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index 874f390ec0..6303411246 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -634,8 +634,8 @@ and label_decl i ppf line (i + 1) ppf "%a" fmt_ident ld_id; core_type (i + 1) ppf ld_type -and longident_x_pattern i ppf (li, _, p) = - line i ppf "%a\n" fmt_longident li; +and longident_x_pattern i ppf (li, _, p, opt) = + line i ppf "%a%s\n" fmt_longident li (if opt then "?" else ""); pattern (i + 1) ppf p and case i ppf {c_lhs; c_guard; c_rhs} = @@ -655,10 +655,10 @@ and value_binding i ppf x = expression (i + 1) ppf x.vb_expr and record_field i ppf = function - | _, Overridden (li, e) -> - line i ppf "%a\n" fmt_longident li; + | _, Overridden (li, e), opt -> + line i ppf "%a%s\n" fmt_longident li (if opt then "?" else ""); expression (i + 1) ppf e - | _, Kept _ -> line i ppf "" + | _, Kept _, _ -> line i ppf "" and label_x_expression i ppf (l, e) = line i ppf "\n"; diff --git a/compiler/ml/rec_check.ml b/compiler/ml/rec_check.ml index 889056073e..a88b27ed7f 100644 --- a/compiler/ml/rec_check.ml +++ b/compiler/ml/rec_check.ml @@ -157,7 +157,7 @@ let rec pattern_variables : Typedtree.pattern -> Ident.t list = | Tpat_variant (_, Some pat, _) -> pattern_variables pat | Tpat_variant (_, None, _) -> [] | Tpat_record (fields, _) -> - List.concat (List.map (fun (_, _, p) -> pattern_variables p) fields) + List.concat (List.map (fun (_, _, p, _) -> pattern_variables p) fields) | Tpat_array pats -> List.concat (List.map pattern_variables pats) | Tpat_or (l, r, _) -> pattern_variables l @ pattern_variables r | Tpat_lazy p -> pattern_variables p @@ -264,8 +264,8 @@ let rec expression : Env.env -> Typedtree.expression -> Use.t = | Record_regular | Record_inlined _ | Record_extension -> Use.guard in let field env = function - | _, Kept _ -> Use.empty - | _, Overridden (_, e) -> expression env e + | _, Kept _, _ -> Use.empty + | _, Overridden (_, e), _ -> expression env e in Use.join (use (array field env es)) (option expression env eo) | Texp_ifthenelse (cond, ifso, ifnot) -> @@ -458,7 +458,7 @@ let check_recursive_bindings valbinds = Ext_list.iter valbinds (fun {vb_expr} -> match vb_expr.exp_desc with | Texp_record - {fields = [|(_, Overridden (_, {exp_desc = Texp_function _}))|]} + {fields = [|(_, Overridden (_, {exp_desc = Texp_function _}), _)|]} | Texp_function _ -> () (*TODO: add uncurried function too*) diff --git a/compiler/ml/tast_iterator.ml b/compiler/ml/tast_iterator.ml index 481db7ef26..ce947feb3e 100644 --- a/compiler/ml/tast_iterator.ml +++ b/compiler/ml/tast_iterator.ml @@ -131,7 +131,7 @@ let pat sub {pat_extra; pat_desc; pat_env; _} = | Tpat_tuple l -> List.iter (sub.pat sub) l | Tpat_construct (_, _, l) -> List.iter (sub.pat sub) l | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po - | Tpat_record (l, _) -> List.iter (fun (_, _, i) -> sub.pat sub i) l + | Tpat_record (l, _) -> List.iter (fun (_, _, i, _) -> sub.pat sub i) l | Tpat_array l -> List.iter (sub.pat sub) l | Tpat_or (p1, p2, _) -> sub.pat sub p1; @@ -172,8 +172,8 @@ let expr sub {exp_extra; exp_desc; exp_env; _} = | Texp_record {fields; extended_expression; _} -> Array.iter (function - | _, Kept _ -> () - | _, Overridden (_, exp) -> sub.expr sub exp) + | _, Kept _, _ -> () + | _, Overridden (_, exp), _ -> sub.expr sub exp) fields; Option.iter (sub.expr sub) extended_expression | Texp_field (exp, _, _) -> sub.expr sub exp diff --git a/compiler/ml/tast_mapper.ml b/compiler/ml/tast_mapper.ml index b5622baacc..8d21406bd4 100644 --- a/compiler/ml/tast_mapper.ml +++ b/compiler/ml/tast_mapper.ml @@ -59,6 +59,7 @@ type mapper = { let id x = x let tuple2 f1 f2 (x, y) = (f1 x, f2 y) let tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) +let tuple4 f1 f2 f3 f4 (x, y, z, w) = (f1 x, f2 y, f3 z, f4 w) let opt f = function | None -> None | Some x -> Some (f x) @@ -173,7 +174,7 @@ let pat sub x = Tpat_construct (loc, cd, List.map (sub.pat sub) l) | Tpat_variant (l, po, rd) -> Tpat_variant (l, opt (sub.pat sub) po, rd) | Tpat_record (l, closed) -> - Tpat_record (List.map (tuple3 id id (sub.pat sub)) l, closed) + Tpat_record (List.map (tuple4 id id (sub.pat sub) id) l, closed) | Tpat_array l -> Tpat_array (List.map (sub.pat sub) l) | Tpat_or (p1, p2, rd) -> Tpat_or (sub.pat sub p1, sub.pat sub p2, rd) | Tpat_alias (p, id, s) -> Tpat_alias (sub.pat sub p, id, s) @@ -215,9 +216,9 @@ let expr sub x = let fields = Array.map (function - | label, Kept t -> (label, Kept t) - | label, Overridden (lid, exp) -> - (label, Overridden (lid, sub.expr sub exp))) + | label, Kept t, o -> (label, Kept t, o) + | label, Overridden (lid, exp), o -> + (label, Overridden (lid, sub.expr sub exp), o)) fields in Texp_record diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index cbba44f1b5..2e1afdfa29 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -1143,7 +1143,8 @@ and transl_let rec_flag pat_expr_list body = and transl_record loc env fields repres opt_init_expr = match (opt_init_expr, repres, fields) with - | None, Record_unboxed _, [|({lbl_name; lbl_loc}, Overridden (_, expr))|] -> + | None, Record_unboxed _, [|({lbl_name; lbl_loc}, Overridden (_, expr), _)|] + -> (* ReScript uncurried encoding *) let loc = lbl_loc in let lambda = transl_exp expr in @@ -1158,7 +1159,9 @@ and transl_record loc env fields repres opt_init_expr = else lambda | _ -> ( let size = Array.length fields in - let optional = Ext_array.exists fields (fun (ld, _) -> ld.lbl_optional) in + let optional = + Ext_array.exists fields (fun (ld, _, _) -> ld.lbl_optional) + in (* Determine if there are "enough" fields (only relevant if this is a functional-style record update *) let no_init = @@ -1177,7 +1180,7 @@ and transl_record loc env fields repres opt_init_expr = let init_id = Ident.create "init" in let lv = Array.mapi - (fun i (lbl, definition) -> + (fun i (lbl, definition, _) -> match definition with | Kept _ -> let access = @@ -1195,7 +1198,7 @@ and transl_record loc env fields repres opt_init_expr = in let ll = Array.to_list lv in let mut = - if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Mutable) fields then + if Array.exists (fun (lbl, _, _) -> lbl.lbl_mut = Mutable) fields then Mutable else Immutable in @@ -1237,7 +1240,7 @@ and transl_record loc env fields repres opt_init_expr = | _ -> assert false) | Record_extension -> let path = - let label, _ = fields.(0) in + let label, _, _ = fields.(0) in match label.lbl_res.desc with | Tconstr (p, _, _) -> p | _ -> assert false @@ -1254,7 +1257,7 @@ and transl_record loc env fields repres opt_init_expr = (* Take a shallow copy of the init record, then mutate the fields of the copy *) let copy_id = Ident.create "newrecord" in - let update_field cont (lbl, definition) = + let update_field cont (lbl, definition, _opt) = match definition with | Kept _type -> cont | Overridden (_lid, expr) -> diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index b8481997a2..f9085caaa4 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -154,7 +154,7 @@ let iter_expression f e = | Pexp_construct (_, eo) | Pexp_variant (_, eo) -> may expr eo | Pexp_record (iel, eo) -> may expr eo; - List.iter (fun (_, e) -> expr e) iel + List.iter (fun (_, e, _) -> expr e) iel | Pexp_open (_, _, e) | Pexp_newtype (_, e) | Pexp_poly (e, _) @@ -299,14 +299,13 @@ let extract_concrete_variant env ty = let label_is_optional ld = ld.lbl_optional -let check_optional_attr env ld attrs loc = +let check_optional_attr env ld optional loc = let check_redundant () = if not (label_is_optional ld) then raise (Error (loc, env, Field_not_optional (ld.lbl_name, ld.lbl_res))); true in - Ext_list.exists attrs (fun ({txt}, _) -> - txt = "res.optional" && check_redundant ()) + optional && check_redundant () (* unification inside type_pat*) let unify_pat_types loc env ty ty' = @@ -493,11 +492,11 @@ let rec build_as_type env p = row_closed = false; }) | Tpat_record (lpl, _) -> - let lbl = snd3 (List.hd lpl) in + let lbl = snd4 (List.hd lpl) in if lbl.lbl_private = Private then p.pat_type else let ty = newvar () in - let ppl = List.map (fun (_, l, p) -> (l.lbl_pos, p)) lpl in + let ppl = List.map (fun (_, l, p, _) -> (l.lbl_pos, p)) lpl in let do_label lbl = let _, ty_arg, ty_res = instance_label false lbl in unify_pat env {p with pat_type = ty} ty_res; @@ -989,7 +988,7 @@ let disambiguate_label_by_ids closed ids labels = (* Only issue warnings once per record constructor/pattern *) let disambiguate_lid_a_list loc closed env opath lid_a_list = - let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in + let ids = List.map (fun (lid, _, _) -> Longident.last lid.txt) lid_a_list in let w_amb = ref [] in let warn loc msg = let open Warnings in @@ -1020,12 +1019,12 @@ let disambiguate_lid_a_list loc closed env opath lid_a_list = (* will fail later *) in let lbl_a_list = - List.map (fun (lid, a) -> (lid, process_label lid, a)) lid_a_list + List.map (fun (lid, a, opt) -> (lid, process_label lid, a, opt)) lid_a_list in (match List.rev !w_amb with | (_, types) :: _ as amb -> let paths = - List.map (fun (_, lbl, _) -> Label.get_type_path lbl) lbl_a_list + List.map (fun (_, lbl, _, _) -> Label.get_type_path lbl) lbl_a_list in let path = List.hd paths in if List.for_all (compare_type_path env path) (List.tl paths) then @@ -1041,7 +1040,7 @@ let disambiguate_lid_a_list loc closed env opath lid_a_list = let rec find_record_qual = function | [] -> None - | ({txt = Longident.Ldot (modname, _)}, _) :: _ -> Some modname + | ({txt = Longident.Ldot (modname, _)}, _, _) :: _ -> Some modname | _ :: rest -> find_record_qual rest let map_fold_cont f xs k = @@ -1054,14 +1053,14 @@ let map_fold_cont f xs k = let type_label_a_list ?labels loc closed env type_lbl_a opath lid_a_list k = let lbl_a_list = match (lid_a_list, labels) with - | ({txt = Longident.Lident s}, _) :: _, Some labels + | ({txt = Longident.Lident s}, _, _) :: _, Some labels when Hashtbl.mem labels s -> (* Special case for rebuilt syntax trees *) List.map (function - | lid, a -> ( + | lid, a, opt -> ( match lid.txt with - | Longident.Lident s -> (lid, Hashtbl.find labels s, a) + | Longident.Lident s -> (lid, Hashtbl.find labels s, a, opt) | _ -> assert false)) lid_a_list | _ -> @@ -1070,10 +1069,10 @@ let type_label_a_list ?labels loc closed env type_lbl_a opath lid_a_list k = | None -> lid_a_list | Some modname -> List.map - (fun ((lid, a) as lid_a) -> + (fun ((lid, a, opt) as lid_a) -> match lid.txt with | Longident.Lident s -> - ({lid with txt = Longident.Ldot (modname, s)}, a) + ({lid with txt = Longident.Ldot (modname, s)}, a, opt) | _ -> lid_a) lid_a_list in @@ -1082,7 +1081,7 @@ let type_label_a_list ?labels loc closed env type_lbl_a opath lid_a_list k = (* Invariant: records are sorted in the typed tree *) let lbl_a_list = List.sort - (fun (_, lbl1, _) (_, lbl2, _) -> compare lbl1.lbl_pos lbl2.lbl_pos) + (fun (_, lbl1, _, _) (_, lbl2, _, _) -> compare lbl1.lbl_pos lbl2.lbl_pos) lbl_a_list in map_fold_cont type_lbl_a lbl_a_list k @@ -1094,10 +1093,10 @@ let check_recordpat_labels ~get_jsx_component_error_info loc lbl_pat_list closed = match lbl_pat_list with | [] -> () (* should not happen *) - | ((l : Longident.t loc), label1, _) :: _ -> + | ((l : Longident.t loc), label1, _, _) :: _ -> let all = label1.lbl_all in let defined = Array.make (Array.length all) false in - let check_defined (_, label, _) = + let check_defined (_, label, _, _) = if defined.(label.lbl_pos) then raise (Error @@ -1490,9 +1489,9 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp get_jsx_component_error_info ~extract_concrete_typedecl opath !env record_ty in - let process_optional_label (ld, pat) = + let process_optional_label (ld, pat, optional) = let exp_optional_attr = - check_optional_attr !env ld pat.ppat_attributes pat.ppat_loc + check_optional_attr !env ld optional pat.ppat_loc in let is_from_pamatch = match pat.ppat_desc with @@ -1506,8 +1505,8 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp Ast_helper.Pat.construct ~loc:pat.ppat_loc lid (Some pat) else pat in - let type_label_pat (label_lid, label, sarg) k = - let sarg = process_optional_label (label, sarg) in + let type_label_pat (label_lid, label, sarg, opt) k = + let sarg = process_optional_label (label, sarg, opt) in begin_def (); let vars, ty_arg, ty_res = instance_label false label in if vars = [] then end_def (); @@ -1527,7 +1526,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp if List.exists instantiated vars then raise (Error (label_lid.loc, !env, Polymorphic_label label_lid.txt))); - k (label_lid, label, arg)) + k (label_lid, label, arg, opt)) in let k' k lbl_pat_list = check_recordpat_labels ~get_jsx_component_error_info loc lbl_pat_list @@ -1822,7 +1821,7 @@ let rec is_nonexpansive exp = | Texp_variant (_, arg) -> is_nonexpansive_opt arg | Texp_record {fields; extended_expression} -> Array.for_all - (fun (lbl, definition) -> + (fun (lbl, definition, _) -> match definition with | Overridden (_, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp | Kept _ -> true) @@ -2087,7 +2086,7 @@ let iter_ppat f p = | Ppat_constraint (p, _) | Ppat_lazy p -> f p - | Ppat_record (args, _flag) -> List.iter (fun (_, p) -> f p) args + | Ppat_record (args, _flag) -> List.iter (fun (_, p, _) -> f p) args let contains_polymorphic_variant p = let rec loop p = @@ -2167,7 +2166,7 @@ let duplicate_ident_types caselist env = (* note: check_duplicates would better be implemented in type_label_a_list directly *) let rec check_duplicates ~get_jsx_component_error_info loc env = function - | (_, lbl1, _) :: ((l : Longident.t loc), lbl2, _) :: _ + | (_, lbl1, _, _) :: ((l : Longident.t loc), lbl2, _, _) :: _ when lbl1.lbl_pos = lbl2.lbl_pos -> raise (Error @@ -2289,15 +2288,13 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp unify_exp ?type_clash_context env (re exp) (instance env ty_expected); exp in - let process_optional_label (id, ld, e) = - let exp_optional_attr = - check_optional_attr env ld e.pexp_attributes e.pexp_loc - in + let process_optional_label (id, ld, e, opt) = + let exp_optional_attr = check_optional_attr env ld opt e.pexp_loc in if label_is_optional ld && not exp_optional_attr then let lid = mknoloc Longident.(Ldot (Lident "*predef*", "Some")) in let e = Ast_helper.Exp.construct ~loc:e.pexp_loc lid (Some e) in - (id, ld, e) - else (id, ld, e) + (id, ld, e, opt) + else (id, ld, e, opt) in match sexp.pexp_desc with | Pexp_ident lid -> @@ -2630,7 +2627,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp check_duplicates ~get_jsx_component_error_info loc env lbl_exp_list; let label_descriptions, representation = match (lbl_exp_list, repr_opt) with - | ( (_, {lbl_all = label_descriptions; lbl_repres = representation}, _) + | ( (_, {lbl_all = label_descriptions; lbl_repres = representation}, _, _) :: _, _ ) -> (label_descriptions, representation) @@ -2657,12 +2654,14 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp let labels_missing = ref [] in let label_definitions = let matching_label lbl = - List.find (fun (_, lbl', _) -> lbl'.lbl_pos = lbl.lbl_pos) lbl_exp_list + List.find + (fun (_, lbl', _, _) -> lbl'.lbl_pos = lbl.lbl_pos) + lbl_exp_list in Array.map (fun lbl -> match matching_label lbl with - | lid, _lbl, lbl_exp -> Overridden (lid, lbl_exp) + | lid, _lbl, lbl_exp, _ -> Overridden (lid, lbl_exp) | exception Not_found -> if not (label_is_optional lbl) then labels_missing := lbl.lbl_name :: !labels_missing; @@ -2682,7 +2681,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp } )); let fields = Array.map2 - (fun descr def -> (descr, def)) + (fun descr def -> (descr, def, false)) label_descriptions label_definitions in re @@ -2736,16 +2735,18 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp unify_exp_types loc env ty_record (instance env ty_expected); check_duplicates ~get_jsx_component_error_info loc env lbl_exp_list; let opt_exp, label_definitions = - let _lid, lbl, _lbl_exp = List.hd lbl_exp_list in + let _lid, lbl, _lbl_exp, _opt = List.hd lbl_exp_list in let matching_label lbl = - List.find (fun (_, lbl', _) -> lbl'.lbl_pos = lbl.lbl_pos) lbl_exp_list + List.find + (fun (_, lbl', _, _) -> lbl'.lbl_pos = lbl.lbl_pos) + lbl_exp_list in let ty_exp = instance env exp.exp_type in let unify_kept lbl = let _, ty_arg1, ty_res1 = instance_label false lbl in unify_exp_types exp.exp_loc env ty_exp ty_res1; match matching_label lbl with - | lid, _lbl, lbl_exp -> + | lid, _lbl, lbl_exp, _ -> (* do not connect result types for overridden labels *) Overridden (lid, lbl_exp) | exception Not_found -> @@ -2760,7 +2761,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp let num_fields = match lbl_exp_list with | [] -> assert false - | (_, lbl, _) :: _ -> Array.length lbl.lbl_all + | (_, lbl, _, _) :: _ -> Array.length lbl.lbl_all in let opt_exp = if List.length lid_sexp_list = num_fields then ( @@ -2769,12 +2770,12 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp else opt_exp in let label_descriptions, representation = - let _, {lbl_all; lbl_repres}, _ = List.hd lbl_exp_list in + let _, {lbl_all; lbl_repres}, _, _ = List.hd lbl_exp_list in (lbl_all, lbl_repres) in let fields = Array.map2 - (fun descr def -> (descr, def)) + (fun descr def -> (descr, def, false)) label_descriptions label_definitions in re @@ -2803,9 +2804,9 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp | Pexp_setfield (srecord, lid, snewval) -> let record, label, opath = type_label_access env srecord lid in let ty_record = if opath = None then newvar () else record.exp_type in - let label_loc, label, newval = + let label_loc, label, newval, _ = type_label_exp ~type_clash_context:SetRecordField false env loc ty_record - (lid, label, snewval) + (lid, label, snewval, false) in unify_exp env record ty_record; if label.lbl_mut = Immutable then @@ -3354,7 +3355,7 @@ and type_label_access env srecord lid = These formats are used by functions in modules Printf, Format, and Scanf. (Handling of * modifiers contributed by Thorsten Ohl.) *) and type_label_exp ?type_clash_context create env loc ty_expected - (lid, label, sarg) = + (lid, label, sarg, opt) = (* Here also ty_expected may be at generic_level *) begin_def (); let separate = Env.has_local_constraints env in @@ -3403,7 +3404,7 @@ and type_label_exp ?type_clash_context create env loc ty_expected | Error (_, _, Less_general _) as e -> raise e | _ -> raise exn (* In case of failure return the first error *)) in - (lid, label, {arg with exp_type = instance env arg.exp_type}) + (lid, label, {arg with exp_type = instance env arg.exp_type}, opt) and type_argument ?type_clash_context ?recarg env sarg ty_expected' ty_expected = diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index b5ee0d2c08..c5243bcb16 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -50,7 +50,8 @@ and pattern_desc = | Tpat_construct of Longident.t loc * constructor_description * pattern list | Tpat_variant of label * pattern option * row_desc ref | Tpat_record of - (Longident.t loc * label_description * pattern) list * closed_flag + (Longident.t loc * label_description * pattern * bool (* optional *)) list + * closed_flag | Tpat_array of pattern list | Tpat_or of pattern * pattern * row_desc option | Tpat_lazy of pattern @@ -89,7 +90,11 @@ and expression_desc = Longident.t loc * constructor_description * expression list | Texp_variant of label * expression option | Texp_record of { - fields: (Types.label_description * record_label_definition) array; + fields: + (Types.label_description + * record_label_definition + * bool (* optional *)) + array; representation: Types.record_representation; extended_expression: expression option; } @@ -414,7 +419,7 @@ let iter_pattern_desc f = function | Tpat_construct (_, _, patl) -> List.iter f patl | Tpat_variant (_, pat, _) -> may f pat | Tpat_record (lbl_pat_list, _) -> - List.iter (fun (_, _, pat) -> f pat) lbl_pat_list + List.iter (fun (_, _, pat, _) -> f pat) lbl_pat_list | Tpat_array patl -> List.iter f patl | Tpat_or (p1, p2, _) -> f p1; @@ -427,7 +432,7 @@ let map_pattern_desc f d = | Tpat_alias (p1, id, s) -> Tpat_alias (f p1, id, s) | Tpat_tuple pats -> Tpat_tuple (List.map f pats) | Tpat_record (lpats, closed) -> - Tpat_record (List.map (fun (lid, l, p) -> (lid, l, f p)) lpats, closed) + Tpat_record (List.map (fun (lid, l, p, o) -> (lid, l, f p, o)) lpats, closed) | Tpat_construct (lid, c, pats) -> Tpat_construct (lid, c, List.map f pats) | Tpat_array pats -> Tpat_array (List.map f pats) | Tpat_lazy p1 -> Tpat_lazy (f p1) diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index 576cd914b7..e1f6548507 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -83,7 +83,8 @@ and pattern_desc = See {!Types.row_desc} for an explanation of the last parameter. *) | Tpat_record of - (Longident.t loc * label_description * pattern) list * closed_flag + (Longident.t loc * label_description * pattern * bool (* optional *)) list + * closed_flag (** { l1=P1; ...; ln=Pn } (flag = Closed) { l1=P1; ...; ln=Pn; _} (flag = Open) @@ -180,7 +181,11 @@ and expression_desc = *) | Texp_variant of label * expression option | Texp_record of { - fields: (Types.label_description * record_label_definition) array; + fields: + (Types.label_description + * record_label_definition + * bool (* optional *)) + array; representation: Types.record_representation; extended_expression: expression option; } diff --git a/compiler/ml/typedtreeIter.ml b/compiler/ml/typedtreeIter.ml index aef0f62491..b4500cd6c1 100644 --- a/compiler/ml/typedtreeIter.ml +++ b/compiler/ml/typedtreeIter.ml @@ -199,7 +199,7 @@ end = struct | None -> () | Some pat -> iter_pattern pat) | Tpat_record (list, _closed) -> - List.iter (fun (_, _, pat) -> iter_pattern pat) list + List.iter (fun (_, _, pat, _) -> iter_pattern pat) list | Tpat_array list -> List.iter iter_pattern list | Tpat_or (p1, p2, _) -> iter_pattern p1; @@ -255,8 +255,8 @@ end = struct | Texp_record {fields; extended_expression; _} -> ( Array.iter (function - | _, Kept _ -> () - | _, Overridden (_, exp) -> iter_expression exp) + | _, Kept _, _ -> () + | _, Overridden (_, exp), _ -> iter_expression exp) fields; match extended_expression with | None -> () diff --git a/compiler/ml/untypeast.ml b/compiler/ml/untypeast.ml index 7452f0ab86..0812bc88f7 100644 --- a/compiler/ml/untypeast.ml +++ b/compiler/ml/untypeast.ml @@ -261,7 +261,8 @@ let pattern sub pat = | Tpat_record (list, closed) -> Ppat_record ( List.map - (fun (lid, _, pat) -> (map_loc sub lid, sub.pat sub pat)) + (fun (lid, _, pat, opt) -> + (map_loc sub lid, sub.pat sub pat, opt)) list, closed ) | Tpat_array list -> Ppat_array (List.map (sub.pat sub) list) @@ -361,8 +362,8 @@ let expression sub exp = let list = Array.fold_left (fun l -> function - | _, Kept _ -> l - | _, Overridden (lid, exp) -> (lid, sub.expr sub exp) :: l) + | _, Kept _, _ -> l + | _, Overridden (lid, exp), opt -> (lid, sub.expr sub exp, opt) :: l) [] fields in Pexp_record (list, map_opt (sub.expr sub) extended_expression) diff --git a/compiler/syntax/src/jsx_common.ml b/compiler/syntax/src/jsx_common.ml index fa55a802ef..fd04f58bba 100644 --- a/compiler/syntax/src/jsx_common.ml +++ b/compiler/syntax/src/jsx_common.ml @@ -45,8 +45,6 @@ let raise_error_multiple_component ~loc = "Only one component definition is allowed for each module. Move to a \ submodule or other file if necessary." -let optional_attr = ({txt = "res.optional"; loc = Location.none}, PStr []) - let extract_uncurried typ = if Ast_uncurried.core_type_is_uncurried_fun typ then let _arity, t = Ast_uncurried.core_type_extract_uncurried_fun typ in diff --git a/compiler/syntax/src/jsx_ppx.ml b/compiler/syntax/src/jsx_ppx.ml index a9a4894de8..1416453ce4 100644 --- a/compiler/syntax/src/jsx_ppx.ml +++ b/compiler/syntax/src/jsx_ppx.ml @@ -19,7 +19,7 @@ type config_key = Int | String let get_jsx_config_by_key ~key ~type_ record_fields = let values = List.filter_map - (fun ((lid, expr) : Longident.t Location.loc * expression) -> + (fun ((lid, expr, _) : Longident.t Location.loc * expression * bool) -> match (type_, lid, expr) with | ( Int, {txt = Lident k}, diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index e73db9f21c..d80ff12f5c 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -31,8 +31,6 @@ let get_label str = | Optional str | Labelled str -> str | Nolabel -> "" -let optional_attrs = [Jsx_common.optional_attr] - let constant_string ~loc str = Ast_helper.Exp.constant ~loc (Pconst_string (str, None)) @@ -192,13 +190,14 @@ let record_from_props ~loc ~remove_key call_arguments = let rec remove_last_position_unit_aux props acc = match props with | [] -> acc - | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] -> + | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)}, _)] + -> acc - | (Nolabel, {pexp_loc}) :: _rest -> + | (Nolabel, {pexp_loc}, _) :: _rest -> Jsx_common.raise_error ~loc:pexp_loc "JSX: found non-labelled argument before the last position" - | ((Labelled txt, {pexp_loc}) as prop) :: rest - | ((Optional txt, {pexp_loc}) as prop) :: rest -> + | ((Labelled txt, {pexp_loc}, _) as prop) :: rest + | ((Optional txt, {pexp_loc}, _) as prop) :: rest -> if txt = spread_props_label then match acc with | [] -> remove_last_position_unit_aux rest (prop :: acc) @@ -211,25 +210,23 @@ let record_from_props ~loc ~remove_key call_arguments = let props, props_to_spread = remove_last_position_unit_aux call_arguments [] |> List.rev - |> List.partition (fun (label, _) -> label <> labelled "_spreadProps") + |> List.partition (fun (label, _, _) -> label <> labelled "_spreadProps") in let props = if remove_key then - props |> List.filter (fun (arg_label, _) -> "key" <> get_label arg_label) + props + |> List.filter (fun (arg_label, _, _) -> "key" <> get_label arg_label) else props in - let process_prop (arg_label, ({pexp_loc} as pexpr)) = + let process_prop (arg_label, ({pexp_loc} as pexpr), optional) = (* In case filed label is "key" only then change expression to option *) let id = get_label arg_label in - if is_optional arg_label then - ( {txt = Lident id; loc = pexp_loc}, - {pexpr with pexp_attributes = optional_attrs} ) - else ({txt = Lident id; loc = pexp_loc}, pexpr) + ({txt = Lident id; loc = pexp_loc}, pexpr, optional || is_optional arg_label) in let fields = props |> List.map process_prop in let spread_fields = - props_to_spread |> List.map (fun (_, expression) -> expression) + props_to_spread |> List.map (fun (_, expression, _) -> expression) in match (fields, spread_fields) with | [], [spread_props] | [], spread_props :: _ -> spread_props @@ -390,14 +387,14 @@ let transform_uppercase_call3 ~config module_path mapper jsx_expr_loc let recursively_transformed_args_for_make = args_for_make |> List.map (fun (label, expression) -> - (label, mapper.expr mapper expression)) + (label, mapper.expr mapper expression, false)) in let children_arg = ref None in let args = recursively_transformed_args_for_make @ match children_expr with - | Exact children -> [(labelled "children", children)] + | Exact children -> [(labelled "children", children, false)] | ListLiteral {pexp_desc = Pexp_array list} when list = [] -> [] | ListLiteral expression -> ( (* this is a hack to support react components that introspect into their children *) @@ -409,13 +406,14 @@ let transform_uppercase_call3 ~config module_path mapper jsx_expr_loc Exp.apply (Exp.ident {txt = module_access_name config "array"; loc = Location.none}) - [(Nolabel, expression)] ); + [(Nolabel, expression)], + false ); ] | _ -> [ ( labelled "children", - Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "null")} - ); + Exp.ident {loc = Location.none; txt = Ldot (Lident "React", "null")}, + false ); ]) in @@ -440,7 +438,9 @@ let transform_uppercase_call3 ~config module_path mapper jsx_expr_loc if is_empty_record record then empty_record ~loc:jsx_expr_loc else record in let key_prop = - args |> List.filter (fun (arg_label, _) -> "key" = get_label arg_label) + args + |> List.filter_map (fun (arg_label, e, _opt) -> + if "key" = get_label arg_label then Some (arg_label, e) else None) in let make_i_d = Exp.ident ~loc:call_expr_loc @@ -522,7 +522,7 @@ let transform_lowercase_call3 ~config mapper jsx_expr_loc call_expr_loc attrs let recursively_transformed_args_for_make = args_for_make |> List.map (fun (label, expression) -> - (label, mapper.expr mapper expression)) + (label, mapper.expr mapper expression, false)) in let children_arg = ref None in let args = @@ -532,13 +532,14 @@ let transform_lowercase_call3 ~config mapper jsx_expr_loc call_expr_loc attrs | Exact children -> [ ( labelled "children", - Exp.apply ~attrs:optional_attrs + Exp.apply (Exp.ident { txt = Ldot (element_binding, "someElement"); loc = Location.none; }) - [(Nolabel, children)] ); + [(Nolabel, children)], + true ); ] | ListLiteral {pexp_desc = Pexp_array list} when list = [] -> [] | ListLiteral expression -> @@ -549,7 +550,8 @@ let transform_lowercase_call3 ~config mapper jsx_expr_loc call_expr_loc attrs Exp.apply (Exp.ident {txt = module_access_name config "array"; loc = Location.none}) - [(Nolabel, expression)] ); + [(Nolabel, expression)], + false ); ] in let is_empty_record {pexp_desc} = @@ -562,7 +564,9 @@ let transform_lowercase_call3 ~config mapper jsx_expr_loc call_expr_loc attrs if is_empty_record record then empty_record ~loc:jsx_expr_loc else record in let key_prop = - args |> List.filter (fun (arg_label, _) -> "key" = get_label arg_label) + args + |> List.filter_map (fun (arg_label, e, _opt) -> + if "key" = get_label arg_label then Some (arg_label, e) else None) in let jsx_expr, key_and_unit = match (!children_arg, key_prop) with @@ -614,7 +618,8 @@ let transform_lowercase_call3 ~config mapper jsx_expr_loc call_expr_loc attrs ] | non_empty_props -> let props_record = - record_from_props ~loc:Location.none ~remove_key:false non_empty_props + record_from_props ~loc:Location.none ~remove_key:false + (non_empty_props |> List.map (fun (l, e) -> (l, e, false))) in [ (* "div" *) @@ -1072,10 +1077,9 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name ~rec_flag binding = (( {loc = ppat_loc; txt = Lident (get_label arg_label)}, { pattern_with_safe_label with - ppat_attributes = - (if is_optional arg_label then optional_attrs else []) - @ pattern.ppat_attributes; - } ) + ppat_attributes = pattern.ppat_attributes; + }, + is_optional arg_label ) :: patterns_with_label) patterns_with_nolabel expr else @@ -1086,10 +1090,8 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name ~rec_flag binding = -> returned_expression patterns_with_label (( {loc = ppat_loc; txt = Lident txt}, - { - pattern with - ppat_attributes = optional_attrs @ pattern.ppat_attributes; - } ) + {pattern with ppat_attributes = pattern.ppat_attributes}, + true ) :: patterns_with_nolabel) expr | _ -> @@ -1108,7 +1110,7 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name ~rec_flag binding = (* (ref) => expr *) let expression = List.fold_left - (fun expr (_, pattern) -> + (fun expr (_, pattern, _opt) -> let pattern = match pattern.ppat_desc with | Ppat_var {txt} when txt = "ref" -> @@ -1437,7 +1439,9 @@ let expr ~config mapper expression = in let children_expr = transform_children_if_list ~mapper list_items in let record_of_children children = - Exp.record [(Location.mknoloc (Lident "children"), children)] None + Exp.record + [(Location.mknoloc (Lident "children"), children, false)] + None in let apply_jsx_array expr = Exp.apply diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index 5705563d4f..e3bd7f7bf7 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -624,7 +624,7 @@ module SexpAst = struct Sexp.atom "Pexp_record"; Sexp.list (map_empty - ~f:(fun (longident_loc, expr) -> + ~f:(fun (longident_loc, expr, _) -> Sexp.list [longident longident_loc.Asttypes.txt; expression expr]) rows); @@ -774,7 +774,7 @@ module SexpAst = struct closed_flag flag; Sexp.list (map_empty - ~f:(fun (longident_loc, p) -> + ~f:(fun (longident_loc, p, _) -> Sexp.list [longident longident_loc.Location.txt; pattern p]) rows); ] diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index 63d486de5e..50ce987b1f 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -947,7 +947,7 @@ and walk_expression expr t comments = PStr [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (rows, _)}, [])}] ) -> walk_list - (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) + (rows |> List.map (fun (li, e, _) -> ExprRecordRow (li, e))) t comments | Pexp_extension extension -> walk_extension extension t comments | Pexp_letexception (extension_constructor, expr2) -> @@ -1067,7 +1067,7 @@ and walk_expression expr t comments = rest in walk_list - (rows |> List.map (fun (li, e) -> ExprRecordRow (li, e))) + (rows |> List.map (fun (li, e, _) -> ExprRecordRow (li, e))) t comments | Pexp_field (expr, longident) -> let leading, inside, trailing = partition_by_loc comments expr.pexp_loc in @@ -1755,7 +1755,7 @@ and walk_pattern pat t comments = | Ppat_type _ -> () | Ppat_record (record_rows, _) -> walk_list - (record_rows |> List.map (fun (li, p) -> PatternRecordRow (li, p))) + (record_rows |> List.map (fun (li, p, _) -> PatternRecordRow (li, p))) t comments | Ppat_or _ -> walk_list diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index e0935d18ad..dbd79c7852 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -155,17 +155,8 @@ end let jsx_attr = (Location.mknoloc "JSX", Parsetree.PStr []) let ternary_attr = (Location.mknoloc "res.ternary", Parsetree.PStr []) let if_let_attr = (Location.mknoloc "res.iflet", Parsetree.PStr []) -let optional_attr = (Location.mknoloc "res.optional", Parsetree.PStr []) let make_await_attr loc = (Location.mkloc "res.await" loc, Parsetree.PStr []) let make_async_attr loc = (Location.mkloc "res.async" loc, Parsetree.PStr []) - -let make_expression_optional ~optional (e : Parsetree.expression) = - if optional then {e with pexp_attributes = optional_attr :: e.pexp_attributes} - else e -let make_pattern_optional ~optional (p : Parsetree.pattern) = - if optional then {p with ppat_attributes = optional_attr :: p.ppat_attributes} - else p - let suppress_fragile_match_warning_attr = ( Location.mknoloc "warning", Parsetree.PStr @@ -215,7 +206,7 @@ type labelled_parameter = type record_pattern_item = | PatUnderscore - | PatField of (Ast_helper.lid * Parsetree.pattern) + | PatField of (Ast_helper.lid * Parsetree.pattern * bool (* optional *)) type context = OrdinaryExpr | TernaryTrueBranchExpr | WhenExpr @@ -1255,18 +1246,19 @@ and parse_optional_label p = *) and parse_record_pattern_row_field ~attrs p = let label = parse_value_path p in - let pattern = + let pattern, optional = match p.Parser.token with | Colon -> Parser.next p; let optional = parse_optional_label p in let pat = parse_pattern p in - make_pattern_optional ~optional pat + (pat, optional) | _ -> - Ast_helper.Pat.var ~loc:label.loc ~attrs - (Location.mkloc (Longident.last label.txt) label.loc) + ( Ast_helper.Pat.var ~loc:label.loc ~attrs + (Location.mkloc (Longident.last label.txt) label.loc), + false ) in - (label, pattern) + (label, pattern, optional) (* TODO: there are better representations than PatField|Underscore ? *) and parse_record_pattern_row p = @@ -1281,8 +1273,8 @@ and parse_record_pattern_row p = Parser.next p; match p.token with | Uident _ | Lident _ -> - let lid, pat = parse_record_pattern_row_field ~attrs p in - Some (false, PatField (lid, make_pattern_optional ~optional:true pat)) + let lid, pat, _ = parse_record_pattern_row_field ~attrs p in + Some (false, PatField (lid, pat, true)) | _ -> None) | Underscore -> Parser.next p; @@ -1309,7 +1301,7 @@ and parse_record_pattern ~attrs p = match field with | PatField field -> (if has_spread then - let _, pattern = field in + let _, pattern, _ = field in Parser.err ~start_pos:pattern.Parsetree.ppat_loc.loc_start p (Diagnostics.message ErrorMessages.record_pattern_spread)); (field :: fields, flag) @@ -1409,7 +1401,7 @@ and parse_dict_pattern_row p = Parser.expect Colon p; let optional = parse_optional_label p in let pat = parse_pattern p in - Some (fieldName, make_pattern_optional ~optional pat) + Some (fieldName, pat, optional) | _ -> None and parse_dict_pattern ~start_pos ~attrs (p : Parser.t) = @@ -2894,7 +2886,8 @@ and parse_braced_or_record_expr p = let field_expr = parse_expr p in Parser.optional p Comma |> ignore; let expr = - parse_record_expr_with_string_keys ~start_pos (field, field_expr) p + parse_record_expr_with_string_keys ~start_pos (field, field_expr, false) + p in Parser.expect Rbrace p; expr @@ -2963,7 +2956,9 @@ and parse_braced_or_record_expr p = | _ -> value_or_constructor in let expr = - parse_record_expr ~start_pos [(path_ident, value_or_constructor)] p + parse_record_expr ~start_pos + [(path_ident, value_or_constructor, false)] + p in Parser.expect Rbrace p; expr @@ -2971,16 +2966,15 @@ and parse_braced_or_record_expr p = Parser.next p; let optional = parse_optional_label p in let field_expr = parse_expr p in - let field_expr = make_expression_optional ~optional field_expr in match p.token with | Rbrace -> Parser.next p; let loc = mk_loc start_pos p.prev_end_pos in - Ast_helper.Exp.record ~loc [(path_ident, field_expr)] None + Ast_helper.Exp.record ~loc [(path_ident, field_expr, optional)] None | _ -> Parser.expect Comma p; let expr = - parse_record_expr ~start_pos [(path_ident, field_expr)] p + parse_record_expr ~start_pos [(path_ident, field_expr, optional)] p in Parser.expect Rbrace p; expr) @@ -2989,14 +2983,18 @@ and parse_braced_or_record_expr p = if p.prev_end_pos.pos_lnum < p.start_pos.pos_lnum then ( Parser.expect Comma p; let expr = - parse_record_expr ~start_pos [(path_ident, value_or_constructor)] p + parse_record_expr ~start_pos + [(path_ident, value_or_constructor, false)] + p in Parser.expect Rbrace p; expr) else ( Parser.expect Colon p; let expr = - parse_record_expr ~start_pos [(path_ident, value_or_constructor)] p + parse_record_expr ~start_pos + [(path_ident, value_or_constructor, false)] + p in Parser.expect Rbrace p; expr) @@ -3121,8 +3119,8 @@ and parse_record_expr_row_with_string_key p = | Colon -> Parser.next p; let field_expr = parse_expr p in - Some (field, field_expr) - | _ -> Some (field, Ast_helper.Exp.ident ~loc:field.loc field)) + Some (field, field_expr, false) + | _ -> Some (field, Ast_helper.Exp.ident ~loc:field.loc field, false)) | _ -> None and parse_record_expr_row p = @@ -3143,8 +3141,7 @@ and parse_record_expr_row p = Parser.next p; let optional = parse_optional_label p in let field_expr = parse_expr p in - let field_expr = make_expression_optional ~optional field_expr in - Some (field, field_expr) + Some (field, field_expr, optional) | _ -> let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in let value = @@ -3152,7 +3149,7 @@ and parse_record_expr_row p = | Uident _ -> remove_module_name_from_punned_field_value value | _ -> value in - Some (field, value)) + Some (field, value, false)) | Question -> ( Parser.next p; match p.Parser.token with @@ -3165,7 +3162,7 @@ and parse_record_expr_row p = | Uident _ -> remove_module_name_from_punned_field_value value | _ -> value in - Some (field, make_expression_optional ~optional:true value) + Some (field, value, true) | _ -> None) | _ -> None @@ -3201,7 +3198,7 @@ and parse_record_expr ~start_pos ?(spread = None) rows p = parse_comma_delimited_region ~grammar:Grammar.RecordRows ~closing:Rbrace ~f:parse_record_expr_row p in - let rows = List.concat [rows; exprs] in + let rows = rows @ exprs in let () = match rows with | [] -> diff --git a/compiler/syntax/src/res_parens.ml b/compiler/syntax/src/res_parens.ml index 336af9f77f..10f63a1167 100644 --- a/compiler/syntax/src/res_parens.ml +++ b/compiler/syntax/src/res_parens.ml @@ -15,13 +15,13 @@ let expr expr = | {pexp_desc = Pexp_constraint _} -> Parenthesized | _ -> Nothing) -let expr_record_row_rhs e = +let expr_record_row_rhs ~optional e = let kind = expr e in match kind with - | Nothing when Res_parsetree_viewer.has_optional_attribute e.pexp_attributes - -> ( + | Nothing when optional -> ( match e.pexp_desc with | Pexp_ifthenelse _ | Pexp_fun _ -> Parenthesized + | _ when ParsetreeViewer.is_binary_expression e -> Parenthesized | _ -> kind) | _ -> kind diff --git a/compiler/syntax/src/res_parens.mli b/compiler/syntax/src/res_parens.mli index 7c56c0ab56..c45c87a34f 100644 --- a/compiler/syntax/src/res_parens.mli +++ b/compiler/syntax/src/res_parens.mli @@ -39,4 +39,4 @@ val arrow_return_typ_expr : Parsetree.core_type -> bool val pattern_record_row_rhs : Parsetree.pattern -> bool -val expr_record_row_rhs : Parsetree.expression -> kind +val expr_record_row_rhs : optional:bool -> Parsetree.expression -> kind diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index 1e751ded1e..038f19f06b 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -232,9 +232,9 @@ let filter_parsing_attrs attrs = | ( { Location.txt = ( "res.arity" | "res.braces" | "ns.braces" | "res.iflet" - | "res.namedArgLoc" | "res.optional" | "res.ternary" | "res.async" - | "res.await" | "res.template" | "res.taggedTemplate" - | "res.patVariantSpread" | "res.dictPattern" ); + | "res.namedArgLoc" | "res.ternary" | "res.async" | "res.await" + | "res.template" | "res.taggedTemplate" | "res.patVariantSpread" + | "res.dictPattern" ); }, _ ) -> false @@ -376,12 +376,6 @@ let is_if_let_expr expr = true | _ -> false -let rec has_optional_attribute attrs = - match attrs with - | [] -> false - | ({Location.txt = "ns.optional" | "res.optional"}, _) :: _ -> true - | _ :: attrs -> has_optional_attribute attrs - let has_attributes attrs = List.exists (fun attr -> diff --git a/compiler/syntax/src/res_parsetree_viewer.mli b/compiler/syntax/src/res_parsetree_viewer.mli index 56e68a307b..01af15733f 100644 --- a/compiler/syntax/src/res_parsetree_viewer.mli +++ b/compiler/syntax/src/res_parsetree_viewer.mli @@ -102,7 +102,6 @@ val filter_fragile_match_attributes : val is_jsx_expression : Parsetree.expression -> bool val has_jsx_attribute : Parsetree.attributes -> bool -val has_optional_attribute : Parsetree.attributes -> bool val should_indent_binary_expr : Parsetree.expression -> bool val should_inline_rhs_binary_expr : Parsetree.expression -> bool diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index cc10416573..6fdb675b7e 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -538,10 +538,6 @@ let print_constant ?(template_literal = false) c = in Doc.text ("'" ^ str ^ "'") -let print_optional_label attrs = - if Res_parsetree_viewer.has_optional_attribute attrs then Doc.text "?" - else Doc.nil - module State = struct let custom_layout_threshold = 2 @@ -2568,15 +2564,16 @@ and print_pattern_record_row ~state row cmt_tbl = match row with (* punned {x}*) | ( ({Location.txt = Longident.Lident ident} as longident), - {Parsetree.ppat_desc = Ppat_var {txt; _}; ppat_attributes} ) + {Parsetree.ppat_desc = Ppat_var {txt; _}; ppat_attributes}, + opt ) when ident = txt -> Doc.concat [ - print_optional_label ppat_attributes; + (if opt then Doc.text "?" else Doc.nil); print_attributes ~state ppat_attributes cmt_tbl; print_lident_path longident cmt_tbl; ] - | longident, pattern -> + | longident, pattern, opt -> let loc_for_comments = {longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end} in @@ -2585,7 +2582,7 @@ and print_pattern_record_row ~state row cmt_tbl = let doc = if Parens.pattern_record_row_rhs pattern then add_parens doc else doc in - Doc.concat [print_optional_label pattern.ppat_attributes; doc] + if opt then Doc.concat [Doc.text "?"; doc] else doc in let doc = Doc.group @@ -2601,8 +2598,8 @@ and print_pattern_record_row ~state row cmt_tbl = print_comments doc cmt_tbl loc_for_comments and print_pattern_dict_row ~state - ((longident, pattern) : Longident.t Location.loc * Parsetree.pattern) - cmt_tbl = + ((longident, pattern, opt) : + Longident.t Location.loc * Parsetree.pattern * bool) cmt_tbl = let loc_for_comments = {longident.loc with loc_end = pattern.ppat_loc.loc_end} in @@ -2611,7 +2608,7 @@ and print_pattern_dict_row ~state let doc = if Parens.pattern_record_row_rhs pattern then add_parens doc else doc in - Doc.concat [print_optional_label pattern.ppat_attributes; doc] + if opt then Doc.concat [Doc.text "?"; doc] else doc in let lbl_doc = Doc.concat [Doc.text "\""; print_longident longident.txt; Doc.text "\""] @@ -3155,7 +3152,8 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) (List.map - (fun row -> print_bs_object_row ~state row cmt_tbl) + (fun (loc, e, _opt) -> + print_bs_object_row ~state (loc, e) cmt_tbl) rows); ]); Doc.trailing_comma; @@ -5457,7 +5455,8 @@ and print_direction_flag flag = | Asttypes.Downto -> Doc.text " downto " | Asttypes.Upto -> Doc.text " to " -and print_expression_record_row ~state (lbl, expr) cmt_tbl punning_allowed = +and print_expression_record_row ~state (lbl, expr, optional) cmt_tbl + punning_allowed = let cmt_loc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in let doc = Doc.group @@ -5468,7 +5467,7 @@ and print_expression_record_row ~state (lbl, expr) cmt_tbl punning_allowed = Doc.concat [ print_attributes ~state expr.pexp_attributes cmt_tbl; - print_optional_label expr.pexp_attributes; + (if optional then Doc.text "?" else Doc.nil); print_lident_path lbl cmt_tbl; ] | _ -> @@ -5476,9 +5475,9 @@ and print_expression_record_row ~state (lbl, expr) cmt_tbl punning_allowed = [ print_lident_path lbl cmt_tbl; Doc.text ": "; - print_optional_label expr.pexp_attributes; + (if optional then Doc.text "?" else Doc.nil); (let doc = print_expression_with_comments ~state expr cmt_tbl in - match Parens.expr_record_row_rhs expr with + match Parens.expr_record_row_rhs ~optional expr with | Parens.Parenthesized -> add_parens doc | Braced braces -> print_braces doc expr braces | Nothing -> doc); diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/record.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/record.res.txt index b4ab57492c..082bb3a3f9 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/record.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/record.res.txt @@ -12,30 +12,19 @@ let r = { expr with pexp_attributes = [||]; pexp_loc = loc } let r = { expr with pexp_attributes = [||] } let r = { (make () : myRecord) with foo = bar } let r = { (make () : myRecord) with foo = bar } -let r = - { - x = ((None)[@res.optional ]); - y = ((None)[@res.optional ]); - z = (((None : tt))[@res.optional ]) - } -let z = ((Function$ (fun name -> { name = ((name)[@res.optional ]); x = 3 })) - [@res.arity 1]) -let z = ((Function$ (fun name -> { name = ((name)[@res.optional ]); x = 3 })) - [@res.arity 1]) -let z = ((Function$ (fun name -> { name; x = ((x)[@res.optional ]) })) - [@res.arity 1]) -let zz = ((Function$ (fun name -> { name; x = ((x)[@res.optional ]) })) - [@res.arity 1]) +let r = { x = ?None; y = ?None; z = ?(None : tt) } +let z = ((Function$ (fun name -> { name?; x = 3 }))[@res.arity 1]) +let z = ((Function$ (fun name -> { name?; x = 3 }))[@res.arity 1]) +let z = ((Function$ (fun name -> { name; x? }))[@res.arity 1]) +let zz = ((Function$ (fun name -> { name; x? }))[@res.arity 1]) let _ = match z with - | { x = ((None)[@res.optional ]); y = ((None)[@res.optional ]); - z = (((None : tt))[@res.optional ]) } -> 11 - | { name = ((name)[@res.optional ]); x = 3 } -> 42 - | { name = ((name)[@res.optional ]); x = 3 } -> 4242 - | { x = ((None)[@res.optional ]); y = ((None)[@res.optional ]); - z = (((None : tt))[@res.optional ]) } -> 11 - | { name = ((name)[@res.optional ]); x = 3 } -> 42 - | { name = ((name)[@res.optional ]); x = 3 } -> 4242 + | { x? = None; y? = None; z? = (None : tt) } -> 11 + | { name?; x = 3 } -> 42 + | { name?; x = 3 } -> 4242 + | { x? = None; y? = None; z? = (None : tt) } -> 11 + | { name?; x = 3 } -> 42 + | { name?; x = 3 } -> 4242 type nonrec tt = { x: int ; y: string [@ns.opttinal ]} diff --git a/tests/syntax_tests/data/parsing/grammar/pattern/expected/dict.res.txt b/tests/syntax_tests/data/parsing/grammar/pattern/expected/dict.res.txt index 48211f4086..0da786cd5b 100644 --- a/tests/syntax_tests/data/parsing/grammar/pattern/expected/dict.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/pattern/expected/dict.res.txt @@ -1,5 +1,5 @@ let someDict = Primitive_dict.make [|("one", {js|one|js})|] -let (({ one = ((one)[@res.optional ]);_})[@res.dictPattern ]) = someDict +let (({ one?;_})[@res.dictPattern ]) = someDict let foo = ((Function$ (fun () -> @@ -29,9 +29,9 @@ let decodeUser = { name; age = - (((match ageJson with + ?((match ageJson with | Number age -> Some age - | _ -> None))[@res.optional ]) + | _ -> None)) } | _ -> (Js.log {js|Not an object.|js}; None)) [@res.braces ]) : user option))) diff --git a/tests/syntax_tests/data/ppx/react/expected/forwardRef.res.txt b/tests/syntax_tests/data/ppx/react/expected/forwardRef.res.txt index 4ea9cba48c..6f5d0caad5 100644 --- a/tests/syntax_tests/data/ppx/react/expected/forwardRef.res.txt +++ b/tests/syntax_tests/data/ppx/react/expected/forwardRef.res.txt @@ -21,7 +21,7 @@ module V4C = { ~props={ type_: "text", ?className, - ref: ?Js.Nullable.toOption(ref)->Belt.Option.map(React.Ref.domRef), + ref: ?(Js.Nullable.toOption(ref)->Belt.Option.map(React.Ref.domRef)), }, [], ), @@ -78,7 +78,7 @@ module V4CUncurried = { ~props={ type_: "text", ?className, - ref: ?Js.Nullable.toOption(ref)->Belt.Option.map(React.Ref.domRef), + ref: ?(Js.Nullable.toOption(ref)->Belt.Option.map(React.Ref.domRef)), }, [], ), @@ -135,7 +135,7 @@ module V4A = { { type_: "text", ?className, - ref: ?Js.Nullable.toOption(ref)->Belt.Option.map(ReactDOM.Ref.domRef), + ref: ?(Js.Nullable.toOption(ref)->Belt.Option.map(ReactDOM.Ref.domRef)), }, ), children, @@ -189,7 +189,7 @@ module V4AUncurried = { { type_: "text", ?className, - ref: ?Js.Nullable.toOption(ref)->Belt.Option.map(ReactDOM.Ref.domRef), + ref: ?(Js.Nullable.toOption(ref)->Belt.Option.map(ReactDOM.Ref.domRef)), }, ), children, diff --git a/tests/syntax_tests/data/printer/expr/expected/record.res.txt b/tests/syntax_tests/data/printer/expr/expected/record.res.txt index b3ac165e2f..97ddee1eee 100644 --- a/tests/syntax_tests/data/printer/expr/expected/record.res.txt +++ b/tests/syntax_tests/data/printer/expr/expected/record.res.txt @@ -100,5 +100,6 @@ type ttt = {x: int, y?: string} let optParen = {x: 3, y: ?(someBool ? Some("") : None)} let optParen = {x: 3, y: ?(3 + 4)} let optParen = {x: 3, y: ?foo(bar)} -let optParen = {x: 3, y: ?foo->bar} +let optParen = {x: 3, y: ?(foo->bar)} let optParen = {x: 3, y: ?() => 3} +let optParen = {x: 3, y: ?-3} diff --git a/tests/syntax_tests/data/printer/expr/record.res b/tests/syntax_tests/data/printer/expr/record.res index 75ddaed34a..82336fc734 100644 --- a/tests/syntax_tests/data/printer/expr/record.res +++ b/tests/syntax_tests/data/printer/expr/record.res @@ -92,3 +92,4 @@ let optParen = { x:3, y: ? (3+4) } let optParen = { x:3, y: ? (foo(bar)) } let optParen = { x:3, y: ? (foo->bar) } let optParen = { x:3, y: ? (()=>3) } +let optParen = { x:3, y: ? (-3) } diff --git a/tests/tests/src/res_debug.res b/tests/tests/src/res_debug.res index 82d69694e5..7a9bbfbb23 100644 --- a/tests/tests/src/res_debug.res +++ b/tests/tests/src/res_debug.res @@ -63,11 +63,11 @@ type props<'name> = {key?: string, name?: string} let name = None let ok = {name: ?optionMap(name, x => x)} -let bad = {name: ?name->optionMap(x => x)} +let bad = {name: ?(name->optionMap(x => x))} let identity = x => x let name1 = Some("ReScript") let ok1 = {name: ?identity(name1)} -let bad1 = {name: ?name1->identity} +let bad1 = {name: ?(name1->identity)}