From df2b120dababd0b050fbcb760b7697597f980914 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Tue, 27 May 2025 12:08:41 +0200 Subject: [PATCH] Refactor the ast for record expressions and pattern. The record element is now represented as a record instead of a tuple. Because of the presence of several polymorphic functions in the type checker, a unique type `'a record_element` is defined, where `'a` will be instantiated with either expression or pattern depending on the context. --- CHANGELOG.md | 1 + analysis/src/CompletionExpressions.ml | 30 +++++------ analysis/src/CompletionFrontEnd.ml | 21 ++++---- analysis/src/CompletionPatterns.ml | 31 +++++------ analysis/src/DumpAst.ml | 26 +++++---- analysis/src/Hint.ml | 2 +- analysis/src/SemanticTokens.ml | 16 +++--- analysis/src/SignatureHelp.ml | 10 ++-- analysis/src/Xform.ml | 4 +- compiler/common/pattern_printer.ml | 2 +- compiler/frontend/ast_derive_js_mapper.ml | 30 +++++++---- compiler/frontend/ast_external_process.ml | 52 +++++++----------- .../frontend/ast_tuple_pattern_flatten.ml | 2 +- compiler/frontend/ast_uncurry_gen.ml | 8 +-- compiler/frontend/ast_util.ml | 7 ++- compiler/frontend/ast_util.mli | 7 +-- compiler/frontend/bs_ast_mapper.ml | 11 ++-- compiler/ml/ast_helper.mli | 4 +- compiler/ml/ast_iterator.ml | 12 ++++- compiler/ml/ast_mapper.ml | 50 +++++++++++------ compiler/ml/ast_mapper_from0.ml | 12 ++++- compiler/ml/ast_mapper_to0.ml | 4 +- compiler/ml/ast_payload.ml | 9 ++-- compiler/ml/depend.ml | 4 +- compiler/ml/parmatch.ml | 2 +- compiler/ml/parsetree.ml | 13 ++--- compiler/ml/pprintast.ml | 4 +- compiler/ml/printast.ml | 4 +- compiler/ml/typecore.ml | 51 +++++++++--------- compiler/syntax/src/jsx_ppx.ml | 2 +- compiler/syntax/src/jsx_v4.ml | 31 ++++++----- compiler/syntax/src/res_ast_debugger.ml | 4 +- compiler/syntax/src/res_comments_table.ml | 6 +-- compiler/syntax/src/res_core.ml | 53 ++++++++++++------- compiler/syntax/src/res_printer.ml | 29 +++++----- 35 files changed, 305 insertions(+), 249 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index f1b7e8126f..9167f738e1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -35,6 +35,7 @@ - Remove deprecated pipe last (`|>`) syntax. https://github.com/rescript-lang/rescript/pull/7512 - Improve error message for pipe (`->`) syntax. https://github.com/rescript-lang/rescript/pull/7520 - Improve a few error messages around various subtyping issues. https://github.com/rescript-lang/rescript/pull/7404 +- Refactor the ast for record expressions and patterns. https://github.com/rescript-lang/rescript/pull/7528 # 12.0.0-alpha.13 diff --git a/analysis/src/CompletionExpressions.ml b/analysis/src/CompletionExpressions.ml index e5858d1ee6..8356a48cfd 100644 --- a/analysis/src/CompletionExpressions.ml +++ b/analysis/src/CompletionExpressions.ml @@ -59,23 +59,21 @@ let rec traverseExpr (exp : Parsetree.expression) ~exprPath ~pos | Pexp_record (fields, _) -> ( let fieldWithCursor = ref None in let fieldWithExprHole = ref None in - fields - |> List.iter (fun (fname, exp, _) -> - match - ( fname.Location.txt, - exp.Parsetree.pexp_loc |> CursorPosition.classifyLoc ~pos ) - with - | Longident.Lident fname, HasCursor -> - fieldWithCursor := Some (fname, exp) - | Lident fname, _ when isExprHole exp -> - fieldWithExprHole := Some (fname, exp) - | _ -> ()); + Ext_list.iter fields (fun {lid = fname; x = exp} -> + match + ( fname.Location.txt, + exp.Parsetree.pexp_loc |> CursorPosition.classifyLoc ~pos ) + with + | Longident.Lident fname, HasCursor -> + fieldWithCursor := Some (fname, exp) + | Lident fname, _ when isExprHole exp -> + fieldWithExprHole := Some (fname, exp) + | _ -> ()); let seenFields = - fields - |> List.filter_map (fun (fieldName, _f, _) -> - match fieldName with - | {Location.txt = Longident.Lident fieldName} -> Some fieldName - | _ -> None) + Ext_list.filter_map fields (fun {lid = fieldName} -> + match fieldName with + | {Location.txt = Longident.Lident fieldName} -> Some fieldName + | _ -> None) in match (!fieldWithCursor, !fieldWithExprHole) with | Some (fname, f), _ | None, Some (fname, f) -> ( diff --git a/analysis/src/CompletionFrontEnd.ml b/analysis/src/CompletionFrontEnd.ml index 9493aa8490..41bf47fbde 100644 --- a/analysis/src/CompletionFrontEnd.ml +++ b/analysis/src/CompletionFrontEnd.ml @@ -518,16 +518,15 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor :: patternPath) ?contextPath p | Ppat_record (fields, _) -> - fields - |> List.iter (fun (fname, p, _) -> - match fname with - | {Location.txt = Longident.Lident fname} -> - scopePattern - ~patternPath: - (Completable.NFollowRecordField {fieldName = fname} - :: patternPath) - ?contextPath p - | _ -> ()) + Ext_list.iter fields (fun {lid = fname; x = p} -> + match fname with + | {Location.txt = Longident.Lident fname} -> + scopePattern + ~patternPath: + (Completable.NFollowRecordField {fieldName = fname} + :: patternPath) + ?contextPath p + | _ -> ()) | Ppat_array pl -> pl |> List.iter @@ -926,7 +925,7 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor ( { pexp_desc = Pexp_record - (({txt = Lident "from"}, fromExpr, _) :: _, _); + ({lid = {txt = Lident "from"}; x = fromExpr} :: _, _); }, _ ); }; diff --git a/analysis/src/CompletionPatterns.ml b/analysis/src/CompletionPatterns.ml index 5ba9431c9a..8755c48457 100644 --- a/analysis/src/CompletionPatterns.ml +++ b/analysis/src/CompletionPatterns.ml @@ -110,24 +110,21 @@ and traversePattern (pat : Parsetree.pattern) ~patternPath ~locHasCursor | Ppat_record (fields, _) -> ( let fieldWithCursor = ref None in let fieldWithPatHole = ref None in - fields - |> List.iter (fun (fname, f, _) -> - match - ( fname.Location.txt, - f.Parsetree.ppat_loc - |> CursorPosition.classifyLoc ~pos:posBeforeCursor ) - with - | Longident.Lident fname, HasCursor -> - fieldWithCursor := Some (fname, f) - | Lident fname, _ when isPatternHole f -> - fieldWithPatHole := Some (fname, f) - | _ -> ()); + Ext_list.iter fields (fun {lid = fname; x = f} -> + match + ( fname.Location.txt, + f.Parsetree.ppat_loc + |> CursorPosition.classifyLoc ~pos:posBeforeCursor ) + with + | Longident.Lident fname, HasCursor -> fieldWithCursor := Some (fname, f) + | Lident fname, _ when isPatternHole f -> + fieldWithPatHole := Some (fname, f) + | _ -> ()); let seenFields = - fields - |> List.filter_map (fun (fieldName, _f, _) -> - match fieldName with - | {Location.txt = Longident.Lident fieldName} -> Some fieldName - | _ -> None) + Ext_list.filter_map fields (fun {lid = fieldName} -> + match fieldName with + | {Location.txt = Longident.Lident fieldName} -> Some fieldName + | _ -> None) in match (!fieldWithCursor, !fieldWithPatHole) with | Some (fname, f), _ | None, Some (fname, f) -> ( diff --git a/analysis/src/DumpAst.ml b/analysis/src/DumpAst.ml index 627cd8106e..39b05b3e6f 100644 --- a/analysis/src/DumpAst.ml +++ b/analysis/src/DumpAst.ml @@ -103,13 +103,12 @@ let rec printPattern pattern ~pos ~indentation = "Ppat_record(\n" ^ addIndentation (indentation + 1) ^ "fields:\n" - ^ (fields - |> List.map (fun ((Location.{txt} as loc), pat, _) -> - addIndentation (indentation + 2) - ^ (loc |> printLocDenominatorLoc ~pos) - ^ (Utils.flattenLongIdent txt |> ident |> str) - ^ ": " - ^ printPattern pat ~pos ~indentation:(indentation + 2)) + ^ (Ext_list.map fields (fun {lid; x = pat} -> + addIndentation (indentation + 2) + ^ (lid |> printLocDenominatorLoc ~pos) + ^ (Utils.flattenLongIdent lid.txt |> ident |> str) + ^ ": " + ^ printPattern pat ~pos ~indentation:(indentation + 2)) |> String.concat "\n") ^ "\n" ^ addIndentation indentation ^ ")" | Ppat_tuple patterns -> @@ -244,13 +243,12 @@ and printExprItem expr ~pos ~indentation = "Pexp_record(\n" ^ addIndentation (indentation + 1) ^ "fields:\n" - ^ (fields - |> List.map (fun ((Location.{txt} as loc), expr, _) -> - addIndentation (indentation + 2) - ^ (loc |> printLocDenominatorLoc ~pos) - ^ (Utils.flattenLongIdent txt |> ident |> str) - ^ ": " - ^ printExprItem expr ~pos ~indentation:(indentation + 2)) + ^ (Ext_list.map fields (fun {lid; x = expr} -> + addIndentation (indentation + 2) + ^ (lid |> printLocDenominatorLoc ~pos) + ^ (Utils.flattenLongIdent lid.txt |> ident |> str) + ^ ": " + ^ printExprItem expr ~pos ~indentation:(indentation + 2)) |> String.concat "\n") ^ "\n" ^ addIndentation indentation ^ ")" | Pexp_tuple exprs -> diff --git a/analysis/src/Hint.ml b/analysis/src/Hint.ml index 8d673a95a5..71b1b7cfe3 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) + Ext_list.iter fields (fun {x = p} -> processPattern p) | Ppat_array fields -> fields |> List.iter processPattern | Ppat_var {loc} -> push loc Type | _ -> () diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index 10219f1b54..d27a62dfdb 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -223,9 +223,8 @@ let command ~debug ~emitter ~path = (* Don't emit true or false *) Ast_iterator.default_iterator.pat iterator p | Ppat_record (cases, _) -> - cases - |> List.iter (fun (label, _, _) -> - emitter |> emitRecordLabel ~label ~debug); + Ext_list.iter cases (fun {lid = label} -> + emitter |> emitRecordLabel ~label ~debug); Ast_iterator.default_iterator.pat iterator p | Ppat_construct (name, _) -> emitter |> emitVariant ~name ~debug; @@ -320,12 +319,11 @@ let command ~debug ~emitter ~path = emitter |> emitFromLoc ~loc ~type_:Operator; Ast_iterator.default_iterator.expr iterator e | Pexp_record (cases, _) -> - cases - |> List.filter_map (fun ((label : Longident.t Location.loc), _, _) -> - match label.txt with - | Longident.Lident s when not (Utils.isFirstCharUppercase s) -> - Some label - | _ -> None) + Ext_list.filter_map cases (fun {lid} -> + match lid.txt with + | Longident.Lident s when not (Utils.isFirstCharUppercase s) -> + Some lid + | _ -> None) |> List.iter (fun label -> emitter |> emitRecordLabel ~label ~debug); Ast_iterator.default_iterator.expr iterator e | Pexp_field (_, label) | Pexp_setfield (_, label, _) -> diff --git a/analysis/src/SignatureHelp.ml b/analysis/src/SignatureHelp.ml index 481aa7e043..da9dc6865a 100644 --- a/analysis/src/SignatureHelp.ml +++ b/analysis/src/SignatureHelp.ml @@ -629,10 +629,8 @@ let signatureHelp ~path ~pos ~currentFile ~debug ~allowForConstructorPayloads = fields |> List.find_map (fun - (({loc; txt}, expr, _) : - Longident.t Location.loc - * Parsetree.expression - * bool) + ({lid = {loc; txt}; x = expr} : + Parsetree.expression Parsetree.record_element) -> if posBeforeCursor >= Pos.ofLexing loc.loc_start @@ -673,8 +671,8 @@ let signatureHelp ~path ~pos ~currentFile ~debug ~allowForConstructorPayloads = fields |> List.find_map (fun - (({loc; txt}, pat, _) : - Longident.t Location.loc * Parsetree.pattern * bool) + ({lid = {loc; txt}; x = pat} : + Parsetree.pattern Parsetree.record_element) -> if posBeforeCursor >= Pos.ofLexing loc.loc_start diff --git a/analysis/src/Xform.ml b/analysis/src/Xform.ml index 837f7df744..4d62a9d68f 100644 --- a/analysis/src/Xform.ml +++ b/analysis/src/Xform.ml @@ -69,10 +69,10 @@ module IfThenElse = struct | None -> None | Some patList -> Some (mkPat (Ppat_tuple patList))) | Pexp_record (items, None) -> ( - let itemToPat (x, e, o) = + let itemToPat {Parsetree.lid; x = e; opt} = match expToPat e with | None -> None - | Some p -> Some (x, p, o) + | Some p -> Some {Parsetree.lid; x = p; opt} in match listToPat ~itemToPat items with | None -> None diff --git a/compiler/common/pattern_printer.ml b/compiler/common/pattern_printer.ml index 96d9fdf01d..f3529da7a5 100644 --- a/compiler/common/pattern_printer.ml +++ b/compiler/common/pattern_printer.ml @@ -33,7 +33,7 @@ let untype typed = let fields = List.map (fun (_, lbl, p, opt) -> - (mknoloc (Longident.Lident lbl.lbl_name), loop p, opt)) + {lid = mknoloc (Longident.Lident lbl.lbl_name); x = 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 dfd2694dbb..d40b4669c1 100644 --- a/compiler/frontend/ast_derive_js_mapper.ml +++ b/compiler/frontend/ast_derive_js_mapper.ml @@ -38,14 +38,16 @@ let handle_config (config : Parsetree.expression option) = match config.pexp_desc with | Pexp_record ( [ - ( {txt = Lident "newType"}, - { - pexp_desc = - ( Pexp_construct - ({txt = Lident (("true" | "false") as x)}, None) - | Pexp_ident {txt = Lident ("newType" as x)} ); - }, - _ ); + { + lid = {txt = Lident "newType"}; + x = + { + pexp_desc = + ( Pexp_construct + ({txt = Lident (("true" | "false") as x)}, None) + | Pexp_ident {txt = Lident ("newType" as x)} ); + }; + }; ], None ) -> not (x = "false") @@ -196,7 +198,11 @@ let init () = txt = Longident.Lident txt; } in - (label, Exp.field exp_param label, false))) + { + Parsetree.lid = label; + x = Exp.field exp_param label; + opt = false; + })) None); ] )) in @@ -208,7 +214,11 @@ let init () = let label = {Asttypes.loc; txt = Longident.Lident txt} in - (label, js_field exp_param label, false))) + { + Parsetree.lid = label; + x = js_field exp_param label; + opt = false; + })) None in let from_js = diff --git a/compiler/frontend/ast_external_process.ml b/compiler/frontend/ast_external_process.ml index e916e4bc69..6988bebab7 100644 --- a/compiler/frontend/ast_external_process.ml +++ b/compiler/frontend/ast_external_process.ml @@ -260,19 +260,14 @@ let parse_external_attributes (no_arguments : bool) (prim_name_check : string) ] -> ( let from_name = ref None in let with_ = ref None in - fields - |> List.iter - (fun - ((l, exp, _) : - Longident.t Location.loc * Parsetree.expression * bool) - -> - match (l, exp.pexp_desc) with - | ( {txt = Lident "from"}, - Pexp_constant (Pconst_string (s, _)) ) -> - from_name := Some s - | {txt = Lident "with"}, Pexp_record (fields, _) -> - with_ := Some fields - | _ -> ()); + Ext_list.iter fields (fun {lid = l; x = exp} -> + match (l, exp.pexp_desc) with + | {txt = Lident "from"}, Pexp_constant (Pconst_string (s, _)) + -> + from_name := Some s + | {txt = Lident "with"}, Pexp_record (fields, _) -> + with_ := Some fields + | _ -> ()); match (!from_name, !with_) with | None, _ -> Location.raise_errorf ~loc:pexp_loc @@ -287,25 +282,18 @@ let parse_external_attributes (no_arguments : bool) (prim_name_check : string) the import attributes you want applied to the import." | Some from_name, Some with_fields -> let import_attributes_from_record = - with_fields - |> List.filter_map - (fun - ((l, exp, _) : - Longident.t Location.loc - * Parsetree.expression - * bool) - -> - match exp.pexp_desc with - | Pexp_constant (Pconst_string (s, _)) -> ( - match l.txt with - | Longident.Lident "type_" -> Some ("type", s) - | Longident.Lident txt -> Some (txt, s) - | _ -> - Location.raise_errorf ~loc:exp.pexp_loc - "Field must be a regular key.") - | _ -> - Location.raise_errorf ~loc:exp.pexp_loc - "Only string values are allowed here.") + Ext_list.filter_map with_fields (fun {lid = l; x = exp} -> + match exp.pexp_desc with + | Pexp_constant (Pconst_string (s, _)) -> ( + match l.txt with + | Longident.Lident "type_" -> Some ("type", s) + | Longident.Lident txt -> Some (txt, s) + | _ -> + Location.raise_errorf ~loc:exp.pexp_loc + "Field must be a regular key.") + | _ -> + Location.raise_errorf ~loc:exp.pexp_loc + "Only string values are allowed here.") in let import_attributes = Hashtbl.create (List.length import_attributes_from_record) diff --git a/compiler/frontend/ast_tuple_pattern_flatten.ml b/compiler/frontend/ast_tuple_pattern_flatten.ml index c6efc507a4..27fe1e73a8 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; x = pat} -> match lid.txt with | Lident s -> { diff --git a/compiler/frontend/ast_uncurry_gen.ml b/compiler/frontend/ast_uncurry_gen.ml index 9e0a43fe37..ea7cf4ad57 100644 --- a/compiler/frontend/ast_uncurry_gen.ml +++ b/compiler/frontend/ast_uncurry_gen.ml @@ -61,9 +61,11 @@ let to_method_callback loc (self : Bs_ast_mapper.mapper) label Exp.constraint_ ~loc (Exp.record ~loc [ - ( {loc; txt = Ast_literal.Lid.hidden_field arity_s}, - body, - false ); + { + lid = {loc; txt = Ast_literal.Lid.hidden_field arity_s}; + x = body; + opt = false; + }; ] None) (Typ.constr ~loc diff --git a/compiler/frontend/ast_util.ml b/compiler/frontend/ast_util.ml index 7a8765f503..f5814164fa 100644 --- a/compiler/frontend/ast_util.ml +++ b/compiler/frontend/ast_util.ml @@ -22,16 +22,15 @@ * 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 * bool) list - let js_property loc obj (name : string) = Parsetree.Pexp_send (obj, {loc; txt = name}) let record_as_js_object loc (self : Bs_ast_mapper.mapper) - (label_exprs : label_exprs) : Parsetree.expression_desc = + (label_exprs : Parsetree.expression Parsetree.record_element list) : + Parsetree.expression_desc = let labels, args, arity = Ext_list.fold_right label_exprs ([], [], 0) - (fun ({txt; loc}, e, _) (labels, args, i) -> + (fun {lid = {txt; loc}; x = 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 0f659d339a..4b44a1bba8 100644 --- a/compiler/frontend/ast_util.mli +++ b/compiler/frontend/ast_util.mli @@ -28,10 +28,11 @@ - convert a uncuried application to normal *) -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 + Location.t -> + Bs_ast_mapper.mapper -> + Parsetree.expression Parsetree.record_element list -> + Parsetree.expression_desc val js_property : Location.t -> Parsetree.expression -> string -> Parsetree.expression_desc diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml index 287608c40d..03eab561d1 100644 --- a/compiler/frontend/bs_ast_mapper.ml +++ b/compiler/frontend/bs_ast_mapper.ml @@ -69,7 +69,6 @@ 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) @@ -343,7 +342,10 @@ module E = struct variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) | Pexp_record (l, eo) -> record ~loc ~attrs - (List.map (map_tuple3 (map_loc sub) (sub.expr sub) id) l) + (List.map + (fun {lid; x = e; opt} -> + {lid = map_loc sub lid; x = sub.expr sub e; opt}) + l) (map_opt (sub.expr sub) eo) | Pexp_field (e, lid) -> field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) @@ -426,7 +428,10 @@ 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_tuple3 (map_loc sub) (sub.pat sub) id) lpl) + (List.map + (fun {lid; x = p; opt} -> + {lid = map_loc sub lid; x = sub.pat sub p; opt}) + 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 9fbee171ae..20c601f4ee 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -107,7 +107,7 @@ module Pat : sig val record : ?loc:loc -> ?attrs:attrs -> - (lid * pattern * bool) list -> + pattern record_element list -> closed_flag -> pattern val array : ?loc:loc -> ?attrs:attrs -> pattern list -> pattern @@ -162,7 +162,7 @@ module Exp : sig val record : ?loc:loc -> ?attrs:attrs -> - (lid * expression * bool) list -> + expression record_element 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 d33f1b656c..285e7d2db6 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -310,7 +310,11 @@ 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_tuple3 (iter_loc sub) (sub.expr sub) (fun _ -> ())) l; + List.iter + (fun {lid; x = exp} -> + iter_loc sub lid; + sub.expr sub exp) + l; iter_opt (sub.expr sub) eo | Pexp_field (e, lid) -> sub.expr sub e; @@ -397,7 +401,11 @@ 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_tuple3 (iter_loc sub) (sub.pat sub) (fun _ -> ())) lpl + List.iter + (fun {lid; x = pat} -> + iter_loc sub lid; + sub.pat sub pat) + 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 06adfddb37..b26ad1e732 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -61,7 +61,6 @@ 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) @@ -306,7 +305,10 @@ module E = struct variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) | Pexp_record (l, eo) -> record ~loc ~attrs - (List.map (map_tuple3 (map_loc sub) (sub.expr sub) id) l) + (List.map + (fun {lid; x = exp; opt} -> + {lid = map_loc sub lid; x = sub.expr sub exp; opt}) + l) (map_opt (sub.expr sub) eo) | Pexp_field (e, lid) -> field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) @@ -390,7 +392,10 @@ 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_tuple3 (map_loc sub) (sub.pat sub) (fun x -> x)) lpl) + (List.map + (fun {lid; x = pat; opt} -> + {lid = map_loc sub lid; x = sub.pat sub pat; opt}) + 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) @@ -555,11 +560,14 @@ module PpxContext = struct let make_pair f1 f2 (x1, x2) = Exp.tuple [f1 x1; f2 x2] let get_cookies () = - ( lid "cookies", - make_list - (make_pair make_string (fun x -> x)) - (StringMap.bindings !cookies), - false ) + { + lid = lid "cookies"; + x = + make_list + (make_pair make_string (fun x -> x)) + (StringMap.bindings !cookies); + opt = false; + } let mk fields = ( {txt = "ocaml.ppx.context"; loc = Location.none}, @@ -568,11 +576,23 @@ module PpxContext = struct let make ~tool_name () = let fields = [ - (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); + {lid = lid "tool_name"; x = make_string tool_name; opt = false}; + { + lid = lid "include_dirs"; + x = make_list make_string !Clflags.include_dirs; + opt = false; + }; + { + lid = lid "load_path"; + x = make_list make_string !Config.load_path; + opt = false; + }; + { + lid = lid "open_modules"; + x = make_list make_string !Clflags.open_modules; + opt = false; + }; + {lid = lid "debug"; x = make_bool !Clflags.debug; opt = false}; get_cookies (); ] in @@ -641,14 +661,14 @@ module PpxContext = struct in List.iter (function - | {txt = Lident name}, x, _ -> field name x + | {lid = {txt = Lident name}; x} -> field name x | _ -> ()) fields let update_cookies fields = let fields = Ext_list.filter fields (function - | {txt = Lident "cookies"}, _, _ -> false + | {lid = {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 ddd0f5e580..6afd493daf 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -492,7 +492,11 @@ module E = struct let optional, attrs = Parsetree0.get_optional_attr e1.pexp_attributes in - (lid1, {e1 with pexp_attributes = attrs}, optional))) + { + Pt.lid = lid1; + x = {e1 with pexp_attributes = attrs}; + opt = optional; + })) (map_opt (sub.expr sub) eo) | Pexp_field (e, lid) -> field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) @@ -565,7 +569,11 @@ module P = struct let optional, attrs = Parsetree0.get_optional_attr p1.ppat_attributes in - (lid1, {p1 with ppat_attributes = attrs}, optional))) + { + Pt.lid = lid1; + x = {p1 with ppat_attributes = attrs}; + opt = 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 d35d3702d4..4d50704e48 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -424,7 +424,7 @@ module E = struct variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) | Pexp_record (l, eo) -> record ~loc ~attrs - (Ext_list.map l (fun (lid, e, optional) -> + (Ext_list.map l (fun {lid; x = e; opt = optional} -> let lid1 = map_loc sub lid in let e1 = sub.expr sub e in let attr = @@ -554,7 +554,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 - (Ext_list.map lpl (fun (lid, p, optional) -> + (Ext_list.map lpl (fun {lid; x = p; opt = optional} -> let lid1 = map_loc sub lid in let p1 = sub.pat sub p in let attr = diff --git a/compiler/ml/ast_payload.ml b/compiler/ml/ast_payload.ml index 66317e1c0f..eb953cd583 100644 --- a/compiler/ml/ast_payload.ml +++ b/compiler/ml/ast_payload.ml @@ -210,12 +210,13 @@ let ident_or_record_as_config loc (x : t) : | None -> Ext_list.map label_exprs (fun u -> match u with - | ( {txt = Lident name; loc}, - {Parsetree.pexp_desc = Pexp_ident {txt = Lident name2}}, - _ ) + | { + lid = {txt = Lident name; loc}; + x = {Parsetree.pexp_desc = Pexp_ident {txt = Lident name2}}; + } when name2 = name -> ({Asttypes.txt = name; loc}, None) - | {txt = Lident name; loc}, y, _ -> + | {lid = {txt = Lident name; loc}; x = y} -> ({Asttypes.txt = name; loc}, Some y) | _ -> Location.raise_errorf ~loc "Qualified label is not allowed") | Some _ -> diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index f474d872cf..f72c7f9937 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 {lid = lbl; x = p} -> add bv lbl; add_pattern bv p) pl @@ -236,7 +236,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 {lid = lbl; x = e} -> add bv lbl; add_expr bv e) lblel; diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 51f91f02ab..0dae8985bf 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -1986,7 +1986,7 @@ module Conv = struct (fun (_, lbl, p, optional) -> let id = fresh lbl.lbl_name in Hashtbl.add labels id lbl; - (mknoloc (Longident.Lident id), loop p, optional)) + {lid = mknoloc (Longident.Lident id); x = loop p; opt = optional}) subpatterns in mkpat (Ppat_record (fields, Open)) diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index 24d5b725c8..63b063214b 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -182,8 +182,7 @@ and pattern_desc = (* `A (None) `A P (Some P) *) - | Ppat_record of - (Longident.t loc * pattern * bool (* optional *)) list * closed_flag + | Ppat_record of pattern record_element list * closed_flag (* { l1=P1; ...; ln=Pn } (flag = Closed) { l1=P1; ...; ln=Pn; _} (flag = Open) @@ -203,8 +202,9 @@ and pattern_desc = | Ppat_open of Longident.t loc * pattern (* M.(P) *) -(* Value expressions *) +and pat_record_label = Longident.t loc * pattern * bool (* optional *) +(* Value expressions *) and expression = { pexp_desc: expression_desc; pexp_loc: Location.t; @@ -269,9 +269,7 @@ and expression_desc = (* `A (None) `A E (Some E) *) - | Pexp_record of - (Longident.t loc * expression * bool (* optional *)) list - * expression option + | Pexp_record of expression record_element list * expression option (* { l1=P1; ...; ln=Pn } (None) { E0 with l1=P1; ...; ln=Pn } (Some E0) @@ -317,6 +315,9 @@ and expression_desc = | Pexp_await of expression | Pexp_jsx_element of jsx_element +(* an element of a record pattern or expression *) +and 'a record_element = {lid: Longident.t loc; x: 'a; opt: bool (* optional *)} + and jsx_element = | Jsx_fragment of jsx_fragment | Jsx_unary_element of jsx_unary_element diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml index 738f67764f..deeca5d3de 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -458,7 +458,7 @@ and simple_pattern ctxt (f : Format.formatter) (x : pattern) : unit = | Ppat_unpack s -> pp f "(module@ %s)@ " s.txt | Ppat_type li -> pp f "#%a" longident_loc li | Ppat_record (l, closed) -> ( - let longident_x_pattern f (li, p, opt) = + let longident_x_pattern f {lid = li; x = p; opt} = let opt_str = if opt then "?" else "" in match (li, p) with | ( {txt = Lident s; _}, @@ -764,7 +764,7 @@ and simple_expr ctxt f x = pp f "(%a :> %a)" (expression ctxt) e (core_type ctxt) ct | Pexp_variant (l, None) -> pp f "`%s" l | Pexp_record (l, eo) -> - let longident_x_expression f (li, e, opt) = + let longident_x_expression f {lid = li; x = e; opt} = let opt_str = if opt then "?" else "" in match e with | {pexp_desc = Pexp_ident {txt; _}; pexp_attributes = []; _} diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index 2586c68b2b..d5c413139c 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -672,7 +672,7 @@ 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, opt) = +and longident_x_pattern i ppf {lid = li; x = p; opt} = line i ppf "%a%s\n" fmt_longident_loc li (if opt then "?" else ""); pattern (i + 1) ppf p @@ -694,7 +694,7 @@ and value_binding i ppf x = pattern (i + 1) ppf x.pvb_pat; expression (i + 1) ppf x.pvb_expr -and longident_x_expression i ppf (li, e, opt) = +and longident_x_expression i ppf {lid = li; x = e; opt} = line i ppf "%a%s\n" fmt_longident_loc li (if opt then "?" else ""); expression (i + 1) ppf e diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index be0414ecf3..5e1f411f90 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -153,7 +153,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 {x = e} -> expr e) iel | Pexp_open (_, _, e) | Pexp_newtype (_, e) | Pexp_assert e @@ -973,8 +973,8 @@ let disambiguate_label_by_ids closed ids labels = if labels'' = [] then (false, labels') else (true, 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 disambiguate_record_elem_list loc closed env opath record_elem_list = + let ids = List.map (fun {lid} -> Longident.last lid.txt) record_elem_list in let w_amb = ref [] in let warn loc msg = let open Warnings in @@ -1005,7 +1005,9 @@ 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, opt) -> (lid, process_label lid, a, opt)) lid_a_list + List.map + (fun {lid; x; opt} -> (lid, process_label lid, x, opt)) + record_elem_list in (match List.rev !w_amb with | (_, types) :: _ as amb -> @@ -1026,7 +1028,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 + | {lid = {txt = Longident.Ldot (modname, _)}} :: _ -> Some modname | _ :: rest -> find_record_qual rest let map_fold_cont f xs k = @@ -1036,33 +1038,34 @@ let map_fold_cont f xs k = (fun ys -> k (List.rev ys)) [] -let type_label_a_list ?labels loc closed env type_lbl_a opath lid_a_list k = +let type_record_elem_list ?labels loc closed env type_lbl_a opath + record_elem_list k = let lbl_a_list = - match (lid_a_list, labels) with - | ({txt = Longident.Lident s}, _, _) :: _, Some labels + match (record_elem_list, labels) with + | {lid = {txt = Longident.Lident s}} :: _, Some labels when Hashtbl.mem labels s -> (* Special case for rebuilt syntax trees *) List.map (function - | lid, a, opt -> ( + | {lid; x = a; opt} -> ( match lid.txt with | Longident.Lident s -> (lid, Hashtbl.find labels s, a, opt) | _ -> assert false)) - lid_a_list + record_elem_list | _ -> - let lid_a_list = - match find_record_qual lid_a_list with - | None -> lid_a_list + let record_elem_list = + match find_record_qual record_elem_list with + | None -> record_elem_list | Some modname -> List.map - (fun ((lid, a, opt) as lid_a) -> + (fun ({lid; x = a; opt} as el) -> match lid.txt with | Longident.Lident s -> - ({lid with txt = Longident.Ldot (modname, s)}, a, opt) - | _ -> lid_a) - lid_a_list + {lid = {lid with txt = Longident.Ldot (modname, s)}; x = a; opt} + | _ -> el) + record_elem_list in - disambiguate_lid_a_list loc closed env opath lid_a_list + disambiguate_record_elem_list loc closed env opath record_elem_list in (* Invariant: records are sorted in the typed tree *) let lbl_a_list = @@ -1530,12 +1533,12 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp if constrs = None then k (wrap_disambiguate "This record pattern is expected to have" expected_ty - (type_label_a_list ?labels loc false !env type_label_pat opath + (type_record_elem_list ?labels loc false !env type_label_pat opath lid_sp_list) (k' (fun x -> x))) else - type_label_a_list ?labels loc false !env type_label_pat opath lid_sp_list - (k' k) + type_record_elem_list ?labels loc false !env type_label_pat opath + lid_sp_list (k' k) | Ppat_array spl -> let ty_elt = newvar () in unify_pat_types loc !env @@ -2042,7 +2045,7 @@ let iter_ppat f p = | Ppat_open (_, p) | Ppat_constraint (p, _) -> f p - | Ppat_record (args, _flag) -> List.iter (fun (_, p, _) -> f p) args + | Ppat_record (args, _flag) -> List.iter (fun {x = p} -> f p) args let contains_polymorphic_variant p = let rec loop p = @@ -2557,7 +2560,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp in let lbl_exp_list = wrap_disambiguate "This record expression is expected to have" ty_record - (type_label_a_list loc true env + (type_record_elem_list loc true env (fun e k -> k (type_label_exp true env loc ty_record (process_optional_label e))) @@ -2666,7 +2669,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp let closed = false in let lbl_exp_list = wrap_disambiguate "This record expression is expected to have" ty_record - (type_label_a_list loc closed env + (type_record_elem_list loc closed env (fun e k -> k (type_label_exp true env loc ty_record (process_optional_label e))) diff --git a/compiler/syntax/src/jsx_ppx.ml b/compiler/syntax/src/jsx_ppx.ml index 8bd2ffd7a0..4b05e1995d 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 * bool) -> + (fun ({lid; x = expr} : expression record_element) -> 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 d353aef8b4..a94cb7466e 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -677,12 +677,15 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name ~rec_flag binding = in if is_labelled arg_label || is_optional arg_label then returned_expression - (( {loc = ppat_loc; txt = Lident (get_label arg_label)}, - { - pattern_with_safe_label with - ppat_attributes = pattern.ppat_attributes; - }, - is_optional arg_label ) + ({ + lid = {loc = ppat_loc; txt = Lident (get_label arg_label)}; + x = + { + pattern_with_safe_label with + ppat_attributes = pattern.ppat_attributes; + }; + opt = is_optional arg_label; + } :: patterns_with_label) patterns_with_nolabel expr else @@ -1151,13 +1154,17 @@ let mk_record_from_props mapper (jsx_expr_loc : Location.t) (props : jsx_props) props |> List.map (function | JSXPropPunning (is_optional, name) -> - ( {txt = Lident name.txt; loc = name.loc}, - Exp.ident {txt = Lident name.txt; loc = name.loc}, - is_optional ) + { + lid = {txt = Lident name.txt; loc = name.loc}; + x = Exp.ident {txt = Lident name.txt; loc = name.loc}; + opt = is_optional; + } | JSXPropValue (name, is_optional, value) -> - ( {txt = Lident name.txt; loc = name.loc}, - mapper.expr mapper value, - is_optional ) + { + lid = {txt = Lident name.txt; loc = name.loc}; + x = mapper.expr mapper value; + opt = is_optional; + } | JSXPropSpreading (loc, _) -> (* There can only be one spread expression and it is expected to be the first prop *) Jsx_common.raise_error ~loc diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index 55ac14bd09..d362e710c0 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -618,7 +618,7 @@ module SexpAst = struct Sexp.atom "Pexp_record"; Sexp.list (map_empty - ~f:(fun (longident_loc, expr, _) -> + ~f:(fun {lid = longident_loc; x = expr} -> Sexp.list [longident longident_loc.Asttypes.txt; expression expr]) rows); @@ -804,7 +804,7 @@ module SexpAst = struct closed_flag flag; Sexp.list (map_empty - ~f:(fun (longident_loc, p, _) -> + ~f:(fun {lid = longident_loc; x = 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 62ce43b66c..d62b99400a 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -1107,7 +1107,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))) + (Ext_list.map rows (fun {lid; x = e} -> ExprRecordRow (lid, e))) t comments | Pexp_extension extension -> walk_extension extension t comments | Pexp_letexception (extension_constructor, expr2) -> @@ -1227,7 +1227,7 @@ and walk_expression expr t comments = rest in walk_list - (rows |> List.map (fun (li, e, _) -> ExprRecordRow (li, e))) + (Ext_list.map rows (fun {lid; x = e} -> ExprRecordRow (lid, e))) t comments | Pexp_field (expr, longident) -> let leading, inside, trailing = partition_by_loc comments expr.pexp_loc in @@ -2068,7 +2068,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))) + (Ext_list.map record_rows (fun {lid; x = p} -> PatternRecordRow (lid, p))) t comments | Ppat_or _ -> walk_list diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index da7614ba8f..d6a8051623 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -212,7 +212,7 @@ type fundef_parameter = type record_pattern_item = | PatUnderscore - | PatField of (Ast_helper.lid * Parsetree.pattern * bool (* optional *)) + | PatField of Parsetree.pattern Parsetree.record_element type context = OrdinaryExpr | TernaryTrueBranchExpr | WhenExpr @@ -1246,7 +1246,7 @@ and parse_record_pattern_row_field ~attrs p = (Location.mkloc (Longident.last label.txt) label.loc), false ) in - (label, pattern, optional) + {Parsetree.lid = label; x = pattern; opt = optional} (* TODO: there are better representations than PatField|Underscore ? *) and parse_record_pattern_row p = @@ -1261,8 +1261,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, pat, true)) + let {Parsetree.lid; x = pat} = parse_record_pattern_row_field ~attrs p in + Some (false, PatField {lid; x = pat; opt = true}) | _ -> None) | Underscore -> Parser.next p; @@ -1289,7 +1289,7 @@ and parse_record_pattern ~attrs p = match field with | PatField field -> (if has_spread then - let _, pattern, _ = field in + let pattern = field.x in Parser.err ~start_pos:pattern.Parsetree.ppat_loc.loc_start p (Diagnostics.message ErrorMessages.record_pattern_spread)); (field :: fields, flag) @@ -1389,7 +1389,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, pat, optional) + Some {Parsetree.lid = fieldName; x = pat; opt = optional} | _ -> None and parse_dict_pattern ~start_pos ~attrs (p : Parser.t) = @@ -2885,7 +2885,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, false) + parse_record_expr_with_string_keys ~start_pos + {Parsetree.lid = field; x = field_expr; opt = false} p in Parser.expect Rbrace p; @@ -2956,7 +2957,9 @@ and parse_braced_or_record_expr p = in let expr = parse_record_expr ~start_pos - [(path_ident, value_or_constructor, false)] + [ + {Parsetree.lid = path_ident; x = value_or_constructor; opt = false}; + ] p in Parser.expect Rbrace p; @@ -2969,11 +2972,15 @@ and parse_braced_or_record_expr p = | Rbrace -> Parser.next p; let loc = mk_loc start_pos p.prev_end_pos in - Ast_helper.Exp.record ~loc [(path_ident, field_expr, optional)] None + Ast_helper.Exp.record ~loc + [{lid = path_ident; x = field_expr; opt = optional}] + None | _ -> Parser.expect Comma p; let expr = - parse_record_expr ~start_pos [(path_ident, field_expr, optional)] p + parse_record_expr ~start_pos + [{lid = path_ident; x = field_expr; opt = optional}] + p in Parser.expect Rbrace p; expr) @@ -2983,7 +2990,7 @@ and parse_braced_or_record_expr p = Parser.expect Comma p; let expr = parse_record_expr ~start_pos - [(path_ident, value_or_constructor, false)] + [{lid = path_ident; x = value_or_constructor; opt = false}] p in Parser.expect Rbrace p; @@ -2992,7 +2999,7 @@ and parse_braced_or_record_expr p = Parser.expect Colon p; let expr = parse_record_expr ~start_pos - [(path_ident, value_or_constructor, false)] + [{lid = path_ident; x = value_or_constructor; opt = false}] p in Parser.expect Rbrace p; @@ -3107,7 +3114,8 @@ and parse_braced_or_record_expr p = let braces = make_braces_attr loc in {expr with pexp_attributes = braces :: expr.pexp_attributes} -and parse_record_expr_row_with_string_key p = +and parse_record_expr_row_with_string_key p : + Parsetree.expression Parsetree.record_element option = match p.Parser.token with | String s -> ( let loc = mk_loc p.start_pos p.end_pos in @@ -3117,11 +3125,18 @@ and parse_record_expr_row_with_string_key p = | Colon -> Parser.next p; let field_expr = parse_expr p in - Some (field, field_expr, false) - | _ -> Some (field, Ast_helper.Exp.ident ~loc:field.loc field, false)) + Some {lid = field; x = field_expr; opt = false} + | _ -> + Some + { + lid = field; + x = Ast_helper.Exp.ident ~loc:field.loc field; + opt = false; + }) | _ -> None -and parse_record_expr_row p = +and parse_record_expr_row p : + Parsetree.expression Parsetree.record_element option = let attrs = parse_attributes p in let () = match p.Parser.token with @@ -3139,7 +3154,7 @@ and parse_record_expr_row p = Parser.next p; let optional = parse_optional_label p in let field_expr = parse_expr p in - Some (field, field_expr, optional) + Some {lid = field; x = field_expr; opt = optional} | _ -> let value = Ast_helper.Exp.ident ~loc:field.loc ~attrs field in let value = @@ -3147,7 +3162,7 @@ and parse_record_expr_row p = | Uident _ -> remove_module_name_from_punned_field_value value | _ -> value in - Some (field, value, false)) + Some {lid = field; x = value; opt = false}) | Question -> ( Parser.next p; match p.Parser.token with @@ -3160,7 +3175,7 @@ and parse_record_expr_row p = | Uident _ -> remove_module_name_from_punned_field_value value | _ -> value in - Some (field, value, true) + Some {lid = field; x = value; opt = true} | _ -> None) | _ -> None diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 3089dd2b77..a1c1e0fbca 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -2501,9 +2501,8 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun row -> print_pattern_dict_row ~state row cmt_tbl) - rows); + (Ext_list.map rows (fun row -> + print_pattern_dict_row ~state row cmt_tbl)); ]); Doc.if_breaks (Doc.text ",") Doc.nil; Doc.soft_line; @@ -2633,9 +2632,11 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = 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}, - opt ) + | { + lid = {Location.txt = Longident.Lident ident} as longident; + x = {Parsetree.ppat_desc = Ppat_var {txt; _}; ppat_attributes}; + opt; + } when ident = txt -> Doc.concat [ @@ -2643,7 +2644,7 @@ and print_pattern_record_row ~state row cmt_tbl = print_attributes ~state ppat_attributes cmt_tbl; print_lident_path longident cmt_tbl; ] - | longident, pattern, opt -> + | {lid = longident; x = pattern; opt} -> let loc_for_comments = {longident.loc with loc_end = pattern.Parsetree.ppat_loc.loc_end} in @@ -2668,8 +2669,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, opt) : - Longident.t Location.loc * Parsetree.pattern * bool) cmt_tbl = + ({lid = longident; x = pattern; opt} : + Parsetree.pattern Parsetree.record_element) cmt_tbl = let loc_for_comments = {longident.loc with loc_end = pattern.ppat_loc.loc_end} in @@ -3228,10 +3229,8 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = Doc.soft_line; Doc.join ~sep:(Doc.concat [Doc.text ","; Doc.line]) - (List.map - (fun (loc, e, _opt) -> - print_bs_object_row ~state (loc, e) cmt_tbl) - rows); + (Ext_list.map rows (fun {lid; x = e} -> + print_bs_object_row ~state (lid, e) cmt_tbl)); ]); Doc.trailing_comma; Doc.soft_line; @@ -5517,8 +5516,8 @@ and print_direction_flag flag = | Asttypes.Downto -> Doc.text " downto " | Asttypes.Upto -> Doc.text " to " -and print_expression_record_row ~state (lbl, expr, optional) cmt_tbl - punning_allowed = +and print_expression_record_row ~state {lid = lbl; x = expr; opt = optional} + cmt_tbl punning_allowed = let cmt_loc = {lbl.loc with loc_end = expr.pexp_loc.loc_end} in let doc = Doc.group