From c00d32e5a2ed148c3e8a93f40e5badad70420bb6 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:01:57 +0200 Subject: [PATCH 01/40] Refactor constructor arity in parsetree Signed-off-by: Christoph Knittel --- analysis/reanalyze/src/annotation.ml | 9 +- analysis/src/completion_expressions.ml | 86 +++-------- analysis/src/completion_front_end.ml | 68 ++++----- analysis/src/completion_patterns.ml | 65 +++------ analysis/src/dump_ast.ml | 32 ++--- analysis/src/process_attributes.ml | 2 +- analysis/src/signature_help.ml | 38 +++-- analysis/src/type_utils.ml | 10 +- analysis/src/xform.ml | 18 ++- compiler/common/pattern_printer.ml | 18 ++- compiler/ext/config.ml | 4 +- compiler/frontend/ast_derive_js_mapper.ml | 2 +- compiler/frontend/ast_derive_projector.ml | 12 +- compiler/frontend/ast_exp_apply.ml | 12 +- compiler/frontend/ast_literal.ml | 8 +- compiler/frontend/bs_builtin_ppx.ml | 36 ++--- compiler/jsoo/jsoo_playground_main.ml | 6 +- compiler/ml/ast_helper.ml | 15 +- compiler/ml/ast_helper.mli | 8 +- compiler/ml/ast_iterator.ml | 16 ++- compiler/ml/ast_mapper.ml | 42 +++--- compiler/ml/ast_mapper_from0.ml | 83 +++++++++-- compiler/ml/ast_mapper_to0.ml | 70 +++++++-- compiler/ml/ast_payload.ml | 4 +- compiler/ml/depend.ml | 13 +- compiler/ml/error_message_utils.ml | 5 +- compiler/ml/parmatch.ml | 16 +-- compiler/ml/parsetree.ml | 50 ++++--- compiler/ml/pprintast.ml | 66 ++++++--- compiler/ml/printast.ml | 18 +-- compiler/ml/typecore.ml | 63 ++++----- compiler/ml/typetexp.ml | 10 +- compiler/syntax/src/jsx_v4.ml | 6 +- compiler/syntax/src/res_ast_debugger.ml | 30 ++-- compiler/syntax/src/res_comments_table.ml | 38 ++--- compiler/syntax/src/res_core.ml | 133 +++++------------- compiler/syntax/src/res_driver.ml | 10 +- compiler/syntax/src/res_parser.ml | 6 +- compiler/syntax/src/res_parser.mli | 5 +- compiler/syntax/src/res_parsetree_viewer.ml | 8 +- compiler/syntax/src/res_printer.ml | 110 +++++---------- packages/@rescript/belt/src/Belt_List.res | 4 +- packages/@rescript/belt/src/Belt_Map.resi | 2 +- packages/@rescript/belt/src/Belt_MapInt.resi | 2 +- .../@rescript/belt/src/Belt_MapString.resi | 2 +- .../belt/src/Belt_internalAVLtree.res | 2 +- packages/@rescript/runtime/Stdlib_List.res | 4 +- tests/ERROR_VARIANTS.md | 2 +- .../src/expected/CompletionPattern.res.txt | 10 -- .../src/expected/TypeAtPosCompletion.res.txt | 3 +- tests/belt_tests/src/belt_list_test.res | 12 +- ...structor_tuple_arity_mismatch.res.expected | 10 ++ ..._tuple_arity_mismatch_pattern.res.expected | 11 ++ .../constructor_tuple_arity_mismatch.res | 3 + ...nstructor_tuple_arity_mismatch_pattern.res | 6 + .../Cross_inline_record_constructor.expected | 2 +- tests/ounit_tests/ounit_ast_mapper0_tests.ml | 123 ++++++++++++++++ .../data/ast-mapping/ConstructorArguments.res | 25 ++++ .../expected/ConstructorArguments.res.txt | 25 ++++ .../tests/src/constructor_explicit_arity.mjs | 56 ++++++++ .../tests/src/constructor_explicit_arity.res | 25 ++++ tests/tests/src/exception_raise_test.res | 2 +- tests/tests/src/mario_game.res | 12 +- tests/tests/src/tramp_fib.mjs | 4 +- tests/tests/src/tramp_fib.res | 15 +- tests/tests/src/unboxed_attribute.res | 2 +- tests/tests/src/variant.res | 6 +- tools/src/migrate.ml | 8 +- tools/src/transforms.ml | 2 +- 69 files changed, 937 insertions(+), 694 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/constructor_tuple_arity_mismatch.res.expected create mode 100644 tests/build_tests/super_errors/expected/constructor_tuple_arity_mismatch_pattern.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/constructor_tuple_arity_mismatch.res create mode 100644 tests/build_tests/super_errors/fixtures/constructor_tuple_arity_mismatch_pattern.res create mode 100644 tests/syntax_tests/data/ast-mapping/ConstructorArguments.res create mode 100644 tests/syntax_tests/data/ast-mapping/expected/ConstructorArguments.res.txt create mode 100644 tests/tests/src/constructor_explicit_arity.mjs create mode 100644 tests/tests/src/constructor_explicit_arity.res diff --git a/analysis/reanalyze/src/annotation.ml b/analysis/reanalyze/src/annotation.ml index 697c69d4b51..78508436050 100644 --- a/analysis/reanalyze/src/annotation.ml +++ b/analysis/reanalyze/src/annotation.ml @@ -30,10 +30,11 @@ let rec get_attribute_payload check_text (attributes : Typedtree.attributes) = _; } -> Some (BoolPayload (s = "true")) - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> - None - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "::"}, Some e)} -> - from_expr e + | {pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, [])} -> None + | { + pexp_desc = Pexp_construct ({txt = Longident.Lident "::"}, [head; tail]); + } -> + from_expr {expr with pexp_desc = Pexp_tuple [head; tail]} | {pexp_desc = Pexp_construct ({txt}, _); _} -> Some (ConstructPayload (txt |> Longident.flatten |> String.concat ".")) | {pexp_desc = Pexp_tuple exprs | Pexp_array exprs} -> diff --git a/analysis/src/completion_expressions.ml b/analysis/src/completion_expressions.ml index 5c01dd6d1b5..23f52561e16 100644 --- a/analysis/src/completion_expressions.ml +++ b/analysis/src/completion_expressions.ml @@ -24,9 +24,9 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos (txt, [Completable.NRecordBody {seen_fields = []}] @ expr_path) | Pexp_ident {txt = Lident txt} -> some_if_has_cursor (txt, expr_path) | Pexp_construct ({txt = Lident "()"}, _) -> some_if_has_cursor ("", expr_path) - | Pexp_construct ({txt = Lident txt}, None) -> + | Pexp_construct ({txt = Lident txt}, []) -> some_if_has_cursor (txt, expr_path) - | Pexp_variant (label, None) -> some_if_has_cursor ("#" ^ label, expr_path) + | Pexp_variant (label, []) -> some_if_has_cursor ("#" ^ label, expr_path) | Pexp_array array_patterns -> ( let next_expr_path = [Completable.NArray] @ expr_path in (* No fields but still has cursor = empty completion *) @@ -121,8 +121,7 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos ("", [Completable.NRecordBody {seen_fields}] @ expr_path) | _ -> None)) | Pexp_construct - ( {txt}, - Some {pexp_loc; pexp_desc = Pexp_construct ({txt = Lident "()"}, _)} ) + ({txt}, [{pexp_loc; pexp_desc = Pexp_construct ({txt = Lident "()"}, _)}]) when loc_has_cursor pexp_loc -> (* Empty payload with cursor, like: Test() *) Some @@ -132,21 +131,24 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos {constructor_name = Utils.get_unqualified_name txt; item_num = 0}; ] @ expr_path ) - | Pexp_construct ({txt}, Some e) - when pos >= (e.pexp_loc |> Loc.end_) + | Pexp_construct ({txt}, args) + when args <> [] + && pos >= ((Ext_list.last args).pexp_loc |> Loc.end_) && first_char_before_cursor_no_white = Some ',' - && is_expr_tuple e = false -> + && is_expr_tuple (Ext_list.last args) = false -> (* Empty payload with trailing ',', like: Test(true, ) *) Some ( "", [ Completable.NVariantPayload - {constructor_name = Utils.get_unqualified_name txt; item_num = 1}; + { + constructor_name = Utils.get_unqualified_name txt; + item_num = List.length args; + }; ] @ expr_path ) - | Pexp_construct ({txt}, Some {pexp_loc; pexp_desc = Pexp_tuple tuple_items}) - when loc_has_cursor pexp_loc -> - tuple_items + | Pexp_construct ({txt}, args) when loc_has_cursor exp.pexp_loc -> + args |> traverse_expr_tuple_items ~first_char_before_cursor_no_white ~pos ~next_expr_path:(fun item_num -> [ @@ -163,38 +165,16 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos }; ] @ expr_path) - | Pexp_construct ({txt}, Some p) when loc_has_cursor exp.pexp_loc -> - p - |> traverse_expr ~first_char_before_cursor_no_white ~pos - ~expr_path: - ([ - Completable.NVariantPayload - { - constructor_name = Utils.get_unqualified_name txt; - item_num = 0; - }; - ] - @ expr_path) | Pexp_variant - (txt, Some {pexp_loc; pexp_desc = Pexp_construct ({txt = Lident "()"}, _)}) + (txt, [{pexp_loc; pexp_desc = Pexp_construct ({txt = Lident "()"}, _)}]) when loc_has_cursor pexp_loc -> (* Empty payload with cursor, like: #test() *) Some ( "", [Completable.NPolyvariantPayload {constructor_name = txt; item_num = 0}] @ expr_path ) - | Pexp_variant (txt, Some e) - when pos >= (e.pexp_loc |> Loc.end_) - && first_char_before_cursor_no_white = Some ',' - && is_expr_tuple e = false -> - (* Empty payload with trailing ',', like: #test(true, ) *) - Some - ( "", - [Completable.NPolyvariantPayload {constructor_name = txt; item_num = 1}] - @ expr_path ) - | Pexp_variant (txt, Some {pexp_loc; pexp_desc = Pexp_tuple tuple_items}) - when loc_has_cursor pexp_loc -> - tuple_items + | Pexp_variant (txt, args) when loc_has_cursor exp.pexp_loc -> + args |> traverse_expr_tuple_items ~first_char_before_cursor_no_white ~pos ~next_expr_path:(fun item_num -> [Completable.NPolyvariantPayload {constructor_name = txt; item_num}] @@ -205,15 +185,6 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos {constructor_name = txt; item_num = item_num + 1}; ] @ expr_path) - | Pexp_variant (txt, Some p) when loc_has_cursor exp.pexp_loc -> - p - |> traverse_expr ~first_char_before_cursor_no_white ~pos - ~expr_path: - ([ - Completable.NPolyvariantPayload - {constructor_name = txt; item_num = 0}; - ] - @ expr_path) | _ -> None and traverse_expr_tuple_items tuple_items ~next_expr_path @@ -280,7 +251,7 @@ let pretty_print_fn_template_arg_name ?current_index ~env ~state ~full | _ -> default_var_name) let complete_constructor_payload ~pos_before_cursor - ~first_char_before_cursor_no_white + ~first_char_before_cursor_no_white ~item_num (constructor_lid : Longident.t Location.loc) expr = match traverse_expr expr ~expr_path:[] ~pos:pos_before_cursor @@ -288,27 +259,10 @@ let complete_constructor_payload ~pos_before_cursor with | None -> None | Some (prefix, nested) -> - (* The nested path must start with the constructor name found, plus - the target argument number for the constructor. We translate to - that here, because we need to account for multi arg constructors - being represented as tuples. *) let nested = - match List.rev nested with - | Completable.NTupleItem {item_num} :: rest -> - [ - Completable.NVariantPayload - {constructor_name = Longident.last constructor_lid.txt; item_num}; - ] - @ rest - | nested -> - [ - Completable.NVariantPayload - { - constructor_name = Longident.last constructor_lid.txt; - item_num = 0; - }; - ] - @ nested + Completable.NVariantPayload + {constructor_name = Longident.last constructor_lid.txt; item_num} + :: List.rev nested in let variant_ctx_path = Completable.CTypeAtPos diff --git a/analysis/src/completion_front_end.ml b/analysis/src/completion_front_end.ml index d7bcb568219..24874f4a4b7 100644 --- a/analysis/src/completion_front_end.ml +++ b/analysis/src/completion_front_end.ml @@ -222,7 +222,7 @@ let rec expr_to_context_path_inner ~(in_jsx_context : bool) | None -> None) | Pexp_constant (Pconst_integer _) -> Some CPInt | Pexp_constant (Pconst_float _) -> Some CPFloat - | Pexp_construct ({txt = Lident ("true" | "false")}, None) -> Some CPBool + | Pexp_construct ({txt = Lident ("true" | "false")}, []) -> Some CPBool | Pexp_array exprs -> Some (CPArray @@ -492,9 +492,9 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file scope_pattern p ~pattern_path:(NTupleItem {item_num = index} :: pattern_path) ?context_path) - | Ppat_construct (_, None) -> () - | Ppat_construct ({txt}, Some {ppat_desc = Ppat_tuple pl}) -> - pl + | Ppat_construct (_, []) -> () + | Ppat_construct ({txt}, patterns) -> + patterns |> List.iteri (fun index p -> scope_pattern p ~pattern_path: @@ -505,28 +505,15 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file } :: pattern_path) ?context_path) - | Ppat_construct ({txt}, Some p) -> - scope_pattern - ~pattern_path: - (NVariantPayload - {item_num = 0; constructor_name = Utils.get_unqualified_name txt} - :: pattern_path) - ?context_path p - | Ppat_variant (_, None) -> () - | Ppat_variant (txt, Some {ppat_desc = Ppat_tuple pl}) -> - pl + | Ppat_variant (_, []) -> () + | Ppat_variant (txt, patterns) -> + patterns |> List.iteri (fun index p -> scope_pattern p ~pattern_path: (NPolyvariantPayload {item_num = index; constructor_name = txt} :: pattern_path) ?context_path) - | Ppat_variant (txt, Some p) -> - scope_pattern - ~pattern_path: - (NPolyvariantPayload {item_num = 0; constructor_name = txt} - :: pattern_path) - ?context_path p | Ppat_record (fields, _, rest) -> ( Ext_list.iter fields (fun {lid = fname; x = p} -> match fname with @@ -1049,7 +1036,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file Pstr_eval ( { pexp_loc; - pexp_desc = Pexp_construct ({txt = path; loc}, None); + pexp_desc = Pexp_construct ({txt = path; loc}, []); }, _ ); }; @@ -1289,17 +1276,21 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file then ValueOrField else Value); })) - | Pexp_construct (lid, e_opt) -> ( + | Pexp_construct (lid, args) -> let lid_path = flatten_lid_check_dot lid in if debug then Printf.printf "Pexp_construct %s:%s %s\n" (lid_path |> String.concat "\n") (Loc.to_string lid.loc) - (match e_opt with - | None -> "None" - | Some e -> Loc.to_string e.pexp_loc); + (match args with + | [] -> "None" + | args -> + args + |> List.map (fun (e : Parsetree.expression) -> + Loc.to_string e.pexp_loc) + |> String.concat ", "); if - e_opt = None && (not lid.loc.loc_ghost) + args = [] && (not lid.loc.loc_ghost) && lid.loc |> Loc.has_pos ~pos:pos_before_cursor then set_result @@ -1307,18 +1298,19 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file (CPId {loc = lid.loc; path = lid_path; completion_context = Value})) else - match e_opt with - | Some e when loc_has_cursor e.pexp_loc -> ( - match - Completion_expressions.complete_constructor_payload - ~pos_before_cursor ~first_char_before_cursor_no_white lid e - with - | Some result -> - (* Check if anything else more important completes before setting this completion. *) - Ast_iterator.default_iterator.expr iterator e; - set_result result - | None -> ()) - | _ -> ()) + args + |> List.iteri (fun item_num (e : Parsetree.expression) -> + if loc_has_cursor e.pexp_loc then + match + Completion_expressions.complete_constructor_payload + ~pos_before_cursor ~first_char_before_cursor_no_white + ~item_num lid e + with + | Some result -> + (* Check if anything else more important completes before setting this completion. *) + Ast_iterator.default_iterator.expr iterator e; + set_result result + | None -> ()) | Pexp_field (e, field_name) -> ( if debug then Printf.printf "Pexp_field %s %s:%s\n" (Loc.to_string e.pexp_loc) diff --git a/analysis/src/completion_patterns.ml b/analysis/src/completion_patterns.ml index 706b4d924b3..f52b3dcef2a 100644 --- a/analysis/src/completion_patterns.ml +++ b/analysis/src/completion_patterns.ml @@ -86,14 +86,14 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor lot. *) some_if_has_cursor ("", pattern_path) "Ppat_any" | Ppat_var {txt} -> some_if_has_cursor (txt, pattern_path) "Ppat_var" - | Ppat_construct ({txt = Lident "()"}, None) -> + | Ppat_construct ({txt = Lident "()"}, []) -> (* switch s { | () }*) some_if_has_cursor ("", pattern_path @ [Completable.NTupleItem {item_num = 0}]) "Ppat_construct()" - | Ppat_construct ({txt = Lident prefix}, None) -> + | Ppat_construct ({txt = Lident prefix}, []) -> some_if_has_cursor (prefix, pattern_path) "Ppat_construct(Lident)" - | Ppat_variant (prefix, None) -> + | Ppat_variant (prefix, []) -> some_if_has_cursor ("#" ^ prefix, pattern_path) "Ppat_variant" | Ppat_array array_patterns -> let next_pattern_path = [Completable.NArray] @ pattern_path in @@ -179,8 +179,7 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor "firstCharBeforeCursorNoWhite:," | _ -> None)) | Ppat_construct - ( {txt}, - Some {ppat_loc; ppat_desc = Ppat_construct ({txt = Lident "()"}, _)} ) + ({txt}, [{ppat_loc; ppat_desc = Ppat_construct ({txt = Lident "()"}, _)}]) when loc_has_cursor ppat_loc -> (* Empty payload with cursor, like: Test() *) Some @@ -190,21 +189,24 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor {constructor_name = Utils.get_unqualified_name txt; item_num = 0}; ] @ pattern_path ) - | Ppat_construct ({txt}, Some pat) - when pos_before_cursor >= (pat.ppat_loc |> Loc.end_) + | Ppat_construct ({txt}, patterns) + when patterns <> [] + && pos_before_cursor >= ((Ext_list.last patterns).ppat_loc |> Loc.end_) && first_char_before_cursor_no_white = Some ',' - && is_pattern_tuple pat = false -> + && is_pattern_tuple (Ext_list.last patterns) = false -> (* Empty payload with trailing ',', like: Test(true, ) *) Some ( "", [ Completable.NVariantPayload - {constructor_name = Utils.get_unqualified_name txt; item_num = 1}; + { + constructor_name = Utils.get_unqualified_name txt; + item_num = List.length patterns; + }; ] @ pattern_path ) - | Ppat_construct ({txt}, Some {ppat_loc; ppat_desc = Ppat_tuple tuple_items}) - when loc_has_cursor ppat_loc -> - tuple_items + | Ppat_construct ({txt}, patterns) when loc_has_cursor pat.ppat_loc -> + patterns |> traverse_tuple_items ~loc_has_cursor ~first_char_before_cursor_no_white ~pos_before_cursor ~next_pattern_path:(fun item_num -> @@ -222,39 +224,16 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor }; ] @ pattern_path) - | Ppat_construct ({txt}, Some p) when loc_has_cursor pat.ppat_loc -> - p - |> traverse_pattern ~loc_has_cursor ~first_char_before_cursor_no_white - ~pos_before_cursor - ~pattern_path: - ([ - Completable.NVariantPayload - { - constructor_name = Utils.get_unqualified_name txt; - item_num = 0; - }; - ] - @ pattern_path) | Ppat_variant - (txt, Some {ppat_loc; ppat_desc = Ppat_construct ({txt = Lident "()"}, _)}) + (txt, [{ppat_loc; ppat_desc = Ppat_construct ({txt = Lident "()"}, _)}]) when loc_has_cursor ppat_loc -> (* Empty payload with cursor, like: #test() *) Some ( "", [Completable.NPolyvariantPayload {constructor_name = txt; item_num = 0}] @ pattern_path ) - | Ppat_variant (txt, Some pat) - when pos_before_cursor >= (pat.ppat_loc |> Loc.end_) - && first_char_before_cursor_no_white = Some ',' - && is_pattern_tuple pat = false -> - (* Empty payload with trailing ',', like: #test(true, ) *) - Some - ( "", - [Completable.NPolyvariantPayload {constructor_name = txt; item_num = 1}] - @ pattern_path ) - | Ppat_variant (txt, Some {ppat_loc; ppat_desc = Ppat_tuple tuple_items}) - when loc_has_cursor ppat_loc -> - tuple_items + | Ppat_variant (txt, patterns) when loc_has_cursor pat.ppat_loc -> + patterns |> traverse_tuple_items ~loc_has_cursor ~first_char_before_cursor_no_white ~pos_before_cursor ~next_pattern_path:(fun item_num -> @@ -266,14 +245,4 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor {constructor_name = txt; item_num = item_num + 1}; ] @ pattern_path) - | Ppat_variant (txt, Some p) when loc_has_cursor pat.ppat_loc -> - p - |> traverse_pattern ~loc_has_cursor ~first_char_before_cursor_no_white - ~pos_before_cursor - ~pattern_path: - ([ - Completable.NPolyvariantPayload - {constructor_name = txt; item_num = 0}; - ] - @ pattern_path) | _ -> None diff --git a/analysis/src/dump_ast.ml b/analysis/src/dump_ast.ml index 2eb536e7af0..f6348ef0ea6 100644 --- a/analysis/src/dump_ast.ml +++ b/analysis/src/dump_ast.ml @@ -98,19 +98,19 @@ let rec print_pattern pattern ~pos ~indentation = | Ppat_var ({txt} as loc) -> "Ppat_var(" ^ (loc |> print_loc_denominator_loc ~pos) ^ txt ^ ")" | Ppat_constant const -> "Ppat_constant(" ^ print_constant const ^ ")" - | Ppat_construct (({txt} as loc), maybe_pat) -> + | Ppat_construct (({txt} as loc), patterns) -> "Ppat_construct(" ^ (loc |> print_loc_denominator_loc ~pos) ^ (Utils.flatten_long_ident txt |> ident |> str) - ^ (match maybe_pat with - | None -> "" - | Some pat -> "," ^ print_pattern pat ~pos ~indentation) + ^ (patterns + |> List.map (fun pat -> "," ^ print_pattern pat ~pos ~indentation) + |> String.concat "") ^ ")" - | Ppat_variant (label, maybe_pat) -> + | Ppat_variant (label, patterns) -> "Ppat_variant(" ^ str label - ^ (match maybe_pat with - | None -> "" - | Some pat -> "," ^ print_pattern pat ~pos ~indentation) + ^ (patterns + |> List.map (fun pat -> "," ^ print_pattern pat ~pos ~indentation) + |> String.concat "") ^ ")" | Ppat_record (fields, _, rest) -> "Ppat_record(\n" @@ -231,19 +231,19 @@ and print_expr_item expr ~pos ~indentation = ^ add_indentation indentation ^ ")" | Pexp_constant constant -> "Pexp_constant(" ^ print_constant constant ^ ")" - | Pexp_construct (({txt} as loc), maybe_expr) -> + | Pexp_construct (({txt} as loc), exprs) -> "Pexp_construct(" ^ (loc |> print_loc_denominator_loc ~pos) ^ (Utils.flatten_long_ident txt |> ident |> str) - ^ (match maybe_expr with - | None -> "" - | Some expr -> ", " ^ print_expr_item expr ~pos ~indentation) + ^ (exprs + |> List.map (fun expr -> ", " ^ print_expr_item expr ~pos ~indentation) + |> String.concat "") ^ ")" - | Pexp_variant (label, maybe_expr) -> + | Pexp_variant (label, exprs) -> "Pexp_variant(" ^ str label - ^ (match maybe_expr with - | None -> "" - | Some expr -> "," ^ print_expr_item expr ~pos ~indentation) + ^ (exprs + |> List.map (fun expr -> "," ^ print_expr_item expr ~pos ~indentation) + |> String.concat "") ^ ")" | Pexp_fun {params = {p_lbl = arg; p_pat = pattern} :: _; body = next_expr} -> "Pexp_fun(\n" diff --git a/analysis/src/process_attributes.ml b/analysis/src/process_attributes.ml index ccbb057426f..068784416b8 100644 --- a/analysis/src/process_attributes.ml +++ b/analysis/src/process_attributes.ml @@ -69,7 +69,7 @@ let rec find_editor_complete_from_attribute ?(module_paths = []) attributes = items |> List.filter_map (fun item -> match item.Parsetree.pexp_desc with - | Pexp_construct ({txt = path}, None) -> + | Pexp_construct ({txt = path}, []) -> Some (Utils.flatten_long_ident path) | _ -> None) in diff --git a/analysis/src/signature_help.ml b/analysis/src/signature_help.ml index d84fe61030c..f493311bd76 100644 --- a/analysis/src/signature_help.ml +++ b/analysis/src/signature_help.ml @@ -400,21 +400,27 @@ let signature_help ~debug ~source ~kind_file ~pos in set_result (exp.pexp_loc, `FunctionCall (arg_at_cursor, exp, extracted_args)) - | {pexp_desc = Pexp_construct (lid, Some payload_exp); pexp_loc} - when loc_has_cursor payload_exp.pexp_loc - || Completion_expressions.is_expr_hole payload_exp - && loc_has_cursor pexp_loc -> + | {pexp_desc = Pexp_construct (lid, payload_exps); pexp_loc} + when List.exists + (fun (payload_exp : Parsetree.expression) -> + loc_has_cursor payload_exp.pexp_loc + || Completion_expressions.is_expr_hole payload_exp + && loc_has_cursor pexp_loc) + payload_exps -> (* Constructor payloads *) - set_result (lid.loc, `ConstructorExpr (lid, payload_exp)) + set_result (lid.loc, `ConstructorExpr (lid, payload_exps)) | _ -> ()); Ast_iterator.default_iterator.expr iterator expr in let pat (iterator : Ast_iterator.iterator) (pat : Parsetree.pattern) = (match pat with - | {ppat_desc = Ppat_construct (lid, Some payload_pat)} - when loc_has_cursor payload_pat.ppat_loc -> + | {ppat_desc = Ppat_construct (lid, payload_pats)} + when List.exists + (fun (payload_pat : Parsetree.pattern) -> + loc_has_cursor payload_pat.ppat_loc) + payload_pats -> (* Constructor payloads *) - set_result (lid.loc, `ConstructorPat (lid, payload_pat)) + set_result (lid.loc, `ConstructorPat (lid, payload_pats)) | _ -> ()); Ast_iterator.default_iterator.pat iterator pat in @@ -623,7 +629,7 @@ let signature_help ~debug ~source ~kind_file ~pos in let active_parameter = match cs with - | `ConstructorExpr (_, {pexp_desc = Pexp_tuple items}) -> ( + | `ConstructorExpr (_, items) when List.length items > 1 -> ( let idx = ref 0 in let tuple_item_with_cursor = items @@ -636,7 +642,8 @@ let signature_help ~debug ~source ~kind_file ~pos match tuple_item_with_cursor with | None -> -1 | Some i -> i) - | `ConstructorExpr (_, {pexp_desc = Pexp_record (fields, _)}) -> ( + | `ConstructorExpr (_, [{pexp_desc = Pexp_record (fields, _)}]) + -> ( let field_name_with_cursor = fields |> List.find_map @@ -664,9 +671,10 @@ let signature_help ~debug ~source ~kind_file ~pos else ()); !field_index | _ -> -1) - | `ConstructorExpr (_, expr) when loc_has_cursor expr.pexp_loc -> + | `ConstructorExpr (_, [expr]) when loc_has_cursor expr.pexp_loc + -> 0 - | `ConstructorPat (_, {ppat_desc = Ppat_tuple items}) -> ( + | `ConstructorPat (_, items) when List.length items > 1 -> ( let idx = ref 0 in let tuple_item_with_cursor = items @@ -679,8 +687,8 @@ let signature_help ~debug ~source ~kind_file ~pos match tuple_item_with_cursor with | None -> -1 | Some i -> i) - | `ConstructorPat (_, {ppat_desc = Ppat_record (fields, _, _rest)}) - -> ( + | `ConstructorPat + (_, [{ppat_desc = Ppat_record (fields, _, _rest)}]) -> ( let field_name_with_cursor = fields |> List.find_map @@ -708,7 +716,7 @@ let signature_help ~debug ~source ~kind_file ~pos else ()); !field_index | _ -> -1) - | `ConstructorPat (_, pat) when loc_has_cursor pat.ppat_loc -> 0 + | `ConstructorPat (_, [pat]) when loc_has_cursor pat.ppat_loc -> 0 | _ -> -1 in diff --git a/analysis/src/type_utils.ml b/analysis/src/type_utils.ml index 5f5cedfaffa..0fb50cd9e03 100644 --- a/analysis/src/type_utils.ml +++ b/analysis/src/type_utils.ml @@ -1014,9 +1014,15 @@ module Codegen = struct let mk_construct_pat ?payload name = Ast_helper.Pat.construct {Asttypes.txt = Longident.Lident name; loc = Location.none} - payload + (match payload with + | None -> [] + | Some payload -> [payload]) - let mk_tag_pat ?payload name = Ast_helper.Pat.variant name payload + let mk_tag_pat ?payload name = + Ast_helper.Pat.variant name + (match payload with + | None -> [] + | Some payload -> [payload]) let any () = Ast_helper.Pat.any () diff --git a/analysis/src/xform.ml b/analysis/src/xform.ml index 2bb2c1d88ba..d921bfa2343 100644 --- a/analysis/src/xform.ml +++ b/analysis/src/xform.ml @@ -55,16 +55,14 @@ module If_then_else = struct Ast_helper.Pat.mk ~loc:exp.pexp_loc ~attrs:exp.pexp_attributes ppat_desc in match exp.pexp_desc with - | Pexp_construct (lid, None) -> Some (mk_pat (Ppat_construct (lid, None))) - | Pexp_construct (lid, Some e1) -> ( - match exp_to_pat e1 with + | Pexp_construct (lid, exprs) -> ( + match list_to_pat ~item_to_pat:exp_to_pat exprs with | None -> None - | Some p1 -> Some (mk_pat (Ppat_construct (lid, Some p1)))) - | Pexp_variant (label, None) -> Some (mk_pat (Ppat_variant (label, None))) - | Pexp_variant (label, Some e1) -> ( - match exp_to_pat e1 with + | Some patterns -> Some (mk_pat (Ppat_construct (lid, patterns)))) + | Pexp_variant (label, exprs) -> ( + match list_to_pat ~item_to_pat:exp_to_pat exprs with | None -> None - | Some p1 -> Some (mk_pat (Ppat_variant (label, Some p1)))) + | Some patterns -> Some (mk_pat (Ppat_variant (label, patterns)))) | Pexp_constant c -> Some (mk_pat (Ppat_constant c)) | Pexp_template {source_segments = [{txt = source}]; values = []} -> ( match String_literal.decode_js_template_escapes source with @@ -408,8 +406,8 @@ module Expand_catch_all_for_variants = struct ?(mode : [`option | `default] = `default) ?(constructor_names = []) (p : Parsetree.pattern) = match p.ppat_desc with - | Ppat_construct ({txt = Lident "Some"}, Some payload) - when mode = `option -> + | Ppat_construct ({txt = Lident "Some"}, [payload]) when mode = `option + -> find_all_constructor_names ~mode ~constructor_names payload | Ppat_construct ({txt}, _) -> Longident.last txt :: constructor_names | Ppat_variant (name, _) -> name :: constructor_names diff --git a/compiler/common/pattern_printer.ml b/compiler/common/pattern_printer.ml index de47287bddd..aa2bcf5f5b0 100644 --- a/compiler/common/pattern_printer.ml +++ b/compiler/common/pattern_printer.ml @@ -47,7 +47,7 @@ let[@warning "-4"] rec classify_optional_field_state pat = | _ -> Field_normal let none_pattern = - mkpat (Ppat_construct (mknoloc (Longident.Lident "None"), None)) + mkpat (Ppat_construct (mknoloc (Longident.Lident "None"), [])) let[@warning "-4"] strip_synthetic_some pat = match pat.pat_desc with @@ -71,16 +71,14 @@ let untype typed = | Tpat_tuple lst -> mkpat (Ppat_tuple (List.map loop lst)) | Tpat_construct (cstr_lid, cstr, lst) -> let lid = {cstr_lid with txt = Longident.Lident cstr.cstr_name} in - let arg = - match List.map loop lst with - | [] -> None - | [p] -> Some p - | lst -> Some (mkpat (Ppat_tuple lst)) - in - mkpat (Ppat_construct (lid, arg)) + mkpat (Ppat_construct (lid, List.map loop lst)) | Tpat_variant (label, p_opt, _row_desc) -> - let arg = Option.map loop p_opt in - mkpat (Ppat_variant (label, arg)) + let args = + match p_opt with + | None -> [] + | Some p -> [loop p] + in + mkpat (Ppat_variant (label, args)) | Tpat_record (subpatterns, closed_flag, rest) -> let fields, saw_optional_rewrite = List.fold_right diff --git a/compiler/ext/config.ml b/compiler/ext/config.ml index dec9d67d4de..ab2051670b1 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -2,9 +2,9 @@ let cmi_magic_number = "Caml1999I032" (* Magic numbers for marshaled values of the *current* parsetree, whose layout changes across compiler versions. *) -and ast_impl_magic_number = "ResImpl01306" +and ast_impl_magic_number = "ResImpl01307" -and ast_intf_magic_number = "ResIntf01306" +and ast_intf_magic_number = "ResIntf01307" (* Magic numbers of the frozen Parsetree0 (OCaml 4.06) layout used on the external-PPX wire. They must never be written in front of a diff --git a/compiler/frontend/ast_derive_js_mapper.ml b/compiler/frontend/ast_derive_js_mapper.ml index ea8fb63837d..ea0410bf519 100644 --- a/compiler/frontend/ast_derive_js_mapper.ml +++ b/compiler/frontend/ast_derive_js_mapper.ml @@ -50,7 +50,7 @@ let handle_config (config : Parsetree.expression option) = { pexp_desc = ( Pexp_construct - ({txt = Lident (("true" | "false") as x)}, None) + ({txt = Lident (("true" | "false") as x)}, []) | Pexp_ident {txt = Lident ("newType" as x)} ); }; }; diff --git a/compiler/frontend/ast_derive_projector.ml b/compiler/frontend/ast_derive_projector.ml index 3203b116087..9b3cdb7afa1 100644 --- a/compiler/frontend/ast_derive_projector.ml +++ b/compiler/frontend/ast_derive_projector.ml @@ -83,7 +83,7 @@ let init () = Exp.constraint_ (Exp.construct {loc; txt = Longident.Lident con_name} - None) + []) annotate_type else let vars = @@ -94,14 +94,8 @@ let init () = Exp.constraint_ (Exp.construct {loc; txt = Longident.Lident con_name} - @@ Some - (if arity = 1 then - Exp.ident - {loc; txt = Lident (List.hd vars)} - else - Exp.tuple - (Ext_list.map vars (fun x -> - Exp.ident {loc; txt = Lident x})))) + @@ Ext_list.map vars (fun x -> + Exp.ident {loc; txt = Lident x})) annotate_type in Ast_helper.Exp.fun_ diff --git a/compiler/frontend/ast_exp_apply.ml b/compiler/frontend/ast_exp_apply.ml index 5f4924bb272..c857031c886 100644 --- a/compiler/frontend/ast_exp_apply.ml +++ b/compiler/frontend/ast_exp_apply.ml @@ -80,10 +80,10 @@ let app_exp_mapper (e : exp) (self : Ast_mapper.mapper) : exp = let a = self.expr self a_ in let f = self.expr self f_ in match f.pexp_desc with - | Pexp_variant (label, None) -> - {f with pexp_desc = Pexp_variant (label, Some a); pexp_loc = e.pexp_loc} - | Pexp_construct (ctor, None) -> - {f with pexp_desc = Pexp_construct (ctor, Some a); pexp_loc = e.pexp_loc} + | Pexp_variant (label, []) -> + {f with pexp_desc = Pexp_variant (label, [a]); pexp_loc = e.pexp_loc} + | Pexp_construct (ctor, []) -> + {f with pexp_desc = Pexp_construct (ctor, [a]); pexp_loc = e.pexp_loc} | Pexp_apply {funct = fn1; args; partial; transformed_jsx} -> Bs_ast_invariant.warn_discarded_unused_attributes fn1.pexp_attributes; { @@ -100,10 +100,10 @@ let app_exp_mapper (e : exp) (self : Ast_mapper.mapper) : exp = Pexp_tuple (Ext_list.map xs (fun fn -> match fn.pexp_desc with - | Pexp_construct (ctor, None) -> + | Pexp_construct (ctor, []) -> { fn with - pexp_desc = Pexp_construct (ctor, Some bounded_obj_arg); + pexp_desc = Pexp_construct (ctor, [bounded_obj_arg]); } | Pexp_apply {funct = fn; args; transformed_jsx} -> Bs_ast_invariant.warn_discarded_unused_attributes diff --git a/compiler/frontend/ast_literal.ml b/compiler/frontend/ast_literal.ml index 97ff7c1c56d..a351c5359ea 100644 --- a/compiler/frontend/ast_literal.ml +++ b/compiler/frontend/ast_literal.ml @@ -65,7 +65,7 @@ end module No_loc = struct let loc = Location.none - let val_unit = Ast_helper.Exp.construct {txt = Lid.val_unit; loc} None + let val_unit = Ast_helper.Exp.construct {txt = Lid.val_unit; loc} [] let type_unit = Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_unit; loc}, [])) @@ -86,7 +86,7 @@ module No_loc = struct let type_any = Ast_helper.Typ.any () - let pat_unit = Pat.construct {txt = Lid.val_unit; loc} None + let pat_unit = Pat.construct {txt = Lid.val_unit; loc} [] end type 'a lit = ?loc:Location.t -> unit -> 'a @@ -100,7 +100,7 @@ type pattern_lit = Parsetree.pattern lit let val_unit ?loc () = match loc with | None -> No_loc.val_unit - | Some loc -> Ast_helper.Exp.construct {txt = Lid.val_unit; loc} None + | Some loc -> Ast_helper.Exp.construct {txt = Lid.val_unit; loc} [] let type_unit ?loc () = match loc with @@ -150,4 +150,4 @@ let type_any ?loc () = let pat_unit ?loc () = match loc with | None -> No_loc.pat_unit - | Some loc -> Pat.construct ~loc {txt = Lid.val_unit; loc} None + | Some loc -> Pat.construct ~loc {txt = Lid.val_unit; loc} [] diff --git a/compiler/frontend/bs_builtin_ppx.ml b/compiler/frontend/bs_builtin_ppx.ml index 25fc5eb04f2..6782c191b82 100644 --- a/compiler/frontend/bs_builtin_ppx.ml +++ b/compiler/frontend/bs_builtin_ppx.ml @@ -164,12 +164,12 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) ( b, [ { - pc_lhs = {ppat_desc = Ppat_construct ({txt = Lident "true"}, None)}; + pc_lhs = {ppat_desc = Ppat_construct ({txt = Lident "true"}, [])}; pc_guard = None; pc_rhs = t_exp; }; { - pc_lhs = {ppat_desc = Ppat_construct ({txt = Lident "false"}, None)}; + pc_lhs = {ppat_desc = Ppat_construct ({txt = Lident "false"}, [])}; pc_guard = None; pc_rhs = f_exp; }; @@ -178,12 +178,12 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) ( b, [ { - pc_lhs = {ppat_desc = Ppat_construct ({txt = Lident "false"}, None)}; + pc_lhs = {ppat_desc = Ppat_construct ({txt = Lident "false"}, [])}; pc_guard = None; pc_rhs = f_exp; }; { - pc_lhs = {ppat_desc = Ppat_construct ({txt = Lident "true"}, None)}; + pc_lhs = {ppat_desc = Ppat_construct ({txt = Lident "true"}, [])}; pc_guard = None; pc_rhs = t_exp; }; @@ -204,13 +204,13 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) { ppat_desc = ( Ppat_construct - ({txt = Lident ("Ok" as variant_name)}, Some _) + ({txt = Lident ("Ok" as variant_name)}, _ :: _) | Ppat_construct - ({txt = Lident ("Error" as variant_name)}, Some _) + ({txt = Lident ("Error" as variant_name)}, _ :: _) | Ppat_construct - ({txt = Lident ("Some" as variant_name)}, Some _) - | Ppat_construct - ({txt = Lident ("None" as variant_name)}, None) ); + ({txt = Lident ("Some" as variant_name)}, _ :: _) + | Ppat_construct ({txt = Lident ("None" as variant_name)}, []) + ); } as pvb_pat; pvb_expr; pvb_constraint = None; @@ -245,7 +245,7 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) (* Extract the variable name from the pattern (e.g., myVar from Some(myVar)) *) let var_name = match pvb_pat.ppat_desc with - | Ppat_construct (_, Some inner_pat) -> ( + | Ppat_construct (_, [inner_pat]) -> ( match Ast_pat.is_single_variable_pattern_conservative inner_pat with | Some name when name <> "" -> name | _ -> "x") @@ -261,7 +261,7 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) Ast_helper.Pat.alias (Ast_helper.Pat.construct ~loc {txt = Lident "Error"; loc} - (Some (Ast_helper.Pat.any ~loc ()))) + [Ast_helper.Pat.any ~loc ()]) {txt = var_name; loc}; pc_guard = None; pc_rhs = Ast_helper.Exp.ident ~loc {txt = Lident var_name; loc}; @@ -273,7 +273,7 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) pc_lhs = Ast_helper.Pat.alias (Ast_helper.Pat.construct ~loc {txt = Lident "Ok"; loc} - (Some (Ast_helper.Pat.any ~loc ()))) + [Ast_helper.Pat.any ~loc ()]) {txt = var_name; loc}; pc_guard = None; pc_rhs = Ast_helper.Exp.ident ~loc {txt = Lident var_name; loc}; @@ -284,7 +284,7 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) Parsetree.pc_bar = None; pc_lhs = Ast_helper.Pat.alias - (Ast_helper.Pat.construct ~loc {txt = Lident "None"; loc} None) + (Ast_helper.Pat.construct ~loc {txt = Lident "None"; loc} []) {txt = var_name; loc}; pc_guard = None; pc_rhs = Ast_helper.Exp.ident ~loc {txt = Lident var_name; loc}; @@ -296,7 +296,7 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) pc_lhs = Ast_helper.Pat.alias (Ast_helper.Pat.construct ~loc {txt = Lident "Some"; loc} - (Some (Ast_helper.Pat.any ~loc ()))) + [Ast_helper.Pat.any ~loc ()]) {txt = var_name; loc}; pc_guard = None; pc_rhs = Ast_helper.Exp.ident ~loc {txt = Lident var_name; loc}; @@ -501,7 +501,7 @@ let signature_item_mapper (self : mapper) (sigi : Parsetree.signature_item) : pval_attributes = []; }; } - | Pexp_construct ({txt = Lident (("true" | "false") as txt)}, None) -> + | Pexp_construct ({txt = Lident (("true" | "false") as txt)}, []) -> succeed attr pval_attributes; { sigi with @@ -616,8 +616,8 @@ let structure_item_mapper (self : mapper) (str : Parsetree.structure_item) : pval_prim = Some (Ast_external_mk.inline_float s); }; } - | ( Some attr, - Pexp_construct ({txt = Lident (("true" | "false") as txt)}, None) ) -> + | Some attr, Pexp_construct ({txt = Lident (("true" | "false") as txt)}, []) + -> succeed attr pvb_attributes; { str with @@ -797,7 +797,7 @@ let rec structure_mapper ~await_context (self : mapper) (stru : Ast_structure.t) | Pexp_let (_, vbs, expr) -> aux expr @ spelunk_vbs acc vbs | Pexp_ifthenelse (_, then_expr, Some else_expr) -> aux then_expr @ aux else_expr - | Pexp_construct (_, Some expr) -> aux expr + | Pexp_construct (_, [expr]) -> aux expr | Pexp_fun {body = expr} -> aux expr | Pexp_constraint (expr, _) -> aux expr | Pexp_match (expr, cases) -> diff --git a/compiler/jsoo/jsoo_playground_main.ml b/compiler/jsoo/jsoo_playground_main.ml index 9d7fc83ff2e..972fec16195 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -255,11 +255,7 @@ module Res_driver = struct open Res_driver (* adds ~src parameter *) - let setup ~src ~filename ~for_printer () = - let mode = - if for_printer then Res_parser.Default else ParseForTypeChecker - in - Res_parser.make ~mode src filename + let setup ~src ~filename ~for_printer:_ () = Res_parser.make src filename (* get full super error message *) let diagnostic_to_string ~(src : string) (d : Res_diagnostics.t) = diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index 8c3bb97b0a0..a02227e71eb 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -119,8 +119,14 @@ module Typ = struct in {t with ptyp_desc = desc} and loop_row_field = function - | Rtag (label, attrs, flag, lst) -> - Rtag (label, attrs, flag, List.map loop lst) + | Rtag (label, attrs, flag, groups) -> + Rtag + ( label, + attrs, + flag, + List.map + (fun ({txt} as group) -> {group with txt = List.map loop txt}) + groups ) | Rinherit t -> Rinherit (loop t) and loop_object_field = function | Otag (label, attrs, t) -> Otag (label, attrs, loop t) @@ -242,7 +248,7 @@ module Exp = struct | None -> let loc = {loc with Location.loc_ghost = true} in let nil = Location.mkloc (Longident.Lident "[]") loc in - construct ~loc nil None) + construct ~loc nil []) | e1 :: el -> let exp_el = handle_seq el in let loc = @@ -253,8 +259,7 @@ module Exp = struct loc_ghost = false; } in - let arg = tuple ~loc [e1; exp_el] in - construct ~loc (Location.mkloc (Longident.Lident "::") loc) (Some arg) + construct ~loc (Location.mkloc (Longident.Lident "::") loc) [e1; exp_el] in let expr = handle_seq seq in {expr with pexp_loc = loc} diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index 7cb4a7104c3..f423e3de368 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -97,8 +97,8 @@ module Pat : sig val constant : ?loc:loc -> ?attrs:attrs -> constant -> pattern val interval : ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern val tuple : ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct : ?loc:loc -> ?attrs:attrs -> lid -> pattern option -> pattern - val variant : ?loc:loc -> ?attrs:attrs -> label -> pattern option -> pattern + val construct : ?loc:loc -> ?attrs:attrs -> lid -> pattern list -> pattern + val variant : ?loc:loc -> ?attrs:attrs -> label -> pattern list -> pattern val record : ?loc:loc -> ?attrs:attrs -> @@ -153,9 +153,9 @@ module Exp : sig val try_ : ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression val tuple : ?loc:loc -> ?attrs:attrs -> expression list -> expression val construct : - ?loc:loc -> ?attrs:attrs -> lid -> expression option -> expression + ?loc:loc -> ?attrs:attrs -> lid -> expression list -> expression val variant : - ?loc:loc -> ?attrs:attrs -> label -> expression option -> expression + ?loc:loc -> ?attrs:attrs -> label -> expression list -> expression val record : ?loc:loc -> ?attrs:attrs -> diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index c94169eb0c6..71b285798c2 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -80,9 +80,13 @@ module T = struct (* Type expressions for the core language *) let row_field sub = function - | Rtag (_, attrs, _, tl) -> + | Rtag (_, attrs, _, groups) -> sub.attributes sub attrs; - List.iter (sub.typ sub) tl + List.iter + (fun {loc; txt} -> + sub.location sub loc; + List.iter (sub.typ sub) txt) + groups | Rinherit t -> sub.typ sub t let object_field sub = function @@ -313,8 +317,8 @@ module E = struct | Pexp_tuple el -> List.iter (sub.expr sub) el | Pexp_construct (lid, arg) -> iter_loc sub lid; - iter_opt (sub.expr sub) arg - | Pexp_variant (_lab, eo) -> iter_opt (sub.expr sub) eo + List.iter (sub.expr sub) arg + | Pexp_variant (_lab, args) -> List.iter (sub.expr sub) args | Pexp_record (l, eo) -> List.iter (fun {lid; x = exp} -> @@ -425,8 +429,8 @@ module P = struct | Ppat_tuple pl -> List.iter (sub.pat sub) pl | Ppat_construct (l, p) -> iter_loc sub l; - iter_opt (sub.pat sub) p - | Ppat_variant (_l, p) -> iter_opt (sub.pat sub) p + List.iter (sub.pat sub) p + | Ppat_variant (_l, args) -> List.iter (sub.pat sub) args | Ppat_record (lpl, _cf, rest) -> List.iter (fun {lid; x = pat} -> diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 327a805ebc2..6b0407bdc4d 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -75,9 +75,15 @@ module T = struct (* Type expressions for the core language *) let row_field sub = function - | Rtag (l, attrs, b, tl) -> + | Rtag (l, attrs, b, groups) -> Rtag - (map_loc sub l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl) + ( map_loc sub l, + sub.attributes sub attrs, + b, + List.map + (fun {loc; txt} -> + {loc = sub.location sub loc; txt = List.map (sub.typ sub) txt}) + groups ) | Rinherit t -> Rinherit (sub.typ sub t) let object_field sub = function @@ -311,9 +317,9 @@ module E = struct | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) + construct ~loc ~attrs (map_loc sub lid) (List.map (sub.expr sub) arg) + | Pexp_variant (lab, args) -> + variant ~loc ~attrs lab (List.map (sub.expr sub) args) | Pexp_record (l, eo) -> record ~loc ~attrs (List.map @@ -419,8 +425,9 @@ module P = struct | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) + construct ~loc ~attrs (map_loc sub l) (List.map (sub.pat sub) p) + | Ppat_variant (l, args) -> + variant ~loc ~attrs l (List.map (sub.pat sub) args) | Ppat_record (lpl, cf, rest) -> record ~loc ~attrs ?rest: @@ -597,14 +604,12 @@ module Ppx_context = struct (Const.string x) let make_bool x = - if x then Exp.construct (lid "true") None - else Exp.construct (lid "false") None + if x then Exp.construct (lid "true") [] else Exp.construct (lid "false") [] let rec make_list f lst = match lst with - | x :: rest -> - Exp.construct (lid "::") (Some (Exp.tuple [f x; make_list f rest])) - | [] -> Exp.construct (lid "[]") None + | x :: rest -> Exp.construct (lid "::") [f x; make_list f rest] + | [] -> Exp.construct (lid "[]") [] let make_pair f1 f2 (x1, x2) = Exp.tuple [f1 x1; f2 x2] @@ -666,11 +671,9 @@ module Ppx_context = struct name and get_bool pexp = match pexp with - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, None)} - -> + | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, [])} -> true - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, None)} - -> + | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, [])} -> false | _ -> raise_errorf @@ -679,13 +682,10 @@ module Ppx_context = struct and get_list elem = function | { pexp_desc = - Pexp_construct - ( {txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple [exp; rest]} ); + Pexp_construct ({txt = Longident.Lident "::"}, [exp; rest]); } -> elem exp :: get_list elem rest - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, None)} -> - [] + | {pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, [])} -> [] | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context { %s }] list syntax" diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 4d9af4ce7c7..cd4e3f399f2 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -164,6 +164,17 @@ let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} (* Internal Parsetree0 bridge metadata; public res.* attributes pass through. *) let record_rest_attr_name = "_res.record_rest" +let constructor_args_attr_name = "_res.constructor_args" + +let remove_constructor_args_attr (attrs : Pt.attributes) = + let rec loop rev_attrs = function + | ({Location.txt; _}, Pt.PStr []) :: attrs + when txt = constructor_args_attr_name -> + (true, List.rev_append rev_attrs attrs) + | attr :: attrs -> loop (attr :: rev_attrs) attrs + | [] -> (false, List.rev rev_attrs) + in + loop [] attrs let record_rest_of_pattern (rest : Pt.pattern) = match rest.Pt.ppat_desc with @@ -192,9 +203,21 @@ module T = struct (* Type expressions for the core language *) let row_field sub = function - | Rtag (l, attrs, b, tl) -> + | Rtag (l, attrs, b, types) -> + let map_group typ = + let typ = sub.typ sub typ in + let has_constructor_args, attrs = + remove_constructor_args_attr typ.ptyp_attributes + in + let txt = + match typ.ptyp_desc with + | Ptyp_tuple args when has_constructor_args -> args + | _ -> [{typ with ptyp_attributes = attrs}] + in + {loc = typ.ptyp_loc; txt} + in Pt.Rtag - (map_loc sub l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl) + (map_loc sub l, sub.attributes sub attrs, b, List.map map_group types) | Rinherit t -> Rinherit (sub.typ sub t) let object_field sub = function @@ -837,8 +860,18 @@ module E = struct loc.loc_end | Pexp_construct (lid, arg) -> ( let lid1 = map_loc sub lid in - let arg1 = map_opt (sub.expr sub) arg in - let exp1 = construct ~loc ~attrs lid1 arg1 in + let has_constructor_args, attrs = remove_constructor_args_attr attrs in + let args = + match arg with + | None -> [] + | Some {pexp_desc = Pexp_tuple args} + when has_constructor_args + || Builtin_attributes.explicit_arity attrs + || lid.txt = Longident.Lident "::" -> + List.map (sub.expr sub) args + | Some arg -> [sub.expr sub arg] + in + let exp1 = construct ~loc ~attrs lid1 args in match lid.txt with | Lident "Function$" -> ( let rec attributes_to_arity (attrs : Parsetree.attributes) = @@ -858,8 +891,8 @@ module E = struct | _ :: rest -> attributes_to_arity rest | [] -> assert false in - match arg1 with - | Some ({pexp_desc = Pexp_fun f} as e1) -> ( + match args with + | [({pexp_desc = Pexp_fun f} as e1)] -> ( let arity = attributes_to_arity attrs in (* Gather [arity] parameters from the converted chain of unary functions into one n-ary node. Nested first-class functions are @@ -895,8 +928,16 @@ module E = struct }) | _ -> exp1) | _ -> exp1) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) + | Pexp_variant (lab, arg) -> + let has_constructor_args, attrs = remove_constructor_args_attr attrs in + let args = + match arg with + | None -> [] + | Some {pexp_desc = Pexp_tuple args} when has_constructor_args -> + List.map (sub.expr sub) args + | Some arg -> [sub.expr sub arg] + in + variant ~loc ~attrs lab args | Pexp_record (l, eo) -> record ~loc ~attrs (Ext_list.map l (fun (lid, e) -> @@ -1063,9 +1104,29 @@ module P = struct (map_pattern_constant ~loc c1) (map_pattern_constant ~loc c2) | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) + | Ppat_construct (l, arg) -> + let has_constructor_args, attrs = remove_constructor_args_attr attrs in + let args = + match arg with + | None -> [] + | Some {ppat_desc = Ppat_tuple args} + when has_constructor_args + || Builtin_attributes.explicit_arity attrs + || l.txt = Longident.Lident "::" -> + List.map (sub.pat sub) args + | Some arg -> [sub.pat sub arg] + in + construct ~loc ~attrs (map_loc sub l) args + | Ppat_variant (l, arg) -> + let has_constructor_args, attrs = remove_constructor_args_attr attrs in + let args = + match arg with + | None -> [] + | Some {ppat_desc = Ppat_tuple args} when has_constructor_args -> + List.map (sub.pat sub) args + | Some arg -> [sub.pat sub arg] + in + variant ~loc ~attrs l args | Ppat_record (lpl, cf) -> let rest, attrs = get_record_rest_attr attrs in record ~loc ~attrs ?rest diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index b2a6f5c66a2..ffc129f093e 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -107,6 +107,10 @@ let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} (* Internal Parsetree0 bridge metadata; public res.* attributes pass through. *) let record_rest_attr_name = "_res.record_rest" +let constructor_args_attr_name = "_res.constructor_args" + +let add_constructor_args_attr attrs = + (Location.mknoloc constructor_args_attr_name, Pt.PStr []) :: attrs let add_record_rest_attr ~rest attrs = (Location.mknoloc record_rest_attr_name, Pt.PPat (rest, None)) :: attrs @@ -123,9 +127,20 @@ module T = struct (* Type expressions for the core language *) let row_field sub = function - | Rtag (l, attrs, b, tl) -> + | Rtag (l, attrs, b, groups) -> + let map_group {loc; txt = args} = + let loc = sub.location sub loc in + match List.map (sub.typ sub) args with + | [arg] -> arg + | args -> + let typ = Ast_helper0.Typ.tuple ~loc args in + { + typ with + ptyp_attributes = add_constructor_args_attr typ.ptyp_attributes; + } + in Pt.Rtag - (map_loc sub l, sub.attributes sub attrs, b, List.map (sub.typ sub) tl) + (map_loc sub l, sub.attributes sub attrs, b, List.map map_group groups) | Rinherit t -> Rinherit (sub.typ sub t) let object_field sub = function @@ -555,10 +570,28 @@ module E = struct match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) - | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) + | Pexp_construct (lid, args) -> + let args = List.map (sub.expr sub) args in + let arg, attrs = + match args with + | [] -> (None, attrs) + | [arg] -> (Some arg, attrs) + | args -> + ( Some (Ast_helper0.Exp.tuple ~loc args), + add_constructor_args_attr attrs ) + in + construct ~loc ~attrs (map_loc sub lid) arg + | Pexp_variant (lab, args) -> + let args = List.map (sub.expr sub) args in + let arg, attrs = + match args with + | [] -> (None, attrs) + | [arg] -> (Some arg, attrs) + | args -> + ( Some (Ast_helper0.Exp.tuple ~loc args), + add_constructor_args_attr attrs ) + in + variant ~loc ~attrs lab arg | Pexp_record (l, eo) -> record ~loc ~attrs (Ext_list.map l (fun {lid; x = e; opt = optional} -> @@ -792,9 +825,28 @@ module P = struct | Ppat_interval (c1, c2) -> interval ~loc ~attrs (map_constant c1) (map_constant c2) | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) + | Ppat_construct (l, args) -> + let args = List.map (sub.pat sub) args in + let arg, attrs = + match args with + | [] -> (None, attrs) + | [arg] -> (Some arg, attrs) + | args -> + ( Some (Ast_helper0.Pat.tuple ~loc args), + add_constructor_args_attr attrs ) + in + construct ~loc ~attrs (map_loc sub l) arg + | Ppat_variant (l, args) -> + let args = List.map (sub.pat sub) args in + let arg, attrs = + match args with + | [] -> (None, attrs) + | [arg] -> (Some arg, attrs) + | args -> + ( Some (Ast_helper0.Pat.tuple ~loc args), + add_constructor_args_attr attrs ) + in + variant ~loc ~attrs l arg | Ppat_record (lpl, cf, rest) -> let attrs = match rest with diff --git a/compiler/ml/ast_payload.ml b/compiler/ml/ast_payload.ml index 649bb0526b4..943b39f6548 100644 --- a/compiler/ml/ast_payload.ml +++ b/compiler/ml/ast_payload.ml @@ -321,8 +321,8 @@ let assert_strings loc (x : t) : string list = let assert_bool_lit (e : Parsetree.expression) = match e.pexp_desc with - | Pexp_construct ({txt = Lident "true"}, None) -> true - | Pexp_construct ({txt = Lident "false"}, None) -> false + | Pexp_construct ({txt = Lident "true"}, []) -> true + | Pexp_construct ({txt = Lident "false"}, []) -> false | _ -> Location.raise_errorf ~loc:e.pexp_loc "expect `true` or `false` in this field" diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index 50537890c53..0a4ad59ad6f 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -116,7 +116,8 @@ let rec add_type bv ty = | Ptyp_variant (fl, _, _) -> List.iter (function - | Rtag (_, _, _, stl) -> List.iter (add_type bv) stl + | Rtag (_, _, _, groups) -> + List.iter (fun {txt} -> List.iter (add_type bv) txt) groups | Rinherit sty -> add_type bv sty) fl | Ptyp_poly (_, t) -> add_type bv t @@ -176,7 +177,7 @@ let rec add_pattern bv pat = | Ppat_tuple pl -> List.iter (add_pattern bv) pl | Ppat_construct (c, op) -> add bv c; - add_opt add_pattern bv op + List.iter (add_pattern bv) op | Ppat_record (pl, _, rest) -> List.iter (fun {lid = lbl; x = p} -> @@ -191,7 +192,7 @@ let rec add_pattern bv pat = | Ppat_constraint (p, ty) -> add_pattern bv p; add_type bv ty - | Ppat_variant (_, op) -> add_opt add_pattern bv op + | Ppat_variant (_, args) -> List.iter (add_pattern bv) args | Ppat_type li -> add bv li | Ppat_unpack id -> pattern_bv := String_map.add id.txt bound !pattern_bv | Ppat_open (m, p) -> @@ -237,8 +238,8 @@ let rec add_expr bv exp = | Pexp_tuple el -> List.iter (add_expr bv) el | Pexp_construct (c, opte) -> add bv c; - add_opt add_expr bv opte - | Pexp_variant (_, opte) -> add_opt add_expr bv opte + List.iter (add_expr bv) opte + | Pexp_variant (_, args) -> List.iter (add_expr bv) args | Pexp_record (lblel, opte) -> List.iter (fun {lid = lbl; x = e} -> @@ -301,7 +302,7 @@ let rec add_expr bv exp = (( {txt = "ocaml.extension_constructor" | "extension_constructor"; _}, PStr [item] ) as e) -> ( match item.pstr_desc with - | Pstr_eval ({pexp_desc = Pexp_construct (c, None)}, _) -> add bv c + | Pstr_eval ({pexp_desc = Pexp_construct (c, [])}, _) -> add bv c | _ -> handle_extension e) | Pexp_extension e -> handle_extension e | Pexp_await e -> add_expr bv e diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 4ee3f1aeaf8..78fc7ecd72c 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -676,7 +676,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf { exp with Parsetree.pexp_desc = - Pexp_variant (String_literal.string_semantic payload, None); + Pexp_variant (String_literal.string_semantic payload, []); } | _ -> None) in @@ -734,8 +734,7 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf exp with Parsetree.pexp_desc = Pexp_construct - ( {txt = Lident constructor_name; loc = exp.pexp_loc}, - None ); + ({txt = Lident constructor_name; loc = exp.pexp_loc}, []); } | _ -> None) in diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index ef6ccd8c217..6390f747390 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -1955,16 +1955,14 @@ module Conv = struct let id = fresh cstr.cstr_name in let lid = {cstr_lid with txt = Longident.Lident id} in Hashtbl.add constrs id cstr; - let arg = - match List.map loop lst with - | [] -> None - | [p] -> Some p - | lst -> Some (mkpat (Ppat_tuple lst)) - in - mkpat (Ppat_construct (lid, arg)) + mkpat (Ppat_construct (lid, List.map loop lst)) | Tpat_variant (label, p_opt, _row_desc) -> - let arg = Misc.may_map loop p_opt in - mkpat (Ppat_variant (label, arg)) + let args = + match p_opt with + | None -> [] + | Some p -> [loop p] + in + mkpat (Ppat_variant (label, args)) | Tpat_record (subpatterns, _closed_flag, rest) -> let fields = List.map diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index daccd0f8586..0c6703549d8 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -162,22 +162,28 @@ and package_type = Longident.t loc * (Longident.t loc * core_type) list *) and row_field = - | Rtag of label loc * attributes * bool * core_type list + | Rtag of label loc * attributes * bool * variant_type_args list (* [`A] ( true, [] ) - [`A of T] ( false, [T] ) - [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) - [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) + [`A of T] ( false, [{txt = [T]}] ) + [`A of T1 & .. & Tn] ( false, [{txt = [T1]};...;{txt = [Tn]}] ) + [`A of & T1 & .. & Tn] ( true, [{txt = [T1]};...;{txt = [Tn]}] ) + + Each inner list records the syntactic arity of one payload group: + #A(T1, ..., Tn) [T1; ...; Tn] + #A((T1, ..., Tn)) [Ptyp_tuple [T1; ...; Tn]] - The 2nd field is true if the tag contains a constant (empty) constructor. - '&' occurs when several types are used for the same constructor (see 4.2 in the manual) - - TODO: switch to a record representation, and keep location + - TODO: switch to a record representation *) | Rinherit of core_type (* [ T ] *) +and variant_type_args = core_type list loc + and object_field = | Otag of label loc * attributes * core_type | Oinherit of core_type @@ -209,14 +215,17 @@ and pattern_desc = Invariant: n >= 2 *) - | Ppat_construct of Longident.t loc * pattern option - (* C None - C P Some P - C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) + | Ppat_construct of Longident.t loc * pattern list + (* C [] + C(P) [P] + C(P1, ..., Pn) [P1; ...; Pn] + C((P1, ..., Pn)) [Ppat_tuple [P1; ...; Pn]] *) - | Ppat_variant of label * pattern option - (* `A (None) - `A P (Some P) + | Ppat_variant of label * pattern list + (* #A [] + #A(P) [P] + #A(P1, ..., Pn) [P1; ...; Pn] + #A((P1, ..., Pn)) [Ppat_tuple [P1; ...; Pn]] *) | Ppat_record of pattern record_element list * closed_flag * record_pat_rest option @@ -298,14 +307,17 @@ and expression_desc = Invariant: n >= 2 *) - | Pexp_construct of Longident.t loc * expression option - (* C None - C E Some E - C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) + | Pexp_construct of Longident.t loc * expression list + (* C [] + C(E) [E] + C(E1, ..., En) [E1; ...; En] + C((E1, ..., En)) [Pexp_tuple [E1; ...; En]] *) - | Pexp_variant of label * expression option - (* `A (None) - `A E (Some E) + | Pexp_variant of label * expression list + (* #A [] + #A(E) [E] + #A(E1, ..., En) [E1; ...; En] + #A((E1, ..., En)) [Pexp_tuple [E1; ...; En]] *) | Pexp_record of expression record_element list * expression option (* { l1=P1; ...; ln=Pn } (None) diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml index 180e7184d22..b1a6e7c46ad 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -110,19 +110,16 @@ let view_expr x = match x.pexp_desc with | Pexp_construct ({txt = Lident "()"; _}, _) -> `tuple | Pexp_construct ({txt = Lident "[]"; _}, _) -> `nil - | Pexp_construct ({txt = Lident "::"; _}, Some _) -> + | Pexp_construct ({txt = Lident "::"; _}, [_; _]) -> let rec loop exp acc = match exp with | { - pexp_desc = Pexp_construct ({txt = Lident "[]"; _}, _); + pexp_desc = Pexp_construct ({txt = Lident "[]"; _}, []); pexp_attributes = []; } -> (List.rev acc, true) | { - pexp_desc = - Pexp_construct - ( {txt = Lident "::"; _}, - Some {pexp_desc = Pexp_tuple [e1; e2]; pexp_attributes = []} ); + pexp_desc = Pexp_construct ({txt = Lident "::"; _}, [e1; e2]); pexp_attributes = []; } -> loop e2 (e1 :: acc) @@ -130,7 +127,7 @@ let view_expr x = in let ls, b = loop x [] in if b then `list ls else `cons ls - | Pexp_construct (x, None) -> `simple x.txt + | Pexp_construct (x, []) -> `simple x.txt | _ -> `normal let is_simple_construct : construct -> bool = function @@ -355,7 +352,15 @@ and core_type1 ctxt f x = | Ptyp_variant (l, closed, low) -> let type_variant_helper f x = match x with - | Rtag (l, attrs, _, ctl) -> + | Rtag (l, attrs, _, groups) -> + let ctl = + List.map + (fun {loc; txt = args} -> + match args with + | [arg] -> arg + | args -> Ast_helper.Typ.tuple ~loc args) + groups + in pp f "@[<2>%a%a@;%a@]" string_quot l.txt (fun f l -> match l with @@ -441,10 +446,7 @@ and pattern ctxt f x = and pattern1 ctxt (f : Format.formatter) (x : pattern) : unit = let rec pattern_list_helper f = function | { - ppat_desc = - Ppat_construct - ( {txt = Lident "::"; _}, - Some {ppat_desc = Ppat_tuple [pat1; pat2]; _} ); + ppat_desc = Ppat_construct ({txt = Lident "::"; _}, [pat1; pat2]); ppat_attributes = []; } -> pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) @@ -453,8 +455,13 @@ and pattern1 ctxt (f : Format.formatter) (x : pattern) : unit = if x.ppat_attributes <> [] then pattern ctxt f x else match x.ppat_desc with - | Ppat_variant (l, Some p) -> - pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p + | Ppat_variant (l, args) when args <> [] -> + let payload = + match args with + | [arg] -> arg + | args -> Ast_helper.Pat.tuple ~loc:x.ppat_loc args + in + pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) payload | Ppat_construct ({txt = Lident ("()" | "[]"); _}, _) -> simple_pattern ctxt f x | Ppat_construct (({txt; _} as li), po) -> ( @@ -464,8 +471,11 @@ and pattern1 ctxt (f : Format.formatter) (x : pattern) : unit = then pp f "%a" pattern_list_helper x else match po with - | Some x -> pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x - | None -> pp f "%a" longident_loc li) + | [] -> pp f "%a" longident_loc li + | [x] -> pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x + | patterns -> + let tuple = Ast_helper.Pat.tuple ~loc:x.ppat_loc patterns in + pp f "%a@;%a" longident_loc li (simple_pattern ctxt) tuple) | _ -> simple_pattern ctxt f x and simple_pattern ctxt (f : Format.formatter) (x : pattern) : unit = @@ -507,7 +517,7 @@ and simple_pattern ctxt (f : Format.formatter) (x : pattern) : unit = pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) | Ppat_constant c -> pp f "%a" constant c | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2 - | Ppat_variant (l, None) -> pp f "`%s" l + | Ppat_variant (l, []) -> pp f "`%s" l | Ppat_constraint (p, ct) -> pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct | Ppat_exception p -> pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p @@ -717,12 +727,18 @@ and expression ctxt f x = (* reset here only because [function,match,try,sequence] are lower priority *) (e, l) partial_str) - | Pexp_construct (li, Some eo) when not (is_simple_construct (view_expr x)) - -> ( + | Pexp_construct (li, args) + when args <> [] && not (is_simple_construct (view_expr x)) -> ( (* Not efficient FIXME*) match view_expr x with | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;" - | `normal -> pp f "@[<2>%a@;%a@]" longident_loc li (simple_expr ctxt) eo + | `normal -> + let arg = + match args with + | [arg] -> arg + | args -> Ast_helper.Exp.tuple ~loc:x.pexp_loc args + in + pp f "@[<2>%a@;%a@]" longident_loc li (simple_expr ctxt) arg | _ -> assert false) | Pexp_setfield (e1, li, e2) -> pp f "@[<2>%a.%a@ <-@ %a@]" (simple_expr ctxt) e1 longident_loc li @@ -758,7 +774,13 @@ and expression ctxt f x = | Pexp_open (ovf, lid, e) -> pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid (expression ctxt) e - | Pexp_variant (l, Some eo) -> pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo + | Pexp_variant (l, args) when args <> [] -> + let payload = + match args with + | [arg] -> arg + | args -> Ast_helper.Exp.tuple ~loc:x.pexp_loc args + in + pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) payload | Pexp_extension e -> extension ctxt f e | Pexp_await e -> pp f "@[await@ %a@]" (simple_expr ctxt) e | Pexp_template {source_segments; values} -> @@ -828,7 +850,7 @@ and simple_expr ctxt f x = pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct | Pexp_coerce (e, (), ct) -> pp f "(%a :> %a)" (expression ctxt) e (core_type ctxt) ct - | Pexp_variant (l, None) -> pp f "`%s" l + | Pexp_variant (l, []) -> pp f "`%s" l | Pexp_record (l, eo) -> let longident_x_expression f {lid = li; x = e; opt} = let opt_str = if opt then "?" else "" in diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index 6b83b1e3263..82ebba24b5a 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -205,10 +205,10 @@ and pattern i ppf x = list i pattern ppf l | Ppat_construct (li, po) -> line i ppf "Ppat_construct %a\n" fmt_longident_loc li; - option i pattern ppf po - | Ppat_variant (l, po) -> + list i pattern ppf po + | Ppat_variant (l, args) -> line i ppf "Ppat_variant \"%s\"\n" l; - option i pattern ppf po + list i pattern ppf args | Ppat_record (l, c, rest) -> ( line i ppf "Ppat_record %a\n" fmt_closed_flag c; list i longident_x_pattern ppf l; @@ -296,10 +296,10 @@ and expression i ppf x = list i expression ppf l | Pexp_construct (li, eo) -> line i ppf "Pexp_construct %a\n" fmt_longident_loc li; - option i expression ppf eo - | Pexp_variant (l, eo) -> + list i expression ppf eo + | Pexp_variant (l, args) -> line i ppf "Pexp_variant \"%s\"\n" l; - option i expression ppf eo + list i expression ppf args | Pexp_record (l, eo) -> line i ppf "Pexp_record\n"; list i longident_x_expression ppf l; @@ -776,10 +776,12 @@ and label_x_expression i ppf (l, e) = and label_x_bool_x_core_type_list i ppf x = match x with - | Rtag (l, attrs, b, ctl) -> + | Rtag (l, attrs, b, groups) -> line i ppf "Rtag \"%s\" %s\n" l.txt (string_of_bool b); attributes (i + 1) ppf attrs; - list (i + 1) core_type ppf ctl + list (i + 1) + (fun i ppf {txt = types} -> list i core_type ppf types) + ppf groups | Rinherit ct -> line i ppf "Rinherit\n"; core_type (i + 1) ppf ct diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index bf11f7d7b47..452ece7d593 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -185,7 +185,8 @@ let iter_expression f e = expr e; List.iter case pel | Pexp_array el | Pexp_tuple el -> List.iter expr el - | Pexp_construct (_, eo) | Pexp_variant (_, eo) -> may expr eo + | Pexp_construct (_, el) -> List.iter expr el + | Pexp_variant (_, args) -> List.iter expr args | Pexp_record (iel, eo) -> may expr eo; List.iter (fun {x = e} -> expr e) iel @@ -678,8 +679,8 @@ let build_ppat_or_for_variant_spread pat env expected_ty = (Longident.Lident (Ident.name c.cd_id)) lident.loc, match c.cd_args with - | Cstr_tuple [] -> None - | _ -> Some (Ast_helper.Pat.any ()) ))) + | Cstr_tuple [] -> [] + | _ -> [Ast_helper.Pat.any ()] ))) |> List.rev in let pat = @@ -1425,17 +1426,12 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp if constr.cstr_generalized then unify_head_only loc !env expected_ty constr; let sargs = match sarg with - | None -> [] - | Some {ppat_desc = Ppat_tuple spl} - when constr.cstr_arity > 1 - || Builtin_attributes.explicit_arity sp.ppat_attributes -> - spl - | Some ({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 -> + | [({ppat_desc = Ppat_any} as sp)] when constr.cstr_arity <> 1 -> if constr.cstr_arity = 0 then Location.prerr_warning sp.ppat_loc Warnings.Wildcard_arg_to_constant_constr; replicate_list sp constr.cstr_arity - | Some sp -> [sp] + | sargs -> sargs in (match sargs with | [({ppat_desc = Ppat_constant _} as sp)] @@ -1487,8 +1483,14 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp pat_attributes = sp.ppat_attributes; pat_env = !env; }) - | Ppat_variant (l, sarg) -> ( + | Ppat_variant (l, sargs) -> ( check_polyvar_name !env loc l; + let sarg = + match sargs with + | [] -> None + | [sarg] -> Some sarg + | sargs -> Some (Ast_helper.Pat.tuple ~loc sargs) + in let arg_type = match sarg with | None -> [] @@ -1554,7 +1556,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp if label_is_optional ld && (not exp_optional_attr) && not is_from_pamatch then let lid = mknoloc Longident.(Ldot (Lident "*predef*", "Some")) in - Ast_helper.Pat.construct ~loc:pat.ppat_loc lid (Some pat) + Ast_helper.Pat.construct ~loc:pat.ppat_loc lid [pat] else pat in let type_label_pat (label_lid, label, sarg, opt) k = @@ -2172,7 +2174,8 @@ let iter_ppat f p = | Ppat_or (p1, p2) -> f p1; f p2 - | Ppat_variant (_, arg) | Ppat_construct (_, arg) -> may f arg + | Ppat_construct (_, args) -> List.iter f args + | Ppat_variant (_, args) -> List.iter f args | Ppat_tuple lst -> List.iter f lst | Ppat_exception p | Ppat_alias (p, _) @@ -2427,7 +2430,7 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp 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 + let e = Ast_helper.Exp.construct ~loc:e.pexp_loc lid [e] in (id, ld, e, opt) else (id, ld, e, opt) in @@ -2740,8 +2743,14 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp } | Pexp_construct (lid, sarg) -> type_construct ~context env loc lid sarg ty_expected sexp.pexp_attributes - | Pexp_variant (l, sarg) -> ( + | Pexp_variant (l, sargs) -> ( check_polyvar_name env loc l; + let sarg = + match sargs with + | [] -> None + | [sarg] -> Some sarg + | sargs -> Some (Ast_helper.Exp.tuple ~loc sargs) + in (* Keep sharing *) let ty_expected0 = instance env ty_expected in try @@ -3551,12 +3560,8 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp payload ) -> ( match payload with | PStr - [ - { - pstr_desc = - Pstr_eval ({pexp_desc = Pexp_construct (lid, None); _}, _); - }; - ] -> + [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_construct (lid, []); _}, _)}] + -> let path = match (Typetexp.find_constructor env lid.loc lid.txt).cstr_kind with | Extension_constructor path -> path @@ -3663,13 +3668,13 @@ and type_function ~async loc attrs env ty_expected_ Exp.case (Pat.construct ~loc:default_loc (mknoloc Longident.(Ldot (Lident "*predef*", "Some"))) - (Some (Pat.var ~loc:default_loc (mknoloc "*sth*")))) + [Pat.var ~loc:default_loc (mknoloc "*sth*")]) (Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*"))); Exp.case (Pat.construct ~loc:default_loc (mknoloc Longident.(Ldot (Lident "*predef*", "None"))) - None) + []) default; ] in @@ -4341,7 +4346,7 @@ and type_application ~context total_app env funct (sargs : sargs) : (* Leftover syntactic arguments *) (match !remaining with | [] -> () - | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, None)})] + | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, [])})] when total_app && !omitted = [] && !rev_args <> [] && List.length !rev_args = List.length !ignored -> (* foo() treated as empty application if all args are optional @@ -4405,7 +4410,7 @@ and type_application ~context total_app env funct (sargs : sargs) : env, Apply_non_function (expand_head env funct.exp_type) ))) -and type_construct ~context env loc lid sarg ty_expected attrs = +and type_construct ~context env loc lid sargs ty_expected attrs = let opath = try let p0, p, _ = extract_concrete_variant env ty_expected in @@ -4421,14 +4426,6 @@ and type_construct ~context env loc lid sarg ty_expected attrs = Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr; Builtin_attributes.check_deprecated loc constr.cstr_attributes constr.cstr_name; - let sargs = - match sarg with - | None -> [] - | Some {pexp_desc = Pexp_tuple sel} - when constr.cstr_arity > 1 || Builtin_attributes.explicit_arity attrs -> - sel - | Some se -> [se] - in if List.length sargs <> constr.cstr_arity then raise (Error diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index d72edc99007..6ab2a3ef347 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -437,8 +437,16 @@ and transl_type_aux env policy styp = with Not_found -> Hashtbl.add hfields l (l, f) in let add_field = function - | Rtag (l, attrs, c, stl) -> + | Rtag (l, attrs, c, groups) -> name := None; + let stl = + List.map + (fun {loc; txt = args} -> + match args with + | [arg] -> arg + | args -> Ast_helper.Typ.tuple ~loc args) + groups + in let tl = Builtin_attributes.warning_scope attrs (fun () -> List.map (transl_type env policy) stl) diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index 9b15ed3f301..c744fe96664 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -32,7 +32,7 @@ let get_label str = let constant_string ~loc str = Ast_helper.Exp.constant ~loc (Ast_helper.Const.string str) -let unit_expr ~loc = Exp.construct ~loc (Location.mkloc (Lident "()") loc) None +let unit_expr ~loc = Exp.construct ~loc (Location.mkloc (Lident "()") loc) [] let safe_type_from_value value_str = let value_str = get_label value_str in @@ -513,10 +513,10 @@ let vb_match ~expr (name, default, pattern, _alias, loc, _) = Exp.case (Pat.construct (Location.mknoloc @@ Lident "Some") - (Some (Pat.var (Location.mknoloc label)))) + [Pat.var (Location.mknoloc label)]) (Exp.ident (Location.mknoloc @@ Lident label)); Exp.case - (Pat.construct (Location.mknoloc @@ Lident "None") None) + (Pat.construct (Location.mknoloc @@ Lident "None") []) default; ]) in diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index ff5bc0d26cb..01ee36b1a33 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -633,23 +633,19 @@ module Sexp_ast = struct | Pexp_tuple exprs -> Sexp.list [Sexp.atom "Pexp_tuple"; Sexp.list (map_empty ~f:expression exprs)] - | Pexp_construct (longident_loc, expr_opt) -> + | Pexp_construct (longident_loc, exprs) -> Sexp.list [ Sexp.atom "Pexp_construct"; longident longident_loc.Asttypes.txt; - (match expr_opt with - | None -> Sexp.atom "None" - | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); + Sexp.list (map_empty ~f:expression exprs); ] - | Pexp_variant (lbl, expr_opt) -> + | Pexp_variant (lbl, exprs) -> Sexp.list [ Sexp.atom "Pexp_variant"; string lbl; - (match expr_opt with - | None -> Sexp.atom "None" - | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); + Sexp.list (map_empty ~f:expression exprs); ] | Pexp_record (rows, opt_expr) -> Sexp.list @@ -846,23 +842,19 @@ module Sexp_ast = struct | Ppat_tuple patterns -> Sexp.list [Sexp.atom "Ppat_tuple"; Sexp.list (map_empty ~f:pattern patterns)] - | Ppat_construct (longident_loc, opt_pattern) -> + | Ppat_construct (longident_loc, patterns) -> Sexp.list [ Sexp.atom "Ppat_construct"; longident longident_loc.Location.txt; - (match opt_pattern with - | None -> Sexp.atom "None" - | Some p -> Sexp.list [Sexp.atom "some"; pattern p]); + Sexp.list (map_empty ~f:pattern patterns); ] - | Ppat_variant (lbl, opt_pattern) -> + | Ppat_variant (lbl, patterns) -> Sexp.list [ Sexp.atom "Ppat_variant"; string lbl; - (match opt_pattern with - | None -> Sexp.atom "None" - | Some p -> Sexp.list [Sexp.atom "Some"; pattern p]); + Sexp.list (map_empty ~f:pattern patterns); ] | Ppat_record (rows, flag, rest) -> Sexp.list @@ -935,7 +927,11 @@ module Sexp_ast = struct string label_loc.txt; attributes attrs; Sexp.atom (if truth then "true" else "false"); - Sexp.list (map_empty ~f:core_type types); + Sexp.list + (map_empty + ~f:(fun {Location.txt = types} -> + Sexp.list (map_empty ~f:core_type types)) + types); ] | Rinherit typexpr -> Sexp.list [Sexp.atom "Rinherit"; core_type typexpr] diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index 4a689a51c5e..403c856ce2a 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -296,19 +296,15 @@ let partition_between_lines start_line end_line comments = let rec collect_list_patterns acc pattern = let open Parsetree in match pattern.ppat_desc with - | Ppat_construct - ({txt = Longident.Lident "::"}, Some {ppat_desc = Ppat_tuple [pat; rest]}) - -> + | Ppat_construct ({txt = Longident.Lident "::"}, [pat; rest]) -> collect_list_patterns (pat :: acc) rest - | Ppat_construct ({txt = Longident.Lident "[]"}, None) -> List.rev acc + | Ppat_construct ({txt = Longident.Lident "[]"}, []) -> List.rev acc | _ -> List.rev (pattern :: acc) let rec collect_list_exprs acc expr = let open Parsetree in match expr.pexp_desc with - | Pexp_construct - ({txt = Longident.Lident "::"}, Some {pexp_desc = Pexp_tuple [expr; rest]}) - -> + | Pexp_construct ({txt = Longident.Lident "::"}, [expr; rest]) -> collect_list_exprs (expr :: acc) rest | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> List.rev acc | _ -> List.rev (expr :: acc) @@ -1007,7 +1003,7 @@ and walk_expression expr t comments = | Pexp_let ( _recFlag, value_bindings, - {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, None)} ) -> + {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, [])} ) -> walk_value_bindings value_bindings t comments | Pexp_let (_recFlag, value_bindings, expr2) -> let comments = @@ -1163,15 +1159,15 @@ and walk_expression expr t comments = let leading, trailing = partition_leading_trailing comments longident.loc in attach t.leading longident.loc leading; match args with - | Some expr -> + | _ :: _ as exprs -> let after_longident, rest = partition_adjacent_trailing longident.loc trailing in attach t.trailing longident.loc after_longident; - walk_expression expr t rest - | None -> attach t.trailing longident.loc trailing) - | Pexp_variant (_label, None) -> () - | Pexp_variant (_label, Some expr) -> walk_expression expr t comments + walk_list (List.map (fun expr -> Expression expr) exprs) t rest + | [] -> attach t.trailing longident.loc trailing) + | Pexp_variant (_label, args) -> + List.iter (fun e -> walk_expression e t comments) args | Pexp_array exprs | Pexp_tuple exprs -> walk_list (exprs |> List.map (fun e -> Expression e)) t comments | Pexp_record (rows, spread_expr) -> @@ -2057,13 +2053,13 @@ and walk_pattern pat t comments = walk_list (collect_list_patterns [] pat |> List.map (fun p -> Pattern p)) t comments - | Ppat_construct (constr, None) -> + | Ppat_construct (constr, []) -> let before_constr, after_constr = partition_leading_trailing comments constr.loc in attach t.leading constr.loc before_constr; attach t.trailing constr.loc after_constr - | Ppat_construct (constr, Some pat) -> + | Ppat_construct (constr, [pat]) -> let leading, trailing = partition_leading_trailing comments constr.loc in attach t.leading constr.loc leading; let after_constructor, rest = @@ -2074,8 +2070,16 @@ and walk_pattern pat t comments = attach t.leading pat.ppat_loc leading; walk_pattern pat t inside; attach t.trailing pat.ppat_loc trailing - | Ppat_variant (_label, None) -> () - | Ppat_variant (_label, Some pat) -> walk_pattern pat t comments + | Ppat_construct (constr, pats) -> + let leading, trailing = partition_leading_trailing comments constr.loc in + attach t.leading constr.loc leading; + let after_constructor, rest = + partition_adjacent_trailing constr.loc trailing + in + attach t.trailing constr.loc after_constructor; + walk_list (List.map (fun pat -> Pattern pat) pats) t rest + | Ppat_variant (_label, args) -> + List.iter (fun p -> walk_pattern p t comments) args | Ppat_type _ -> () | Ppat_record (record_rows, _, rest) -> let nodes = diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 81d2ea3a3d1..5f524753750 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -590,7 +590,7 @@ let make_list_pattern loc seq ext_opt = | None -> let loc = {loc with Location.loc_ghost = true} in let nil = {Location.txt = Longident.Lident "[]"; loc} in - Ast_helper.Pat.construct ~loc nil None + Ast_helper.Pat.construct ~loc nil [] in base_case | p1 :: pl -> @@ -598,9 +598,9 @@ let make_list_pattern loc seq ext_opt = let loc = mk_loc p1.Parsetree.ppat_loc.loc_start pat_pl.ppat_loc.loc_end in - let arg = Ast_helper.Pat.mk ~loc (Ppat_tuple [p1; pat_pl]) in Ast_helper.Pat.mk ~loc - (Ppat_construct (Location.mkloc (Longident.Lident "::") loc, Some arg)) + (Ppat_construct + (Location.mkloc (Longident.Lident "::") loc, [p1; pat_pl])) in handle_seq seq @@ -1246,7 +1246,7 @@ let rec parse_pattern ?(alias = true) ?(or_ = true) p = let loc = mk_loc start_pos end_pos in Ast_helper.Pat.construct ~loc (Location.mkloc (Longident.Lident (Token.to_string token)) loc) - None + [] | Int _ | String _ | Float _ | Codepoint _ | Minus | Plus -> ( let c = parse_constant p in match p.token with @@ -1265,7 +1265,7 @@ let rec parse_pattern ?(alias = true) ?(or_ = true) p = Parser.next p; let loc = mk_loc start_pos p.prev_end_pos in let lid = Location.mkloc (Longident.Lident "()") loc in - Ast_helper.Pat.construct ~loc lid None + Ast_helper.Pat.construct ~loc lid [] | _ -> ( let pat = parse_constrained_pattern p in match p.token with @@ -1302,7 +1302,7 @@ let rec parse_pattern ?(alias = true) ?(or_ = true) p = let constr = parse_module_long_ident ~lowercase:false p in match p.Parser.token with | Lparen -> parse_constructor_pattern_args p constr start_pos attrs - | _ -> Ast_helper.Pat.construct ~loc:constr.loc ~attrs constr None) + | _ -> Ast_helper.Pat.construct ~loc:constr.loc ~attrs constr []) | DotDotDot -> Parser.next p; let ident = parse_value_path p in @@ -1342,7 +1342,7 @@ let rec parse_pattern ?(alias = true) ?(or_ = true) p = in match p.Parser.token with | Lparen -> parse_variant_pattern_args p ident start_pos attrs - | _ -> Ast_helper.Pat.variant ~loc ~attrs ident None) + | _ -> Ast_helper.Pat.variant ~loc ~attrs ident []) | Exception -> Parser.next p; let pat = parse_pattern ~alias:false ~or_:false p in @@ -1750,20 +1750,12 @@ and parse_constructor_pattern_args p constr start_pos attrs = match args with | [] -> let loc = mk_loc lparen p.prev_end_pos in - Some - (Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None) - | [({ppat_desc = Ppat_tuple _} as pat)] as patterns -> - if p.mode = ParseForTypeChecker then - (* Some(1, 2) for type-checker *) - Some pat - else - (* Some((1, 2)) for printer *) - Some (Ast_helper.Pat.tuple ~loc:(mk_loc lparen p.end_pos) patterns) - | [pattern] -> Some pattern - | patterns -> - Some (Ast_helper.Pat.tuple ~loc:(mk_loc lparen p.end_pos) patterns) + [ + Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + []; + ] + | patterns -> patterns in Ast_helper.Pat.construct ~loc:(mk_loc start_pos p.prev_end_pos) @@ -1780,20 +1772,12 @@ and parse_variant_pattern_args p ident start_pos attrs = match patterns with | [] -> let loc = mk_loc lparen p.prev_end_pos in - Some - (Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - None) - | [({ppat_desc = Ppat_tuple _} as pat)] as patterns -> - if p.mode = ParseForTypeChecker then - (* #ident(1, 2) for type-checker *) - Some pat - else - (* #ident((1, 2)) for printer *) - Some (Ast_helper.Pat.tuple ~loc:(mk_loc lparen p.end_pos) patterns) - | [pattern] -> Some pattern - | patterns -> - Some (Ast_helper.Pat.tuple ~loc:(mk_loc lparen p.end_pos) patterns) + [ + Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + []; + ] + | patterns -> patterns in Parser.expect Rparen p; Ast_helper.Pat.variant @@ -2020,7 +2004,7 @@ and parse_parameters p : fundef_type_param list * fundef_term_param list = let unit_pattern = Ast_helper.Pat.construct ~loc (Location.mkloc (Longident.Lident "()") loc) - None + [] in {p_label = Asttypes.Nolabel; expr = None; pat = unit_pattern} in @@ -2124,7 +2108,7 @@ and parse_atomic_expr p = let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident (Token.to_string token)) loc) - None + [] | Int _ | String _ | Float _ | Codepoint _ -> let c = parse_constant p in let loc = mk_loc start_pos p.prev_end_pos in @@ -2142,7 +2126,7 @@ and parse_atomic_expr p = let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) - None + [] | _t -> ( let expr = parse_constrained_or_coerced_expr p in match p.token with @@ -2602,8 +2586,8 @@ and over_parse_constrained_or_coerced_or_arrow_expression p expr = (Longident.flatten longident.txt |> String.concat ".") longident.loc), false ) - | Pexp_construct (({txt = Longident.Lident "()"} as lid), None) -> - (Ast_helper.Pat.construct ~loc:expr.pexp_loc lid None, true) + | Pexp_construct (({txt = Longident.Lident "()"} as lid), []) -> + (Ast_helper.Pat.construct ~loc:expr.pexp_loc lid [], true) (* TODO: can we convert more expressions to patterns?*) | _ -> ( Ast_helper.Pat.var ~loc:expr.pexp_loc @@ -3627,7 +3611,7 @@ and parse_expr_block_item p = let loc = mk_loc p.start_pos p.end_pos in Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) - None + [] in let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.let_ ~loc rec_flag let_bindings next @@ -3780,7 +3764,7 @@ and parse_if_let_expr start_pos p = let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) - None + [] in let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.match_ @@ -3886,7 +3870,7 @@ and parse_for_expression p = let unit_pattern = let loc = mk_loc lparen p.prev_end_pos in let lid = Location.mkloc (Longident.Lident "()") loc in - Ast_helper.Pat.construct lid None + Ast_helper.Pat.construct lid [] in parse_for_rest false ~await:false (parse_alias_pattern ~attrs:[] unit_pattern p) @@ -3916,7 +3900,7 @@ and parse_for_expression p = let unit_pattern = let loc = mk_loc lparen p.prev_end_pos in let lid = Location.mkloc (Longident.Lident "()") loc in - Ast_helper.Pat.construct lid None + Ast_helper.Pat.construct lid [] in parse_for_rest false ~await:true (parse_alias_pattern ~attrs:[] unit_pattern p) @@ -4048,9 +4032,7 @@ and parse_argument p : argument option = (* apply(.) — legacy uncurried unit call *) | Rparen -> let unit_expr = - Ast_helper.Exp.construct - (Location.mknoloc (Longident.Lident "()")) - None + Ast_helper.Exp.construct (Location.mknoloc (Longident.Lident "()")) [] in Some {label = Asttypes.Nolabel; expr = unit_expr} | _ -> parse_argument2 p) @@ -4182,7 +4164,7 @@ and parse_call_expr p fun_expr = expr = Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) - None; + []; }; ] | args -> args @@ -4218,33 +4200,15 @@ and parse_value_or_constructor p = Parser.next p; aux p (ident :: acc) | Lparen when p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> - let lparen = p.start_pos in let args = parse_constructor_args p in - let rparen = p.prev_end_pos in let lident = build_longident (ident :: acc) in - let tail = - match args with - | [] -> None - | [({Parsetree.pexp_desc = Pexp_tuple _} as arg)] as args -> - let loc = mk_loc lparen rparen in - if p.mode = ParseForTypeChecker then - (* Some(1, 2) for type-checker *) - Some arg - else - (* Some((1, 2)) for printer *) - Some (Ast_helper.Exp.tuple ~loc args) - | [arg] -> Some arg - | args -> - let loc = mk_loc lparen rparen in - Some (Ast_helper.Exp.tuple ~loc args) - in let loc = mk_loc start_pos p.prev_end_pos in let ident_loc = mk_loc start_pos end_pos_lident in - Ast_helper.Exp.construct ~loc (Location.mkloc lident ident_loc) tail + Ast_helper.Exp.construct ~loc (Location.mkloc lident ident_loc) args | _ -> let loc = mk_loc start_pos p.prev_end_pos in let lident = build_longident (ident :: acc) in - Ast_helper.Exp.construct ~loc (Location.mkloc lident loc) None) + Ast_helper.Exp.construct ~loc (Location.mkloc lident loc) []) | Lident ident -> Parser.next p; let loc = mk_loc start_pos p.prev_end_pos in @@ -4268,30 +4232,12 @@ and parse_poly_variant_expr p = let ident, _loc = parse_hash_ident ~start_pos p in match p.Parser.token with | Lparen when p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> - let lparen = p.start_pos in let args = parse_constructor_args p in - let rparen = p.prev_end_pos in - let loc_paren = mk_loc lparen rparen in - let tail = - match args with - | [] -> None - | [({Parsetree.pexp_desc = Pexp_tuple _} as expr)] as args -> - if p.mode = ParseForTypeChecker then - (* #a(1, 2) for type-checker *) - Some expr - else - (* #a((1, 2)) for type-checker *) - Some (Ast_helper.Exp.tuple ~loc:loc_paren args) - | [arg] -> Some arg - | args -> - (* #a((1, 2)) for printer *) - Some (Ast_helper.Exp.tuple ~loc:loc_paren args) - in let loc = mk_loc start_pos p.prev_end_pos in - Ast_helper.Exp.variant ~loc ident tail + Ast_helper.Exp.variant ~loc ident args | _ -> let loc = mk_loc start_pos p.prev_end_pos in - Ast_helper.Exp.variant ~loc ident None + Ast_helper.Exp.variant ~loc ident [] and parse_constructor_args p = let lparen = p.Parser.start_pos in @@ -4307,7 +4253,7 @@ and parse_constructor_args p = [ Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) - None; + []; ] | args -> args @@ -6303,14 +6249,7 @@ and parse_polymorphic_variant_type_args p = ~f:parse_typ_expr_region p in Parser.expect Rparen p; - let attrs = [] in - let loc = mk_loc start_pos p.prev_end_pos in - match args with - | [({ptyp_desc = Ptyp_tuple _} as typ)] as types -> - if p.mode = ParseForTypeChecker then typ - else Ast_helper.Typ.tuple ~loc ~attrs types - | [typ] -> typ - | types -> Ast_helper.Typ.tuple ~loc ~attrs types + Location.mkloc args (mk_loc start_pos p.prev_end_pos) and parse_type_equation_and_representation ?current_type_name_path ?inline_types_context p = diff --git a/compiler/syntax/src/res_driver.ml b/compiler/syntax/src/res_driver.ml index eddb55a1f27..9cadb5c7091 100644 --- a/compiler/syntax/src/res_driver.ml +++ b/compiler/syntax/src/res_driver.ml @@ -57,14 +57,12 @@ type print_engine = { unit; } -let setup ~filename ~for_printer () = +let setup ~filename ~for_printer:_ () = let src = IO.read_file ~filename in - let mode = if for_printer then Res_parser.Default else ParseForTypeChecker in - Res_parser.make ~mode src filename + Res_parser.make src filename -let setup_from_source ~display_filename ~source ~for_printer () = - let mode = if for_printer then Res_parser.Default else ParseForTypeChecker in - Res_parser.make ~mode source display_filename +let setup_from_source ~display_filename ~source ~for_printer:_ () = + Res_parser.make source display_filename let parsing_engine = { diff --git a/compiler/syntax/src/res_parser.ml b/compiler/syntax/src/res_parser.ml index 641a41ab244..6dc53174e65 100644 --- a/compiler/syntax/src/res_parser.ml +++ b/compiler/syntax/src/res_parser.ml @@ -6,12 +6,9 @@ module Reporting = Res_reporting module Comment = Res_comment -type mode = ParseForTypeChecker | Default - type region_status = Report | Silent type t = { - mode: mode; mutable scanner: Scanner.t; mutable token: Token.t; mutable start_pos: Lexing.position; @@ -122,11 +119,10 @@ let next_regex_token p = let check_progress ~prev_end_pos ~result p = if p.end_pos == prev_end_pos then None else Some result -let make ?(mode = ParseForTypeChecker) src filename = +let make src filename = let scanner = Scanner.make ~filename src in let parser_state = { - mode; scanner; token = Token.Semicolon; start_pos = Lexing.dummy_pos; diff --git a/compiler/syntax/src/res_parser.mli b/compiler/syntax/src/res_parser.mli index 978cc18bdc9..c55a0e3ec72 100644 --- a/compiler/syntax/src/res_parser.mli +++ b/compiler/syntax/src/res_parser.mli @@ -5,12 +5,9 @@ module Reporting = Res_reporting module Diagnostics = Res_diagnostics module Comment = Res_comment -type mode = ParseForTypeChecker | Default - type region_status = Report | Silent type t = { - mode: mode; mutable scanner: Scanner.t; mutable token: Token.t; mutable start_pos: Lexing.position; @@ -23,7 +20,7 @@ type t = { mutable regions: region_status ref list; } -val make : ?mode:mode -> string -> string -> t +val make : string -> string -> t val expect : ?grammar:Grammar.t -> Token.t -> t -> unit val optional : t -> Token.t -> bool diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index 87e2a4d8035..693dcac9265 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -70,9 +70,7 @@ let collect_list_expressions expr = let rec collect acc expr = match expr.pexp_desc with | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> (List.rev acc, None) - | Pexp_construct - ( {txt = Longident.Lident "::"}, - Some {pexp_desc = Pexp_tuple (hd :: [tail])} ) -> + | Pexp_construct ({txt = Longident.Lident "::"}, hd :: [tail]) -> collect (hd :: acc) tail | _ -> (List.rev acc, Some expr) in @@ -644,9 +642,7 @@ let mod_expr_functor mod_expr = let rec collect_patterns_from_list_construct acc pattern = let open Parsetree in match pattern.ppat_desc with - | Ppat_construct - ({txt = Longident.Lident "::"}, Some {ppat_desc = Ppat_tuple [pat; rest]}) - -> + | Ppat_construct ({txt = Longident.Lident "::"}, [pat; rest]) -> collect_patterns_from_list_construct (pat :: acc) rest | _ -> (List.rev acc, pattern) diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 64b41811f5a..3703648f981 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -2133,19 +2133,21 @@ and print_typ_expr ?inline_record_definitions ~(state : State.t) if i > 0 || comment_attrs <> [] then Doc.text "| " else Doc.if_breaks (Doc.text "| ") Doc.nil in - let do_type t = - match t.Parsetree.ptyp_desc with - | Ptyp_tuple _ -> - print_typ_expr ?inline_record_definitions ~state t cmt_tbl - | _ -> - Doc.concat - [ - Doc.lparen; - print_typ_expr ?inline_record_definitions ~state t cmt_tbl; - Doc.rparen; - ] + let do_group {Location.txt = types} = + Doc.concat + [ + Doc.lparen; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun typ -> + print_typ_expr ?inline_record_definitions ~state typ + cmt_tbl) + types); + Doc.rparen; + ] in - let printed_types = List.map do_type types in + let printed_types = List.map do_group types in let cases = Doc.join ~sep:(Doc.concat [Doc.line; Doc.text "& "]) printed_types in @@ -2719,20 +2721,18 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = let constr_name = print_longident_location constr_name cmt_tbl in let args_doc = match constructor_args with - | None -> Doc.nil - | Some - { - ppat_loc; - ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _); - } -> + | [] -> Doc.nil + | [ + { + ppat_loc; + ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _); + }; + ] -> Doc.concat [Doc.lparen; print_comments_inside cmt_tbl ppat_loc; Doc.rparen] - | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> + | [{ppat_desc = Ppat_tuple []; ppat_loc = loc}] -> Doc.concat [Doc.lparen; print_comments_inside cmt_tbl loc; Doc.rparen] - (* Some((1, 2) *) - | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> - Doc.concat [Doc.lparen; print_pattern ~state arg cmt_tbl; Doc.rparen] - | Some {ppat_desc = Ppat_tuple patterns} -> + | _ :: _ :: _ as patterns -> Doc.concat [ Doc.lparen; @@ -2750,7 +2750,7 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = Doc.soft_line; Doc.rparen; ] - | Some arg -> + | [arg] -> let arg_doc = print_pattern ~state arg cmt_tbl in let should_hug = Parsetree_viewer.is_huggable_pattern arg in Doc.concat @@ -2768,7 +2768,7 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = ] in Doc.group (Doc.concat [constr_name; args_doc]) - | Ppat_variant (label, None) -> + | Ppat_variant (label, []) -> Doc.concat [Doc.text "#"; print_poly_var_ident label] | Ppat_variant (label, variant_args) -> let variant_name = @@ -2776,16 +2776,9 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = in let args_doc = match variant_args with - | None -> Doc.nil - | Some {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)} - -> + | [{ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)}] -> Doc.text "()" - | Some {ppat_desc = Ppat_tuple []; ppat_loc = loc} -> - Doc.concat [Doc.lparen; print_comments_inside cmt_tbl loc; Doc.rparen] - (* Some((1, 2) *) - | Some {ppat_desc = Ppat_tuple [({ppat_desc = Ppat_tuple _} as arg)]} -> - Doc.concat [Doc.lparen; print_pattern ~state arg cmt_tbl; Doc.rparen] - | Some {ppat_desc = Ppat_tuple patterns} -> + | _ :: _ :: _ as patterns -> Doc.concat [ Doc.lparen; @@ -2803,7 +2796,7 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = Doc.soft_line; Doc.rparen; ] - | Some arg -> + | [arg] -> let arg_doc = print_pattern ~state arg cmt_tbl in let should_hug = Parsetree_viewer.is_huggable_pattern arg in Doc.concat @@ -2819,6 +2812,7 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = ]); Doc.rparen; ] + | [] -> Doc.nil in Doc.group (Doc.concat [variant_name; args_doc]) | Ppat_type ident @@ -3286,23 +3280,10 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = let constr = print_longident_location longident_loc cmt_tbl in let args = match args with - | None -> Doc.nil - | Some {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} - -> + | [] -> Doc.nil + | [{pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}] -> Doc.text "()" - (* Some((1, 2)) *) - | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as arg)]} -> - Doc.concat - [ - Doc.lparen; - (let doc = print_expression_with_comments ~state arg cmt_tbl in - match Parens.expr arg with - | Parens.Parenthesized -> add_parens doc - | Braced braces -> print_braces doc arg braces - | Nothing -> doc); - Doc.rparen; - ] - | Some {pexp_desc = Pexp_tuple args} -> + | _ :: _ :: _ as args -> Doc.concat [ Doc.lparen; @@ -3327,7 +3308,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = Doc.soft_line; Doc.rparen; ] - | Some arg -> + | [arg] -> let arg_doc = let doc = print_expression_with_comments ~state arg cmt_tbl in match Parens.expr arg with @@ -3413,23 +3394,9 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = in let args = match args with - | None -> Doc.nil - | Some {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)} - -> + | [{pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}] -> Doc.text "()" - (* #poly((1, 2) *) - | Some {pexp_desc = Pexp_tuple [({pexp_desc = Pexp_tuple _} as arg)]} -> - Doc.concat - [ - Doc.lparen; - (let doc = print_expression_with_comments ~state arg cmt_tbl in - match Parens.expr arg with - | Parens.Parenthesized -> add_parens doc - | Braced braces -> print_braces doc arg braces - | Nothing -> doc); - Doc.rparen; - ] - | Some {pexp_desc = Pexp_tuple args} -> + | _ :: _ :: _ as args -> Doc.concat [ Doc.lparen; @@ -3454,7 +3421,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = Doc.soft_line; Doc.rparen; ] - | Some arg -> + | [arg] -> let arg_doc = let doc = print_expression_with_comments ~state arg cmt_tbl in match Parens.expr arg with @@ -3476,6 +3443,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = ]); Doc.rparen; ] + | [] -> Doc.nil in Doc.group (Doc.concat [variant_name; args]) | Pexp_record (rows, spread_expr) -> @@ -3926,7 +3894,7 @@ and print_pexp_fun ~state ~in_callback e cmt_tbl = match (return_expr.pexp_desc, opt_braces) with | _, Some _ -> true | ( ( Pexp_array _ | Pexp_tuple _ - | Pexp_construct (_, Some _) + | Pexp_construct (_, _ :: _) | Pexp_record _ ), _ ) -> true @@ -5500,7 +5468,7 @@ and print_expr_fun_parameters ~state ~in_callback ~async ~has_constraint lbl = Nolabel; default_expr = None; pat = - {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"; loc}, None)}; + {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"; loc}, [])}; }; ] -> let doc = diff --git a/packages/@rescript/belt/src/Belt_List.res b/packages/@rescript/belt/src/Belt_List.res index a000e415d4c..4a7cd832f53 100644 --- a/packages/@rescript/belt/src/Belt_List.res +++ b/packages/@rescript/belt/src/Belt_List.res @@ -338,7 +338,7 @@ let splitAt = (lst, n) => if n < 0 { None } else if n == 0 { - Some(list{}, lst) + Some((list{}, lst)) } else { switch lst { | list{} => None @@ -346,7 +346,7 @@ let splitAt = (lst, n) => let cell = mutableCell(x, list{}) let rest = splitAtAux(n - 1, xs, cell) switch rest { - | Some(rest) => Some(cell, rest) + | Some(rest) => Some((cell, rest)) | None => None } } diff --git a/packages/@rescript/belt/src/Belt_Map.resi b/packages/@rescript/belt/src/Belt_Map.resi index 78dd3482db0..7a238f86a2c 100644 --- a/packages/@rescript/belt/src/Belt_Map.resi +++ b/packages/@rescript/belt/src/Belt_Map.resi @@ -123,7 +123,7 @@ module IntCmp = Belt.Id.MakeComparable({ let s0 = Belt.Map.fromArray(~id=module(IntCmp), [(4, "4"), (1, "1"), (2, "2"), (3, "")]) -s0->Belt.Map.findFirstBy((k, _) => k == 4) == Some(4, "4") +s0->Belt.Map.findFirstBy((k, _) => k == 4) == Some((4, "4")) ``` */ let findFirstBy: (t<'k, 'v, 'id>, ('k, 'v) => bool) => option<('k, 'v)> diff --git a/packages/@rescript/belt/src/Belt_MapInt.resi b/packages/@rescript/belt/src/Belt_MapInt.resi index 42b2e1de683..8cb314338dd 100644 --- a/packages/@rescript/belt/src/Belt_MapInt.resi +++ b/packages/@rescript/belt/src/Belt_MapInt.resi @@ -35,7 +35,7 @@ to match predicate `p`. ```rescript let mapInt = Belt.Map.Int.fromArray([(1, "one"), (2, "two"), (3, "three")]) -mapInt->Belt.Map.Int.findFirstBy((k, v) => k == 1 && v == "one") == Some(1, "one") +mapInt->Belt.Map.Int.findFirstBy((k, v) => k == 1 && v == "one") == Some((1, "one")) ``` */ let findFirstBy: (t<'v>, (key, 'v) => bool) => option<(key, 'v)> diff --git a/packages/@rescript/belt/src/Belt_MapString.resi b/packages/@rescript/belt/src/Belt_MapString.resi index 0469496376e..7da55813c8c 100644 --- a/packages/@rescript/belt/src/Belt_MapString.resi +++ b/packages/@rescript/belt/src/Belt_MapString.resi @@ -35,7 +35,7 @@ to match predicate `p`. ```rescript let mapString = Belt.Map.String.fromArray([("1", "one"), ("2", "two"), ("3", "three")]) -mapString->Belt.Map.String.findFirstBy((k, v) => k == "1" && v == "one") == Some("1", "one") +mapString->Belt.Map.String.findFirstBy((k, v) => k == "1" && v == "one") == Some(("1", "one")) ``` */ let findFirstBy: (t<'v>, (key, 'v) => bool) => option<(key, 'v)> diff --git a/packages/@rescript/belt/src/Belt_internalAVLtree.res b/packages/@rescript/belt/src/Belt_internalAVLtree.res index 80f3ded37c1..7482c2bfa22 100644 --- a/packages/@rescript/belt/src/Belt_internalAVLtree.res +++ b/packages/@rescript/belt/src/Belt_internalAVLtree.res @@ -203,7 +203,7 @@ let rec findFirstBy = (n, p) => let {key: v, value: d} = n let pvd = p(v, d) if pvd { - Some(v, d) + Some((v, d)) } else { let right = findFirstBy(n.right, p) if right != None { diff --git a/packages/@rescript/runtime/Stdlib_List.res b/packages/@rescript/runtime/Stdlib_List.res index 46c60d7c4d5..20723081edc 100644 --- a/packages/@rescript/runtime/Stdlib_List.res +++ b/packages/@rescript/runtime/Stdlib_List.res @@ -358,7 +358,7 @@ let splitAt = (lst, n) => if n < 0 { None } else if n == 0 { - Some(list{}, lst) + Some((list{}, lst)) } else { switch lst { | list{} => None @@ -366,7 +366,7 @@ let splitAt = (lst, n) => let cell = mutableCell(x, list{}) let rest = splitAtAux(n - 1, xs, cell) switch rest { - | Some(rest) => Some(cell, rest) + | Some(rest) => Some((cell, rest)) | None => None } } diff --git a/tests/ERROR_VARIANTS.md b/tests/ERROR_VARIANTS.md index 0bab798c839..043df0891a1 100644 --- a/tests/ERROR_VARIANTS.md +++ b/tests/ERROR_VARIANTS.md @@ -201,7 +201,7 @@ Source: [typecore.ml:27](../compiler/ml/typecore.ml). | Variant | Status | Fixture | Notes | |---|---|---|---| | `Polymorphic_label` | ✓ | `polymorphic_label.res` | Pattern that instantiates a polymorphic record field: `({f: (f: int => int)}: t) =>` constrains the universal `'a` of `f: 'a. 'a => 'a` to `int => int`. | -| `Constructor_arity_mismatch` | ✓ | `constructor_arity_mismatch.res`, `constructor_arity_mismatch_pattern.res`, `arity_mismatch*.res` | Triggers in both expression (4028) and pattern (1426) paths. | +| `Constructor_arity_mismatch` | ✓ | `constructor_arity_mismatch.res`, `constructor_arity_mismatch_pattern.res`, `constructor_tuple_arity_mismatch.res`, `constructor_tuple_arity_mismatch_pattern.res`, `arity_mismatch*.res` | Triggers in both expression and pattern paths, including the distinction between multiple arguments and one tuple argument. | | `Label_mismatch` | ✓ | `label_mismatch_record_literal.res` | Record literal without expected type mixing fields from two different record types — disambiguation picks one type per label, and the cross-type unify fails inside `type_label_exp`. | | `Pattern_type_clash` | ✓ | many `*_pattern_type_clash.res` etc. | Most-fired pattern error. Sub-case fixtures: `pattern_matching_on_option_but_value_not_option.res` and `pattern_matching_on_value_but_is_option.res` (option-vs-non-option trace), `pattern_type_clash_polyvariant.res` (polyvariant tag against concrete type), `pattern_type_clash_tuple_arity.res` (tuple arity mismatch). | | `Or_pattern_type_clash` | ✓ | `or_pattern_type_clash.res` | | diff --git a/tests/analysis_tests/tests/src/expected/CompletionPattern.res.txt b/tests/analysis_tests/tests/src/expected/CompletionPattern.res.txt index fef158f633b..ecde04f0f47 100644 --- a/tests/analysis_tests/tests/src/expected/CompletionPattern.res.txt +++ b/tests/analysis_tests/tests/src/expected/CompletionPattern.res.txt @@ -427,7 +427,6 @@ Path z Complete src/CompletionPattern.res 96:27 posCursor:[96:27] posNoWhite:[96:26] Found pattern:[96:16->96:28] Ppat_construct Three:[96:16->96:21] -posCursor:[96:27] posNoWhite:[96:26] Found pattern:[96:21->96:29] posCursor:[96:27] posNoWhite:[96:26] Found pattern:[96:26->96:27] Completable: Cpattern Value[z]=t->variantPayload::Three($1) Package opens Stdlib.place holder Pervasives.JsxModules.place holder @@ -513,7 +512,6 @@ Path b Complete src/CompletionPattern.res 112:28 posCursor:[112:28] posNoWhite:[112:27] Found pattern:[112:16->112:29] -posCursor:[112:28] posNoWhite:[112:27] Found pattern:[112:22->112:29] posCursor:[112:28] posNoWhite:[112:27] Found pattern:[112:27->112:28] Completable: Cpattern Value[b]=t->polyvariantPayload::three($1) Package opens Stdlib.place holder Pervasives.JsxModules.place holder @@ -584,7 +582,6 @@ Path p Complete src/CompletionPattern.res 137:29 posCursor:[137:29] posNoWhite:[137:28] Found pattern:[137:16->137:31] Ppat_construct Test:[137:16->137:20] -posCursor:[137:29] posNoWhite:[137:28] Found pattern:[137:20->137:32] Completable: Cpattern Value[p]->variantPayload::Test($2) Package opens Stdlib.place holder Pervasives.JsxModules.place holder Resolved opens 1 Stdlib @@ -607,7 +604,6 @@ Path p Complete src/CompletionPattern.res 140:23 posCursor:[140:23] posNoWhite:[140:22] Found pattern:[140:16->140:31] Ppat_construct Test:[140:16->140:20] -posCursor:[140:23] posNoWhite:[140:22] Found pattern:[140:20->140:32] Completable: Cpattern Value[p]->variantPayload::Test($1) Package opens Stdlib.place holder Pervasives.JsxModules.place holder Resolved opens 1 Stdlib @@ -621,7 +617,6 @@ Path p Complete src/CompletionPattern.res 143:35 posCursor:[143:35] posNoWhite:[143:34] Found pattern:[143:16->143:37] Ppat_construct Test:[143:16->143:20] -posCursor:[143:35] posNoWhite:[143:34] Found pattern:[143:20->143:38] Completable: Cpattern Value[p]->variantPayload::Test($3) Package opens Stdlib.place holder Pervasives.JsxModules.place holder Resolved opens 1 Stdlib @@ -653,7 +648,6 @@ Path v Complete src/CompletionPattern.res 153:30 posCursor:[153:30] posNoWhite:[153:29] Found pattern:[153:16->153:32] -posCursor:[153:30] posNoWhite:[153:29] Found pattern:[153:21->153:32] Completable: Cpattern Value[v]->polyvariantPayload::test($2) Package opens Stdlib.place holder Pervasives.JsxModules.place holder Resolved opens 1 Stdlib @@ -675,7 +669,6 @@ Path v Complete src/CompletionPattern.res 156:24 posCursor:[156:24] posNoWhite:[156:23] Found pattern:[156:16->156:32] -posCursor:[156:24] posNoWhite:[156:23] Found pattern:[156:21->156:32] Completable: Cpattern Value[v]->polyvariantPayload::test($1) Package opens Stdlib.place holder Pervasives.JsxModules.place holder Resolved opens 1 Stdlib @@ -688,7 +681,6 @@ Path v Complete src/CompletionPattern.res 159:36 posCursor:[159:36] posNoWhite:[159:35] Found pattern:[159:16->159:38] -posCursor:[159:36] posNoWhite:[159:35] Found pattern:[159:21->159:38] Completable: Cpattern Value[v]->polyvariantPayload::test($3) Package opens Stdlib.place holder Pervasives.JsxModules.place holder Resolved opens 1 Stdlib @@ -864,7 +856,6 @@ Complete src/CompletionPattern.res 185:48 posCursor:[185:48] posNoWhite:[185:47] Found pattern:[185:16->185:50] posCursor:[185:48] posNoWhite:[185:47] Found pattern:[185:22->185:50] Ppat_construct Three:[185:22->185:27] -posCursor:[185:48] posNoWhite:[185:47] Found pattern:[185:27->185:53] Completable: Cpattern Value[z]->variantPayload::Three($1) Package opens Stdlib.place holder Pervasives.JsxModules.place holder Resolved opens 1 Stdlib @@ -891,7 +882,6 @@ Path b Complete src/CompletionPattern.res 191:50 posCursor:[191:50] posNoWhite:[191:49] Found pattern:[191:16->191:52] posCursor:[191:50] posNoWhite:[191:49] Found pattern:[191:23->191:52] -posCursor:[191:50] posNoWhite:[191:49] Found pattern:[191:29->191:52] Completable: Cpattern Value[b]->polyvariantPayload::three($1) Package opens Stdlib.place holder Pervasives.JsxModules.place holder Resolved opens 1 Stdlib diff --git a/tests/analysis_tests/tests/src/expected/TypeAtPosCompletion.res.txt b/tests/analysis_tests/tests/src/expected/TypeAtPosCompletion.res.txt index d79b5b50ed7..f18c6358f87 100644 --- a/tests/analysis_tests/tests/src/expected/TypeAtPosCompletion.res.txt +++ b/tests/analysis_tests/tests/src/expected/TypeAtPosCompletion.res.txt @@ -29,8 +29,7 @@ ContextPath CTypeAtPos() Complete src/TypeAtPosCompletion.res 16:18 posCursor:[16:18] posNoWhite:[16:16] Found expr:[13:8->19:1] -Pexp_construct One:[13:8->13:11] [13:11->19:1] -posCursor:[16:18] posNoWhite:[16:16] Found expr:[15:2->18:3] +Pexp_construct One:[13:8->13:11] [14:2->14:3], [15:2->18:3] Completable: Cexpression CTypeAtPos()->variantPayload::One($1), recordBody Package opens Stdlib.place holder Pervasives.JsxModules.place holder Resolved opens 1 Stdlib diff --git a/tests/belt_tests/src/belt_list_test.res b/tests/belt_tests/src/belt_list_test.res index 9f84baa3dfd..0ba7fdd2582 100644 --- a/tests/belt_tests/src/belt_list_test.res +++ b/tests/belt_tests/src/belt_list_test.res @@ -159,12 +159,12 @@ describe(__MODULE__, () => { let a = N.makeBy(5, id) eq(__LOC__, N.splitAt(list{}, 1), None) eq(__LOC__, N.splitAt(a, 6), None) - eq(__LOC__, N.splitAt(a, 5), Some(a, list{})) - eq(__LOC__, N.splitAt(a, 4), Some(list{0, 1, 2, 3}, list{4})) - eq(__LOC__, N.splitAt(a, 3), Some(list{0, 1, 2}, list{3, 4})) - eq(__LOC__, N.splitAt(a, 2), Some(list{0, 1}, list{2, 3, 4})) - eq(__LOC__, N.splitAt(a, 1), Some(list{0}, list{1, 2, 3, 4})) - eq(__LOC__, N.splitAt(a, 0), Some(list{}, a)) + eq(__LOC__, N.splitAt(a, 5), Some((a, list{}))) + eq(__LOC__, N.splitAt(a, 4), Some((list{0, 1, 2, 3}, list{4}))) + eq(__LOC__, N.splitAt(a, 3), Some((list{0, 1, 2}, list{3, 4}))) + eq(__LOC__, N.splitAt(a, 2), Some((list{0, 1}, list{2, 3, 4}))) + eq(__LOC__, N.splitAt(a, 1), Some((list{0}, list{1, 2, 3, 4}))) + eq(__LOC__, N.splitAt(a, 0), Some((list{}, a))) eq(__LOC__, N.splitAt(a, -1), None) }) diff --git a/tests/build_tests/super_errors/expected/constructor_tuple_arity_mismatch.res.expected b/tests/build_tests/super_errors/expected/constructor_tuple_arity_mismatch.res.expected new file mode 100644 index 00000000000..d0d1e0ed0b2 --- /dev/null +++ b/tests/build_tests/super_errors/expected/constructor_tuple_arity_mismatch.res.expected @@ -0,0 +1,10 @@ + + We've found a bug for you! + /.../fixtures/constructor_tuple_arity_mismatch.res:3:15-25 + + 1 │ type unary = Unary((int, int)) + 2 │ + 3 │ let invalid = Unary(1, 2) + 4 │ + + This variant constructor Unary expects 1 argument, but it's being passed 2. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/constructor_tuple_arity_mismatch_pattern.res.expected b/tests/build_tests/super_errors/expected/constructor_tuple_arity_mismatch_pattern.res.expected new file mode 100644 index 00000000000..ebc857c4318 --- /dev/null +++ b/tests/build_tests/super_errors/expected/constructor_tuple_arity_mismatch_pattern.res.expected @@ -0,0 +1,11 @@ + + We've found a bug for you! + /.../fixtures/constructor_tuple_arity_mismatch_pattern.res:5:5-18 + + 3 │ let read = value => + 4 │ switch value { + 5 │ | Binary((x, y)) => x + y + 6 │ } + 7 │ + + This variant constructor Binary expects 2 arguments, but it's only being passed 1. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/constructor_tuple_arity_mismatch.res b/tests/build_tests/super_errors/fixtures/constructor_tuple_arity_mismatch.res new file mode 100644 index 00000000000..988cf303c56 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/constructor_tuple_arity_mismatch.res @@ -0,0 +1,3 @@ +type unary = Unary((int, int)) + +let invalid = Unary(1, 2) diff --git a/tests/build_tests/super_errors/fixtures/constructor_tuple_arity_mismatch_pattern.res b/tests/build_tests/super_errors/fixtures/constructor_tuple_arity_mismatch_pattern.res new file mode 100644 index 00000000000..f40de8e9b3c --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/constructor_tuple_arity_mismatch_pattern.res @@ -0,0 +1,6 @@ +type binary = Binary(int, int) + +let read = value => + switch value { + | Binary((x, y)) => x + y + } diff --git a/tests/build_tests/super_errors_multi/expected/Cross_inline_record_constructor.expected b/tests/build_tests/super_errors_multi/expected/Cross_inline_record_constructor.expected index 6a1cdb1ef84..b41ec138a12 100644 --- a/tests/build_tests/super_errors_multi/expected/Cross_inline_record_constructor.expected +++ b/tests/build_tests/super_errors_multi/expected/Cross_inline_record_constructor.expected @@ -6,4 +6,4 @@ 1 │ let v = Defs.Pair(1, 2) 2 │ - This constructor expects an inlined record argument. \ No newline at end of file + This variant constructor Defs.Pair expects an inline record as payload. \ No newline at end of file diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index 21b215875e5..d32e7242455 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -292,8 +292,125 @@ let test_function_cases_desugar_to_fun_match _ = let map_expr_to0 e = Ast_mapper_to0.default_mapper.expr Ast_mapper_to0.default_mapper e +let map_pat_to0 p = + Ast_mapper_to0.default_mapper.pat Ast_mapper_to0.default_mapper p + let attr_names attrs = List.map (fun ({Location.txt}, _) -> txt) attrs +let test_constructor_args_roundtrip_through_ast0 _ = + let int_expr value = + Ast_helper.Exp.constant ~loc (Parsetree.Pconst_integer (value, None)) + in + let int_pat value = + Ast_helper.Pat.constant ~loc (Parsetree.Pconst_integer (value, None)) + in + let lid = Location.mknoloc (Longident.Lident "Pair") in + let expr = Ast_helper.Exp.construct ~loc lid [int_expr "1"; int_expr "2"] in + let expr0 = map_expr_to0 expr in + (match expr0.pexp_desc with + | Parsetree0.Pexp_construct (_, Some {pexp_desc = Pexp_tuple [_; _]}) -> + OUnit.assert_bool "multiple arguments carry bridge metadata" + (has_attr "_res.constructor_args" expr0.pexp_attributes) + | _ -> assert_failure "Expected a tuple-encoded v0 constructor payload"); + let expr = map_expr0 expr0 in + (match expr.pexp_desc with + | Parsetree.Pexp_construct (_, [_; _]) -> + OUnit.assert_bool "bridge metadata is removed" + (not (has_attr "_res.constructor_args" expr.pexp_attributes)) + | _ -> assert_failure "Expected two constructor arguments after roundtrip"); + let tuple_expr = Ast_helper.Exp.tuple ~loc [int_expr "1"; int_expr "2"] in + let expr = Ast_helper.Exp.construct ~loc lid [tuple_expr] in + let expr0 = map_expr_to0 expr in + OUnit.assert_bool "a single tuple argument does not carry bridge metadata" + (not (has_attr "_res.constructor_args" expr0.pexp_attributes)); + (match (map_expr0 expr0).pexp_desc with + | Parsetree.Pexp_construct (_, [{pexp_desc = Pexp_tuple [_; _]}]) -> () + | _ -> assert_failure "Expected one tuple argument after roundtrip"); + let pat = Ast_helper.Pat.construct ~loc lid [int_pat "1"; int_pat "2"] in + let pat0 = map_pat_to0 pat in + (match pat0.ppat_desc with + | Parsetree0.Ppat_construct (_, Some {ppat_desc = Ppat_tuple [_; _]}) -> + OUnit.assert_bool "pattern arguments carry bridge metadata" + (has_attr "_res.constructor_args" pat0.ppat_attributes) + | _ -> assert_failure "Expected a tuple-encoded v0 constructor pattern"); + match (map_pat0 pat0).ppat_desc with + | Parsetree.Ppat_construct (_, [_; _]) -> () + | _ -> assert_failure "Expected two pattern arguments after roundtrip" + +let test_ast0_explicit_arity_becomes_constructor_args _ = + let arg value = + Ast_helper0.Exp.constant ~loc (Parsetree0.Pconst_integer (value, None)) + in + let expr0 = + Ast_helper0.Exp.construct ~loc + ~attrs:[attr "ocaml.explicit_arity" (Parsetree0.PStr [])] + (Location.mknoloc (Longident.Lident "Pair")) + (Some (Ast_helper0.Exp.tuple ~loc [arg "1"; arg "2"])) + in + match (map_expr0 expr0).pexp_desc with + | Parsetree.Pexp_construct (_, [_; _]) -> () + | _ -> assert_failure "Expected explicit-arity v0 payload to become arguments" + +let test_polyvariant_args_roundtrip_through_ast0 _ = + let int_expr value = + Ast_helper.Exp.constant ~loc (Parsetree.Pconst_integer (value, None)) + in + let int_pat value = + Ast_helper.Pat.constant ~loc (Parsetree.Pconst_integer (value, None)) + in + let expr = Ast_helper.Exp.variant ~loc "Pair" [int_expr "1"; int_expr "2"] in + let expr0 = map_expr_to0 expr in + (match expr0.pexp_desc with + | Parsetree0.Pexp_variant ("Pair", Some {pexp_desc = Pexp_tuple [_; _]}) -> + OUnit.assert_bool "polymorphic variant arguments carry bridge metadata" + (has_attr "_res.constructor_args" expr0.pexp_attributes) + | _ -> assert_failure "Expected tuple-encoded v0 polymorphic variant payload"); + (match (map_expr0 expr0).pexp_desc with + | Parsetree.Pexp_variant ("Pair", [_; _]) -> () + | _ -> assert_failure "Expected two polymorphic variant arguments"); + let pat = Ast_helper.Pat.variant ~loc "Pair" [int_pat "1"; int_pat "2"] in + let pat0 = map_pat_to0 pat in + (match pat0.ppat_desc with + | Parsetree0.Ppat_variant ("Pair", Some {ppat_desc = Ppat_tuple [_; _]}) -> + OUnit.assert_bool "polymorphic variant pattern arguments carry metadata" + (has_attr "_res.constructor_args" pat0.ppat_attributes) + | _ -> assert_failure "Expected tuple-encoded v0 polymorphic variant pattern"); + (match (map_pat0 pat0).ppat_desc with + | Parsetree.Ppat_variant ("Pair", [_; _]) -> () + | _ -> assert_failure "Expected two polymorphic variant pattern arguments"); + let int_type = + Ast_helper.Typ.constr ~loc (Location.mknoloc (Longident.Lident "int")) [] + in + let typ = + Ast_helper.Typ.variant ~loc + [ + Parsetree.Rtag + ( Location.mknoloc "Pair", + [], + false, + [Location.mkloc [int_type; int_type] loc] ); + ] + Closed None + in + let typ0 = + Ast_mapper_to0.default_mapper.typ Ast_mapper_to0.default_mapper typ + in + (match typ0.ptyp_desc with + | Parsetree0.Ptyp_variant + ( [Rtag ({txt = "Pair"}, _, false, [{ptyp_desc = Ptyp_tuple [_; _]}])], + _, + _ ) -> + () + | _ -> assert_failure "Expected tuple-encoded v0 polymorphic variant type"); + let typ = + Ast_mapper_from0.default_mapper.typ Ast_mapper_from0.default_mapper typ0 + in + match typ.ptyp_desc with + | Parsetree.Ptyp_variant + ([Rtag ({txt = "Pair"}, _, false, [{txt = [_; _]}])], _, _) -> + () + | _ -> assert_failure "Expected two polymorphic variant type arguments" + let assert_string_expr ~expected_source ~expected_semantic expr = match expr.Parsetree.pexp_desc with | Pexp_constant (Pconst_string payload) -> @@ -808,6 +925,12 @@ let suites = >:: test_malformed_internal_record_rest_attr_fails; "record_rest_roundtrips_through_ast0" >:: test_record_rest_roundtrips_through_ast0; + "constructor_args_roundtrip_through_ast0" + >:: test_constructor_args_roundtrip_through_ast0; + "ast0_explicit_arity_becomes_constructor_args" + >:: test_ast0_explicit_arity_becomes_constructor_args; + "polyvariant_args_roundtrip_through_ast0" + >:: test_polyvariant_args_roundtrip_through_ast0; "value_constraint_roundtrips_through_ast0" >:: test_value_constraint_roundtrips_through_ast0; "function_cases_desugar_to_fun_match" diff --git a/tests/syntax_tests/data/ast-mapping/ConstructorArguments.res b/tests/syntax_tests/data/ast-mapping/ConstructorArguments.res new file mode 100644 index 00000000000..909bdb76b7d --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/ConstructorArguments.res @@ -0,0 +1,25 @@ +type unary = Unary((int, int)) +type binary = Binary(int, int) + +let unary = Unary((1, 2)) +let binary = Binary(1, 2) + +let readUnary = value => + switch value { + | Unary((x, y)) => x + y + } + +let readBinary = value => + switch value { + | Binary(x, y) => x + y + } + +type poly = [#UnaryTuple((int, int)) | #BinaryArgs(int, int)] + +let polyUnary: poly = #UnaryTuple((1, 2)) +let polyBinary: poly = #BinaryArgs(1, 2) + +let readPoly = value => + switch value { + | #UnaryTuple((x, y)) | #BinaryArgs(x, y) => x + y + } diff --git a/tests/syntax_tests/data/ast-mapping/expected/ConstructorArguments.res.txt b/tests/syntax_tests/data/ast-mapping/expected/ConstructorArguments.res.txt new file mode 100644 index 00000000000..909bdb76b7d --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/expected/ConstructorArguments.res.txt @@ -0,0 +1,25 @@ +type unary = Unary((int, int)) +type binary = Binary(int, int) + +let unary = Unary((1, 2)) +let binary = Binary(1, 2) + +let readUnary = value => + switch value { + | Unary((x, y)) => x + y + } + +let readBinary = value => + switch value { + | Binary(x, y) => x + y + } + +type poly = [#UnaryTuple((int, int)) | #BinaryArgs(int, int)] + +let polyUnary: poly = #UnaryTuple((1, 2)) +let polyBinary: poly = #BinaryArgs(1, 2) + +let readPoly = value => + switch value { + | #UnaryTuple((x, y)) | #BinaryArgs(x, y) => x + y + } diff --git a/tests/tests/src/constructor_explicit_arity.mjs b/tests/tests/src/constructor_explicit_arity.mjs new file mode 100644 index 00000000000..e84a82dcfab --- /dev/null +++ b/tests/tests/src/constructor_explicit_arity.mjs @@ -0,0 +1,56 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +function readUnary(value) { + let match = value._0; + return match[0] + match[1] | 0; +} + +function readBinary(value) { + return value._0 + value._1 | 0; +} + +function readPoly(value) { + return value.VAL[0] + value.VAL[1] | 0; +} + +let unary = { + TAG: "Unary", + _0: [ + 1, + 2 + ] +}; + +let binary = { + TAG: "Binary", + _0: 1, + _1: 2 +}; + +let polyUnary = { + NAME: "UnaryTuple", + VAL: [ + 1, + 2 + ] +}; + +let polyBinary = { + NAME: "BinaryArgs", + VAL: [ + 1, + 2 + ] +}; + +export { + unary, + binary, + readUnary, + readBinary, + polyUnary, + polyBinary, + readPoly, +} +/* No side effect */ diff --git a/tests/tests/src/constructor_explicit_arity.res b/tests/tests/src/constructor_explicit_arity.res new file mode 100644 index 00000000000..909bdb76b7d --- /dev/null +++ b/tests/tests/src/constructor_explicit_arity.res @@ -0,0 +1,25 @@ +type unary = Unary((int, int)) +type binary = Binary(int, int) + +let unary = Unary((1, 2)) +let binary = Binary(1, 2) + +let readUnary = value => + switch value { + | Unary((x, y)) => x + y + } + +let readBinary = value => + switch value { + | Binary(x, y) => x + y + } + +type poly = [#UnaryTuple((int, int)) | #BinaryArgs(int, int)] + +let polyUnary: poly = #UnaryTuple((1, 2)) +let polyBinary: poly = #BinaryArgs(1, 2) + +let readPoly = value => + switch value { + | #UnaryTuple((x, y)) | #BinaryArgs(x, y) => x + y + } diff --git a/tests/tests/src/exception_raise_test.res b/tests/tests/src/exception_raise_test.res index ca6ea90f722..010139b2f0b 100644 --- a/tests/tests/src/exception_raise_test.res +++ b/tests/tests/src/exception_raise_test.res @@ -18,7 +18,7 @@ let appf = (g, x) => { | U.A(_) => 3 | B(list{_, _, x, ..._}) => x | C(x, _) - | D(x, _) => x + | D((x, _)) => x | _ => 4 } } diff --git a/tests/tests/src/mario_game.res b/tests/tests/src/mario_game.res index 20345edbbe7..b4d7fe2acdc 100644 --- a/tests/tests/src/mario_game.res +++ b/tests/tests/src/mario_game.res @@ -1123,17 +1123,17 @@ module Object: { BigM } if !prev_jumping && player.jumping { - Some(pl_typ, Sprite.make(SPlayer(pl_typ, Jumping), player.dir, context)) + Some((pl_typ, Sprite.make(SPlayer(pl_typ, Jumping), player.dir, context))) } else if ( prev_dir != player.dir || (prev_vx == 0. && Math.abs(player.vel.x) > 0. && !player.jumping) ) { - Some(pl_typ, Sprite.make(SPlayer(pl_typ, Running), player.dir, context)) + Some((pl_typ, Sprite.make(SPlayer(pl_typ, Running), player.dir, context))) } else if prev_dir != player.dir && (player.jumping && prev_jumping) { - Some(pl_typ, Sprite.make(SPlayer(pl_typ, Jumping), player.dir, context)) + Some((pl_typ, Sprite.make(SPlayer(pl_typ, Jumping), player.dir, context))) } else if player.vel.y == 0. && player.crouch { - Some(pl_typ, Sprite.make(SPlayer(pl_typ, Crouching), player.dir, context)) + Some((pl_typ, Sprite.make(SPlayer(pl_typ, Crouching), player.dir, context))) } else if player.vel.y == 0. && player.vel.x == 0. { - Some(pl_typ, Sprite.make(SPlayer(pl_typ, Standing), player.dir, context)) + Some((pl_typ, Sprite.make(SPlayer(pl_typ, Standing), player.dir, context))) } else { None } @@ -2020,7 +2020,7 @@ module Director: { o.crouch = false let player = switch Object.update_player(o, keys, state.ctx) { | None => p - | Some(new_typ, new_spr) => + | Some((new_typ, new_spr)) => Object.normalize_pos(o.pos, s.params, new_spr.params) Player(new_typ, new_spr, o) } diff --git a/tests/tests/src/tramp_fib.mjs b/tests/tests/src/tramp_fib.mjs index 67c841d559f..5dd085d7b2d 100644 --- a/tests/tests/src/tramp_fib.mjs +++ b/tests/tests/src/tramp_fib.mjs @@ -70,8 +70,8 @@ function isOdd(n) { } Mocha.describe("Tramp_fib", () => { - Mocha.test("fibonacci trampoline", () => Test_utils.eq("File \"tramp_fib.res\", line 55, characters 7-14", iter(u), 89)); - Mocha.test("even/odd trampoline", () => Test_utils.eq("File \"tramp_fib.res\", line 59, characters 7-14", iter(isEven(20000)), true)); + Mocha.test("fibonacci trampoline", () => Test_utils.eq("File \"tramp_fib.res\", line 54, characters 7-14", iter(u), 89)); + Mocha.test("even/odd trampoline", () => Test_utils.eq("File \"tramp_fib.res\", line 58, characters 7-14", iter(isEven(20000)), true)); }); export { diff --git a/tests/tests/src/tramp_fib.res b/tests/tests/src/tramp_fib.res index 452c070470b..f3a6d06ec39 100644 --- a/tests/tests/src/tramp_fib.res +++ b/tests/tests/src/tramp_fib.res @@ -16,14 +16,13 @@ let rec fib = (n, k) => k(1) | _ => Suspend( - () => - fib(n - 1, v0 => fib(n - 2, v1 => k(v0 + v1))), - /* match v0,v1 with - | Continue v0, Continue v1 -> */ - /* k (Continue (v0 + v1)) [@bs] */ - /* Suspend (fun [@bs]() -> k (Continue (v0 + v1)) [@bs]) */ - /* | _ -> assert false */ - /* FIXME: this branch completly gone */ + () => fib(n - 1, v0 => fib(n - 2, v1 => k(v0 + v1))), + /* match v0,v1 with + | Continue v0, Continue v1 -> */ + /* k (Continue (v0 + v1)) [@bs] */ + /* Suspend (fun [@bs]() -> k (Continue (v0 + v1)) [@bs]) */ + /* | _ -> assert false */ + /* FIXME: this branch completly gone */ ) } diff --git a/tests/tests/src/unboxed_attribute.res b/tests/tests/src/unboxed_attribute.res index 0cc4e87d866..d1e16b75c1f 100644 --- a/tests/tests/src/unboxed_attribute.res +++ b/tests/tests/src/unboxed_attribute.res @@ -1,4 +1,4 @@ type rec func<'a, 'b, 'i> = 'i => res<'a, 'b, 'i> @unboxed and res<'a, 'b, 'i> = Val(('b, func<'a, 'b, 'i>)) -let rec u = _ => Val(3, u) +let rec u = _ => Val((3, u)) diff --git a/tests/tests/src/variant.res b/tests/tests/src/variant.res index 5b4aaab9d71..0e7c9e19999 100644 --- a/tests/tests/src/variant.res +++ b/tests/tests/src/variant.res @@ -9,7 +9,7 @@ let b = B(34) let c = C(4, 2) -let d = D(4, 2) +let d = D((4, 2)) let foo = x => switch x { @@ -17,7 +17,7 @@ let foo = x => | A2 => 2 | B(n) => n | C(n, m) => n + m - | D(n, m) => n + m + | D((n, m)) => n + m } let fooA1 = x => @@ -83,5 +83,5 @@ let fooExn = f => | EA2 => 2 | EB(n) => n | EC(n, m) => n + m - | ED(n, m) => n + m + | ED((n, m)) => n + m } diff --git a/tools/src/migrate.ml b/tools/src/migrate.ml index bbb88c286b6..7b7ff184ce1 100644 --- a/tools/src/migrate.ml +++ b/tools/src/migrate.ml @@ -8,7 +8,7 @@ module Int_set = Set.Make (Int) let is_unit_expr (e : Parsetree.expression) = match e.pexp_desc with - | Pexp_construct ({txt = Lident "()"}, None) -> true + | Pexp_construct ({txt = Lident "()"}, []) -> true | _ -> false module Insert_ext = struct @@ -54,7 +54,7 @@ module Expr_utils = struct match e.pexp_desc with | Pexp_apply {funct = {pexp_desc = Pexp_ident {txt = Lident "->"}}; _} -> true - | Pexp_construct (_, Some e) + | Pexp_construct (_, [e]) | Pexp_constraint (e, _) | Pexp_coerce (e, _, _) | Pexp_let (_, _, e) @@ -677,7 +677,7 @@ let make_mapper (deprecated_used : Cmt_utils.deprecated_used list) = | {pexp_desc = Pexp_construct (lid, arg); pexp_loc} -> ( match find_constructor_target ~loc:pexp_loc ~lid_loc:lid.loc with | Some {Constructor_replace.lid; attrs} -> - let arg = Option.map (mapper.expr mapper) arg in + let arg = List.map (mapper.expr mapper) arg in let replaced = {exp with pexp_desc = Pexp_construct (lid, arg)} in Mapper_utils.Apply_transforms.attach_to_replacement ~attrs replaced @@ -723,7 +723,7 @@ let make_mapper (deprecated_used : Cmt_utils.deprecated_used list) = | {ppat_desc = Ppat_construct (lid, arg); ppat_loc} -> ( match find_constructor_target ~loc:ppat_loc ~lid_loc:lid.loc with | Some {Constructor_replace.lid; attrs} -> - let arg = Option.map (mapper.pat mapper) arg in + let arg = List.map (mapper.pat mapper) arg in let replaced = {pat with ppat_desc = Ppat_construct (lid, arg)} in Mapper_utils.Apply_transforms.attach_attrs_to_pat ~attrs replaced | None -> Ast_mapper.default_mapper.pat mapper pat) diff --git a/tools/src/transforms.ml b/tools/src/transforms.ml index da3e07f94a9..924b61eb436 100644 --- a/tools/src/transforms.ml +++ b/tools/src/transforms.ml @@ -42,7 +42,7 @@ let drop_unit_arguments_in_apply (e : Parsetree.expression) : (* Drop only unlabelled unit arguments from an application expression. *) let is_unit_expr (e : Parsetree.expression) = match e.pexp_desc with - | Pexp_construct ({txt = Lident "()"}, None) -> true + | Pexp_construct ({txt = Lident "()"}, []) -> true | _ -> false in match e.pexp_desc with From 2201335bf4aaccd3597e88636fabf2b95b33b361 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:08:55 +0200 Subject: [PATCH 02/40] Remove obsolete parser printer flag Signed-off-by: Christoph Knittel --- analysis/src/codemod.ml | 4 +- analysis/src/commands.ml | 6 +- analysis/src/completion_front_end.ml | 9 +-- analysis/src/diagnostics.ml | 6 +- analysis/src/document_symbol.ml | 9 +-- analysis/src/dump_ast.ml | 3 +- analysis/src/hint.ml | 10 +--- analysis/src/semantic_tokens.ml | 9 +-- analysis/src/signature_help.ml | 7 +-- analysis/src/xform.ml | 6 +- compiler/bsc/rescript_compiler_main.ml | 8 +-- compiler/jsoo/jsoo_playground_main.ml | 15 ++--- compiler/syntax/cli/res_cli.ml | 21 ++----- compiler/syntax/src/res_driver.ml | 56 +++++++------------ compiler/syntax/src/res_driver.mli | 18 ++---- compiler/syntax/src/res_multi_printer.ml | 6 +- tests/ounit_tests/ounit_ast_mapper0_tests.ml | 4 +- tests/ounit_tests/ounit_jsx_loc_tests.ml | 4 +- .../ounit_tests/ounit_string_literal_tests.ml | 33 +++++------ tests/syntax_tests/res_test.ml | 5 +- tools/src/migrate.ml | 8 +-- tools/src/tools.ml | 26 ++++----- 22 files changed, 91 insertions(+), 182 deletions(-) diff --git a/analysis/src/codemod.ml b/analysis/src/codemod.ml index 235948bdd1f..5f7cfbc9349 100644 --- a/analysis/src/codemod.ml +++ b/analysis/src/codemod.ml @@ -13,8 +13,8 @@ let transform_opt ~source ~pos ~debug ~typ ~hint = | AddMissingCases -> ( let source = "let " ^ hint ^ " = ()" in let {Res_driver.parsetree = hint_structure} = - Res_driver.parse_implementation_from_source ~for_printer:false - ~display_filename:"" ~source + Res_driver.parse_implementation_from_source ~display_filename:"" + ~source in match hint_structure with | [{pstr_desc = Pstr_value (_, [{pvb_pat = pattern}])}] -> ( diff --git a/analysis/src/commands.ml b/analysis/src/commands.ml index 391661b216d..746c9d9ea50 100644 --- a/analysis/src/commands.ml +++ b/analysis/src/commands.ml @@ -304,8 +304,7 @@ let format ~source ~kind_file = match kind_file with | Files.Res -> ( let {Res_driver.parsetree = structure; comments; diagnostics} = - Res_driver.parsing_engine.parse_implementation_from_source - ~for_printer:true ~source + Res_driver.parsing_engine.parse_implementation_from_source ~source in match List.length diagnostics > 0 with | true -> Error "Document has syntax errors" @@ -314,8 +313,7 @@ let format ~source ~kind_file = ) | Resi -> ( let {Res_driver.parsetree = signature; comments; diagnostics} = - Res_driver.parsing_engine.parse_interface_from_source ~for_printer:true - ~source + Res_driver.parsing_engine.parse_interface_from_source ~source in match List.length diagnostics > 0 with | true -> Error "Document has syntax errors" diff --git a/analysis/src/completion_front_end.ml b/analysis/src/completion_front_end.ml index 24874f4a4b7..994b5a84a53 100644 --- a/analysis/src/completion_front_end.ml +++ b/analysis/src/completion_front_end.ml @@ -1884,10 +1884,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file in if kind_file = Files.Res then ( - let parser = - Res_driver.parsing_engine.parse_implementation_from_source - ~for_printer:false - in + let parser = Res_driver.parsing_engine.parse_implementation_from_source in let {Res_driver.parsetree = str} = parser ~source:text in iterator.structure iterator str |> ignore; if blank_after_cursor = Some ' ' || blank_after_cursor = Some '\n' then ( @@ -1898,9 +1895,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file if !found = false then if debug then Printf.printf "XXX Not found!\n"; !result) else if kind_file = Resi then ( - let parser = - Res_driver.parsing_engine.parse_interface_from_source ~for_printer:false - in + let parser = Res_driver.parsing_engine.parse_interface_from_source in let {Res_driver.parsetree = signature} = parser ~source:text in iterator.signature iterator signature |> ignore; if blank_after_cursor = Some ' ' || blank_after_cursor = Some '\n' then ( diff --git a/analysis/src/diagnostics.ml b/analysis/src/diagnostics.ml index 2b73f9b7d9a..fa1fc720c86 100644 --- a/analysis/src/diagnostics.ml +++ b/analysis/src/diagnostics.ml @@ -22,14 +22,12 @@ let document_syntax ~source ~kind_file = in if kind_file = Files.Res then let parse_implementation = - Res_driver.parsing_engine.parse_implementation_from_source - ~for_printer:false ~source + Res_driver.parsing_engine.parse_implementation_from_source ~source in get_diagnostics parse_implementation.diagnostics else if kind_file = Files.Resi then let parse_interface = - Res_driver.parsing_engine.parse_interface_from_source ~for_printer:false - ~source + Res_driver.parsing_engine.parse_interface_from_source ~source in get_diagnostics parse_interface.diagnostics else [] diff --git a/analysis/src/document_symbol.ml b/analysis/src/document_symbol.ml index 3ef53933e54..92ee9e18133 100644 --- a/analysis/src/document_symbol.ml +++ b/analysis/src/document_symbol.ml @@ -118,16 +118,11 @@ let get_symbols ~source ~kind_file = in (if kind_file = Files.Res then - let parser = - Res_driver.parsing_engine.parse_implementation_from_source - ~for_printer:false - in + let parser = Res_driver.parsing_engine.parse_implementation_from_source in let {Res_driver.parsetree = structure} = parser ~source in iterator.structure iterator structure |> ignore else - let parser = - Res_driver.parsing_engine.parse_interface_from_source ~for_printer:false - in + let parser = Res_driver.parsing_engine.parse_interface_from_source in let {Res_driver.parsetree = signature} = parser ~source in iterator.signature iterator signature |> ignore); let is_inside diff --git a/analysis/src/dump_ast.ml b/analysis/src/dump_ast.ml index f6348ef0ea6..34391a1aba6 100644 --- a/analysis/src/dump_ast.ml +++ b/analysis/src/dump_ast.ml @@ -383,8 +383,7 @@ let print_struct_item struct_item ~pos ~source = let dump ~current_file ~pos = let {Res_driver.parsetree = structure; source} = - Res_driver.parsing_engine.parse_implementation ~for_printer:true - ~filename:current_file + Res_driver.parsing_engine.parse_implementation ~filename:current_file in print_endline diff --git a/analysis/src/hint.ml b/analysis/src/hint.ml index fa39a0ce02b..6ab41e64789 100644 --- a/analysis/src/hint.ml +++ b/analysis/src/hint.ml @@ -73,10 +73,7 @@ let inlay ~source ~kind_file ~pos ~max_length ~full ~state ~debug = in let iterator = {Ast_iterator.default_iterator with value_binding} in (if kind_file = Files.Res then - let parser = - Res_driver.parsing_engine.parse_implementation_from_source - ~for_printer:false - in + let parser = Res_driver.parsing_engine.parse_implementation_from_source in let {Res_driver.parsetree = structure} = parser ~source in iterator.structure iterator structure |> ignore); match full with @@ -136,10 +133,7 @@ let code_lens ~source ~kind_file ~full ~debug = (* We only print code lenses in implementation files. This is because they'd be redundant in interface files, where the definition itself will be the same thing as what would've been printed in the code lens. *) (if kind_file = Files.Res then - let parser = - Res_driver.parsing_engine.parse_implementation_from_source - ~for_printer:false - in + let parser = Res_driver.parsing_engine.parse_implementation_from_source in let {Res_driver.parsetree = structure} = parser ~source in iterator.structure iterator structure |> ignore); match full with diff --git a/analysis/src/semantic_tokens.ml b/analysis/src/semantic_tokens.ml index 3a8f925cd10..0ec8f6363dc 100644 --- a/analysis/src/semantic_tokens.ml +++ b/analysis/src/semantic_tokens.ml @@ -498,19 +498,14 @@ let command ~debug ~emitter ~source ~kind_file = in if kind_file = Files.Res then ( - let parser = - Res_driver.parsing_engine.parse_implementation_from_source - ~for_printer:false - in + let parser = Res_driver.parsing_engine.parse_implementation_from_source in let {Res_driver.parsetree = structure; diagnostics} = parser ~source in if debug then Printf.printf "structure items:%d diagnostics:%d\n" (List.length structure) (List.length diagnostics); iterator.structure iterator structure |> ignore) else - let parser = - Res_driver.parsing_engine.parse_interface_from_source ~for_printer:false - in + let parser = Res_driver.parsing_engine.parse_interface_from_source in let {Res_driver.parsetree = signature; diagnostics} = parser ~source in if debug then Printf.printf "signature items:%d diagnostics:%d\n" diff --git a/analysis/src/signature_help.ml b/analysis/src/signature_help.ml index f493311bd76..b7583810f7d 100644 --- a/analysis/src/signature_help.ml +++ b/analysis/src/signature_help.ml @@ -425,10 +425,7 @@ let signature_help ~debug ~source ~kind_file ~pos Ast_iterator.default_iterator.pat iterator pat in let iterator = {Ast_iterator.default_iterator with expr; pat} in - let parser = - Res_driver.parsing_engine.parse_implementation_from_source - ~for_printer:false - in + let parser = Res_driver.parsing_engine.parse_implementation_from_source in let {Res_driver.parsetree = structure} = parser ~source in iterator.structure iterator structure |> ignore; (* Handle function application, if found *) @@ -458,7 +455,7 @@ let signature_help ~debug ~source ~kind_file ~pos let fn_type_str = Shared.type_to_string type_expr in let type_str_for_parser = label_prefix ^ fn_type_str in let {Res_driver.parsetree = signature} = - Res_driver.parse_interface_from_source ~for_printer:false + Res_driver.parse_interface_from_source ~display_filename:"" ~source:type_str_for_parser in diff --git a/analysis/src/xform.ml b/analysis/src/xform.ml index d921bfa2343..56934158bc9 100644 --- a/analysis/src/xform.ml +++ b/analysis/src/xform.ml @@ -865,8 +865,7 @@ end let parse_implementation ~source = let {Res_driver.parsetree = structure; comments} = - Res_driver.parsing_engine.parse_implementation_from_source - ~for_printer:false ~source + Res_driver.parsing_engine.parse_implementation_from_source ~source in let filter_comments ~loc comments = (* Relevant comments in the range of the expression *) @@ -899,8 +898,7 @@ let parse_implementation ~source = let parse_interface ~source = let {Res_driver.parsetree = structure; comments} = - Res_driver.parsing_engine.parse_interface_from_source ~for_printer:false - ~source + Res_driver.parsing_engine.parse_interface_from_source ~source in let filter_comments ~loc comments = (* Relevant comments in the range of the expression *) diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index 95ec7b79e84..8045973e6cf 100644 --- a/compiler/bsc/rescript_compiler_main.ml +++ b/compiler/bsc/rescript_compiler_main.ml @@ -22,7 +22,7 @@ module Error_message_utils_support = struct (Error_message_utils.Parser.parse_source := fun source -> let res = - Res_driver.parse_implementation_from_source ~for_printer:false + Res_driver.parse_implementation_from_source ~display_filename:"" ~source in (res.parsetree, res.comments |> List.map to_comment)); @@ -108,8 +108,7 @@ let reprint_source_file sourcefile = match kind with | Res -> let parse_result = - Res_driver.parsing_engine.parse_implementation ~for_printer:true - ~filename:sourcefile + Res_driver.parsing_engine.parse_implementation ~filename:sourcefile in if parse_result.invalid then ( Res_diagnostics.print_report parse_result.diagnostics @@ -125,8 +124,7 @@ let reprint_source_file sourcefile = |> print_endline | Resi -> let parse_result = - Res_driver.parsing_engine.parse_interface ~for_printer:true - ~filename:sourcefile + Res_driver.parsing_engine.parse_interface ~filename:sourcefile in if parse_result.invalid then ( Res_diagnostics.print_report parse_result.diagnostics diff --git a/compiler/jsoo/jsoo_playground_main.ml b/compiler/jsoo/jsoo_playground_main.ml index 972fec16195..8e36ce3a19a 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -255,7 +255,7 @@ module Res_driver = struct open Res_driver (* adds ~src parameter *) - let setup ~src ~filename ~for_printer:_ () = Res_parser.make src filename + let setup ~src ~filename = Res_parser.make src filename (* get full super error message *) let diagnostic_to_string ~(src : string) (d : Res_diagnostics.t) = @@ -269,10 +269,10 @@ module Res_driver = struct Location.default_error_reporter ~src:(Some src) Format.str_formatter err; Format.flush_str_formatter () - let parse_implementation ~sourcefile ~for_printer ~src = + let parse_implementation ~sourcefile ~src = Location.input_name := sourcefile; let parse_result = - let engine = setup ~filename:sourcefile ~for_printer ~src () in + let engine = setup ~filename:sourcefile ~src in let structure = Res_core.parse_implementation engine in let invalid, diagnostics = match engine.diagnostics with @@ -312,7 +312,7 @@ end let rescript_parse ~filename src = let structure, _ = - Res_driver.parse_implementation ~for_printer:false ~sourcefile:filename ~src + Res_driver.parse_implementation ~sourcefile:filename ~src in structure @@ -739,12 +739,9 @@ module Compile = struct let code = match (from, to_) with | Res, Res -> - (* Essentially pretty printing. - * IMPORTANT: we need forPrinter:true when parsing code here, - * otherwise we will loose some information for the ReScript printer *) + (* Essentially pretty printing. *) let structure, comments = - Res_driver.parse_implementation ~for_printer:true - ~sourcefile:filename ~src + Res_driver.parse_implementation ~sourcefile:filename ~src in Res_printer.print_implementation ~width:80 structure ~comments in diff --git a/compiler/syntax/cli/res_cli.ml b/compiler/syntax/cli/res_cli.ml index dae94cd7ccd..82f359634b8 100644 --- a/compiler/syntax/cli/res_cli.ml +++ b/compiler/syntax/cli/res_cli.ml @@ -160,7 +160,6 @@ module Res_clflags : sig val interface : bool ref val jsx_version : int ref val jsx_module : string ref - val typechecker : bool ref val test_ast_conversion : bool ref val parse : unit -> unit @@ -173,7 +172,6 @@ end = struct let jsx_version = ref (-1) let jsx_module = ref "react" let file = ref "" - let typechecker = ref false let test_ast_conversion = ref false let usage = @@ -206,10 +204,6 @@ end = struct ( "-jsx-module", Arg.String (fun txt -> jsx_module := txt), "Specify the jsx module. Default: react" ); - ( "-typechecker", - Arg.Unit (fun () -> typechecker := true), - "Parses the ast as it would be passed to the typechecker and not the \ - printer" ); ( "-test-ast-conversion", Arg.Unit (fun () -> test_ast_conversion := true), "Test the ast conversion" ); @@ -223,7 +217,7 @@ module Cli_arg_processor = struct [@@unboxed] let process_file ~is_interface ~width ~recover ~target ~jsx_version - ~jsx_module ~typechecker ~test_ast_conversion filename = + ~jsx_module ~test_ast_conversion filename = let len = String.length filename in let process_interface = is_interface @@ -246,12 +240,6 @@ module Cli_arg_processor = struct exit 1 in - let for_printer = - match target with - | ("res" | "sexp") when not typechecker -> true - | _ -> false - in - let (Parser backend) = parsing_engine in (* This is the whole purpose of the Color module above *) Color.setup None; @@ -260,7 +248,7 @@ module Cli_arg_processor = struct if target = "tokens" then print_engine.print_implementation ~width ~filename ~comments:[] [] else if process_interface then - let parse_result = backend.parse_interface ~for_printer ~filename in + let parse_result = backend.parse_interface ~filename in if parse_result.invalid then ( backend.string_of_diagnostics ~source:parse_result.source ~filename:parse_result.filename parse_result.diagnostics; @@ -285,7 +273,7 @@ module Cli_arg_processor = struct print_engine.print_interface ~width ~filename ~comments:parse_result.comments parsetree else - let parse_result = backend.parse_implementation ~for_printer ~filename in + let parse_result = backend.parse_implementation ~filename in if parse_result.invalid then ( backend.string_of_diagnostics ~source:parse_result.source ~filename:parse_result.filename parse_result.diagnostics; @@ -318,7 +306,6 @@ let () = Cli_arg_processor.process_file ~is_interface:!Res_clflags.interface ~width:!Res_clflags.width ~recover:!Res_clflags.recover ~target:!Res_clflags.print ~jsx_version:!Res_clflags.jsx_version - ~jsx_module:!Res_clflags.jsx_module ~typechecker:!Res_clflags.typechecker - !Res_clflags.file + ~jsx_module:!Res_clflags.jsx_module !Res_clflags.file ~test_ast_conversion:!Res_clflags.test_ast_conversion) [@@raises exit] diff --git a/compiler/syntax/src/res_driver.ml b/compiler/syntax/src/res_driver.ml index 9cadb5c7091..fa5b2d230c4 100644 --- a/compiler/syntax/src/res_driver.ml +++ b/compiler/syntax/src/res_driver.ml @@ -11,21 +11,13 @@ type ('ast, 'diagnostics) parse_result = { type 'diagnostics parsing_engine = { parse_implementation: - for_printer:bool -> - filename:string -> - (Parsetree.structure, 'diagnostics) parse_result; + filename:string -> (Parsetree.structure, 'diagnostics) parse_result; parse_implementation_from_source: - for_printer:bool -> - source:string -> - (Parsetree.structure, 'diagnostics) parse_result; + source:string -> (Parsetree.structure, 'diagnostics) parse_result; parse_interface: - for_printer:bool -> - filename:string -> - (Parsetree.signature, 'diagnostics) parse_result; + filename:string -> (Parsetree.signature, 'diagnostics) parse_result; parse_interface_from_source: - for_printer:bool -> - source:string -> - (Parsetree.signature, 'diagnostics) parse_result; + source:string -> (Parsetree.signature, 'diagnostics) parse_result; string_of_diagnostics: source:string -> filename:string -> 'diagnostics -> unit; } @@ -57,18 +49,18 @@ type print_engine = { unit; } -let setup ~filename ~for_printer:_ () = +let setup ~filename = let src = IO.read_file ~filename in Res_parser.make src filename -let setup_from_source ~display_filename ~source ~for_printer:_ () = +let setup_from_source ~display_filename ~source = Res_parser.make source display_filename let parsing_engine = { parse_implementation = - (fun ~for_printer ~filename -> - let engine = setup ~filename ~for_printer () in + (fun ~filename -> + let engine = setup ~filename in let structure = Res_core.parse_implementation engine in let invalid, diagnostics = match engine.diagnostics with @@ -84,10 +76,8 @@ let parsing_engine = comments = List.rev engine.comments; }); parse_implementation_from_source = - (fun ~for_printer ~source -> - let engine = - setup_from_source ~source ~for_printer ~display_filename:"source" () - in + (fun ~source -> + let engine = setup_from_source ~source ~display_filename:"source" in let structure = Res_core.parse_implementation engine in let invalid, diagnostics = match engine.diagnostics with @@ -103,8 +93,8 @@ let parsing_engine = comments = List.rev engine.comments; }); parse_interface = - (fun ~for_printer ~filename -> - let engine = setup ~filename ~for_printer () in + (fun ~filename -> + let engine = setup ~filename in let signature = Res_core.parse_specification engine in let invalid, diagnostics = match engine.diagnostics with @@ -120,10 +110,8 @@ let parsing_engine = comments = List.rev engine.comments; }); parse_interface_from_source = - (fun ~for_printer ~source -> - let engine = - setup_from_source ~source ~display_filename:"" ~for_printer () - in + (fun ~source -> + let engine = setup_from_source ~source ~display_filename:"" in let signature = Res_core.parse_specification engine in let invalid, diagnostics = match engine.diagnostics with @@ -143,8 +131,8 @@ let parsing_engine = Res_diagnostics.print_report diagnostics source); } -let parse_implementation_from_source ~for_printer ~display_filename ~source = - let engine = setup_from_source ~display_filename ~source ~for_printer () in +let parse_implementation_from_source ~display_filename ~source = + let engine = setup_from_source ~display_filename ~source in let structure = Res_core.parse_implementation engine in let invalid, diagnostics = match engine.diagnostics with @@ -160,8 +148,8 @@ let parse_implementation_from_source ~for_printer ~display_filename ~source = comments = List.rev engine.comments; } -let parse_interface_from_source ~for_printer ~display_filename ~source = - let engine = setup_from_source ~display_filename ~source ~for_printer () in +let parse_interface_from_source ~display_filename ~source = + let engine = setup_from_source ~display_filename ~source in let signature = Res_core.parse_specification engine in let invalid, diagnostics = match engine.diagnostics with @@ -197,9 +185,7 @@ let print_engine = let parse_implementation ?(ignore_parse_errors = false) sourcefile = Location.input_name := sourcefile; - let parse_result = - parsing_engine.parse_implementation ~for_printer:false ~filename:sourcefile - in + let parse_result = parsing_engine.parse_implementation ~filename:sourcefile in if parse_result.invalid then ( Res_diagnostics.print_report parse_result.diagnostics parse_result.source; if not ignore_parse_errors then exit 1); @@ -208,9 +194,7 @@ let parse_implementation ?(ignore_parse_errors = false) sourcefile = let parse_interface ?(ignore_parse_errors = false) sourcefile = Location.input_name := sourcefile; - let parse_result = - parsing_engine.parse_interface ~for_printer:false ~filename:sourcefile - in + let parse_result = parsing_engine.parse_interface ~filename:sourcefile in if parse_result.invalid then ( Res_diagnostics.print_report parse_result.diagnostics parse_result.source; if not ignore_parse_errors then exit 1); diff --git a/compiler/syntax/src/res_driver.mli b/compiler/syntax/src/res_driver.mli index 4d6feb13de6..6b2e0a12b20 100644 --- a/compiler/syntax/src/res_driver.mli +++ b/compiler/syntax/src/res_driver.mli @@ -9,34 +9,24 @@ type ('ast, 'diagnostics) parse_result = { type 'diagnostics parsing_engine = { parse_implementation: - for_printer:bool -> - filename:string -> - (Parsetree.structure, 'diagnostics) parse_result; + filename:string -> (Parsetree.structure, 'diagnostics) parse_result; parse_implementation_from_source: - for_printer:bool -> - source:string -> - (Parsetree.structure, 'diagnostics) parse_result; + source:string -> (Parsetree.structure, 'diagnostics) parse_result; parse_interface: - for_printer:bool -> - filename:string -> - (Parsetree.signature, 'diagnostics) parse_result; + filename:string -> (Parsetree.signature, 'diagnostics) parse_result; parse_interface_from_source: - for_printer:bool -> - source:string -> - (Parsetree.signature, 'diagnostics) parse_result; + source:string -> (Parsetree.signature, 'diagnostics) parse_result; string_of_diagnostics: source:string -> filename:string -> 'diagnostics -> unit; } val parse_implementation_from_source : - for_printer:bool -> display_filename:string -> source:string -> (Parsetree.structure, Res_diagnostics.t list) parse_result [@@live] val parse_interface_from_source : - for_printer:bool -> display_filename:string -> source:string -> (Parsetree.signature, Res_diagnostics.t list) parse_result diff --git a/compiler/syntax/src/res_multi_printer.ml b/compiler/syntax/src/res_multi_printer.ml index 711241ade50..43c405a31bc 100644 --- a/compiler/syntax/src/res_multi_printer.ml +++ b/compiler/syntax/src/res_multi_printer.ml @@ -1,9 +1,7 @@ (* print res files to res syntax *) let print_res ~ignore_parse_errors ~is_interface ~filename = if is_interface then ( - let parse_result = - Res_driver.parsing_engine.parse_interface ~for_printer:true ~filename - in + let parse_result = Res_driver.parsing_engine.parse_interface ~filename in if parse_result.invalid then ( Res_diagnostics.print_report parse_result.diagnostics parse_result.source; if not ignore_parse_errors then exit 1); @@ -11,7 +9,7 @@ let print_res ~ignore_parse_errors ~is_interface ~filename = ~comments:parse_result.comments parse_result.parsetree) else let parse_result = - Res_driver.parsing_engine.parse_implementation ~for_printer:true ~filename + Res_driver.parsing_engine.parse_implementation ~filename in if parse_result.invalid then ( Res_diagnostics.print_report parse_result.diagnostics parse_result.source; diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index d32e7242455..8dc613c6a40 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -789,7 +789,7 @@ let quote = "\"" let slash = "\\"|} in let parsed = - Res_driver.parse_implementation_from_source ~for_printer:false + Res_driver.parse_implementation_from_source ~display_filename:"StringReprintTest.res" ~source in OUnit.assert_bool "expected valid ReScript source" (not parsed.invalid); @@ -809,7 +809,7 @@ let slash = "\\"|} let test_invalid_utf8_doc_comment_roundtrips_through_ast0 _ = let source = "/** doc " ^ "\xff" ^ " byte */\nlet value = 1" in let parsed = - Res_driver.parse_implementation_from_source ~for_printer:false + Res_driver.parse_implementation_from_source ~display_filename:"InvalidDocComment.res" ~source in OUnit.assert_bool "expected invalid UTF-8 to be diagnosed" parsed.invalid; diff --git a/tests/ounit_tests/ounit_jsx_loc_tests.ml b/tests/ounit_tests/ounit_jsx_loc_tests.ml index 09f667f1626..f05165d044f 100644 --- a/tests/ounit_tests/ounit_jsx_loc_tests.ml +++ b/tests/ounit_tests/ounit_jsx_loc_tests.ml @@ -3,8 +3,8 @@ let assert_equal = OUnit.assert_equal let assert_failure = OUnit.assert_failure let parse_structure source = - Res_driver.parse_implementation_from_source ~for_printer:false - ~display_filename:"JsxLocTest.res" ~source + Res_driver.parse_implementation_from_source ~display_filename:"JsxLocTest.res" + ~source |> fun result -> result.parsetree let roundtrip_structure source = diff --git a/tests/ounit_tests/ounit_string_literal_tests.ml b/tests/ounit_tests/ounit_string_literal_tests.ml index a8fdb3e542a..5474c0f5d7a 100644 --- a/tests/ounit_tests/ounit_string_literal_tests.ml +++ b/tests/ounit_tests/ounit_string_literal_tests.ml @@ -22,7 +22,7 @@ let assert_encoded ~semantic ~expected = let assert_invalid_backquoted_pattern encoded = let source = "let f = value => switch value { | `" ^ encoded ^ "` => 1 }" in let result = - Res_driver.parse_implementation_from_source ~for_printer:false + Res_driver.parse_implementation_from_source ~display_filename:"StringLiteralTest.res" ~source in OUnit.assert_bool "expected an invalid string escape" result.invalid @@ -35,7 +35,7 @@ let f = value => switch value { | `\uD800` => 1 } |} in let result = - Res_driver.parse_implementation_from_source ~for_printer:false + Res_driver.parse_implementation_from_source ~display_filename:"StringLiteralTest.res" ~source in OUnit.assert_equal ~printer:string_of_int 2 (List.length result.diagnostics) @@ -45,14 +45,14 @@ let assert_invalid_tagged_template_pattern tag = "let f = value => switch value { | " ^ tag ^ "`literal` => 1 }" in let result = - Res_driver.parse_implementation_from_source ~for_printer:false + Res_driver.parse_implementation_from_source ~display_filename:"StringLiteralTest.res" ~source in OUnit.assert_bool "expected a tagged template pattern error" result.invalid let assert_invalid_string encoded = let result = - Res_driver.parse_implementation_from_source ~for_printer:false + Res_driver.parse_implementation_from_source ~display_filename:"StringLiteralTest.res" ~source:("let value = \"" ^ encoded ^ "\"") in @@ -60,7 +60,7 @@ let assert_invalid_string encoded = let assert_invalid_template_expression source = let result = - Res_driver.parse_implementation_from_source ~for_printer:false + Res_driver.parse_implementation_from_source ~display_filename:"StringLiteralTest.res" ~source:("let value = `" ^ source ^ "`") in @@ -68,7 +68,7 @@ let assert_invalid_template_expression source = let assert_parsed_string ~source ~expected_semantic = let result = - Res_driver.parse_implementation_from_source ~for_printer:false + Res_driver.parse_implementation_from_source ~display_filename:"StringLiteralTest.res" ~source:("let value = \"" ^ source ^ "\"") in @@ -89,7 +89,7 @@ let assert_parsed_string ~source ~expected_semantic = let assert_invalid_utf8_after_diagnostic () = let source = "let x = (1,\nlet value = \"bad " ^ "\xff" ^ " byte\"" in let result = - Res_driver.parse_implementation_from_source ~for_printer:false + Res_driver.parse_implementation_from_source ~display_filename:"StringLiteralTest.res" ~source in OUnit.assert_equal ~printer:string_of_int 2 (List.length result.diagnostics); @@ -99,9 +99,9 @@ let assert_invalid_utf8_after_diagnostic () = Res_diagnostics.explain diagnostic = "Invalid code point") result.diagnostics) -let assert_parsed_char ~for_printer ~source ~expected_semantic = +let assert_parsed_char ~source ~expected_semantic = let result = - Res_driver.parse_implementation_from_source ~for_printer + Res_driver.parse_implementation_from_source ~display_filename:"StringLiteralTest.res" ~source:("let value = '" ^ source ^ "'") in @@ -129,7 +129,7 @@ let assert_parsed_char ~for_printer ~source ~expected_semantic = let assert_parsed_template_literal ~source = let result = - Res_driver.parse_implementation_from_source ~for_printer:false + Res_driver.parse_implementation_from_source ~display_filename:"StringLiteralTest.res" ~source:("let value = `" ^ source ^ "`") in @@ -156,7 +156,7 @@ let assert_parsed_template_literal ~source = let assert_parsed_template_pattern ~source ~expected_semantic = let result = - Res_driver.parse_implementation_from_source ~for_printer:false + Res_driver.parse_implementation_from_source ~display_filename:"StringLiteralTest.res" ~source:("let f = value => switch value { | `" ^ source ^ "` => 1 }") in @@ -188,7 +188,7 @@ let assert_parsed_template_pattern ~source ~expected_semantic = let assert_parsed_template () = let result = - Res_driver.parse_implementation_from_source ~for_printer:false + Res_driver.parse_implementation_from_source ~display_filename:"StringLiteralTest.res" ~source:"let value = `head\\n${item}tail`" in @@ -227,7 +227,7 @@ let assert_tagged_template_location () = let prefix = "let value = " in let source = prefix ^ "tag`head${item}tail`" in let result = - Res_driver.parse_implementation_from_source ~for_printer:false + Res_driver.parse_implementation_from_source ~display_filename:"StringLiteralTest.res" ~source in match result.parsetree with @@ -246,7 +246,7 @@ let assert_tagged_template_location () = let assert_invalid_json_interpolation () = let result = - Res_driver.parse_implementation_from_source ~for_printer:false + Res_driver.parse_implementation_from_source ~display_filename:"StringLiteralTest.res" ~source:{|let value = json`head${item}tail`|} in @@ -485,10 +485,7 @@ let suites = ( "invalid backquoted pattern after an earlier diagnostic" >:: fun _ -> assert_invalid_backquoted_pattern_after_diagnostic () ); ( "character literals retain source and semantic forms" >:: fun _ -> - assert_parsed_char ~for_printer:false ~source:{|\u{61}|} - ~expected_semantic:0x61; - assert_parsed_char ~for_printer:true ~source:{|\u{61}|} - ~expected_semantic:0x61; + assert_parsed_char ~source:{|\u{61}|} ~expected_semantic:0x61; OUnit.assert_equal ~printer:(Printf.sprintf "%S") {e|\x00|e} (String_literal.encode_char_source 0x00); OUnit.assert_equal ~printer:(Printf.sprintf "%S") "😀" diff --git a/tests/syntax_tests/res_test.ml b/tests/syntax_tests/res_test.ml index 47810416ede..2e4afd20314 100644 --- a/tests/syntax_tests/res_test.ml +++ b/tests/syntax_tests/res_test.ml @@ -71,10 +71,7 @@ module Outcome_printer_tests = struct * and stored in a snapshot `tests/oprint/expected/oprint.resi.txt` *) let run () = let filename = Filename.concat data_dir "oprint/oprint.res" in - let result = - Res_driver.parsing_engine.parse_implementation ~for_printer:false - ~filename - in + let result = Res_driver.parsing_engine.parse_implementation ~filename in let signature = if result.Res_driver.invalid then ( Res_driver.parsing_engine.string_of_diagnostics ~source:result.source diff --git a/tools/src/migrate.ml b/tools/src/migrate.ml index 7b7ff184ce1..f58ddc47c4d 100644 --- a/tools/src/migrate.ml +++ b/tools/src/migrate.ml @@ -741,9 +741,7 @@ let migrate ~entry_point_file ~output_mode = let state = Shared_types.create_state () in let result = if Filename.check_suffix path ".res" then - let parser = - Res_driver.parsing_engine.parse_implementation ~for_printer:true - in + let parser = Res_driver.parsing_engine.parse_implementation in let {Res_driver.parsetree; comments; source} = parser ~filename:path in match Cmt.load_cmt_infos_from_path ~state ~path with | None -> @@ -771,9 +769,7 @@ let migrate ~entry_point_file ~output_mode = ~width:Res_printer.default_print_width ast_transformed ~comments, source ) else if Filename.check_suffix path ".resi" then - let parser = - Res_driver.parsing_engine.parse_interface ~for_printer:true - in + let parser = Res_driver.parsing_engine.parse_interface in let {Res_driver.parsetree = signature; comments; source} = parser ~filename:path in diff --git a/tools/src/tools.ml b/tools/src/tools.ml index 3ae00bff140..3cf3d052dd9 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -623,7 +623,7 @@ let extract_docs ~entry_point_file ~debug = let extract_embedded ~extension_points ~filename = let {Res_driver.parsetree = structure} = - Res_driver.parsing_engine.parse_implementation ~for_printer:false ~filename + Res_driver.parsing_engine.parse_implementation ~filename in let content = ref [] in let append item = content := item :: !content in @@ -801,8 +801,8 @@ module Format_codeblocks = struct let formatted_code = if lang |> String.split_on_char ' ' |> List.hd = "resi" then let {Res_driver.parsetree; comments; invalid; diagnostics} = - Res_driver.parse_interface_from_source ~for_printer:true - ~display_filename ~source:code_with_offset + Res_driver.parse_interface_from_source ~display_filename + ~source:code_with_offset in if invalid then ( report_parse_error diagnostics; @@ -812,8 +812,8 @@ module Format_codeblocks = struct |> String.trim |> Cmarkit.Block_line.list_of_string else let {Res_driver.parsetree; comments; invalid; diagnostics} = - Res_driver.parse_implementation_from_source ~for_printer:true - ~display_filename ~source:code_with_offset + Res_driver.parse_implementation_from_source ~display_filename + ~source:code_with_offset in if invalid then ( report_parse_error diagnostics; @@ -898,9 +898,7 @@ module Format_codeblocks = struct Ok (formatted_contents, content) else Ok (content, content) else if Filename.check_suffix path ".res" then - let parser = - Res_driver.parsing_engine.parse_implementation ~for_printer:true - in + let parser = Res_driver.parsing_engine.parse_implementation in let {Res_driver.parsetree = structure; comments; source; filename} = parser ~filename:path in @@ -911,9 +909,7 @@ module Format_codeblocks = struct let ast_mapped = mapper.structure mapper structure in Ok (Res_printer.print_implementation ast_mapped ~comments, source) else if Filename.check_suffix path ".resi" then - let parser = - Res_driver.parsing_engine.parse_interface ~for_printer:true - in + let parser = Res_driver.parsing_engine.parse_interface in let {Res_driver.parsetree = signature; comments; source; filename} = parser ~filename:path in @@ -1157,8 +1153,8 @@ module Extract_codeblocks = struct let mapped_code = if lang |> String.split_on_char ' ' |> List.hd = "resi" then let {Res_driver.parsetree; comments; invalid; diagnostics} = - Res_driver.parse_interface_from_source ~for_printer:true - ~display_filename ~source:code_with_offset + Res_driver.parse_interface_from_source ~display_filename + ~source:code_with_offset in if invalid then ( report_parse_error diagnostics; @@ -1167,8 +1163,8 @@ module Extract_codeblocks = struct Res_printer.print_interface parsetree ~comments |> String.trim else let {Res_driver.parsetree; comments; invalid; diagnostics} = - Res_driver.parse_implementation_from_source ~for_printer:true - ~display_filename ~source:code_with_offset + Res_driver.parse_implementation_from_source ~display_filename + ~source:code_with_offset in if invalid then ( report_parse_error diagnostics; From 89684c2752f9815aafa106fbf074e69cd76d311b Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:09:00 +0200 Subject: [PATCH 03/40] Share constructor pattern argument parsing Signed-off-by: Christoph Knittel --- compiler/syntax/src/res_core.ml | 44 ++++++------------- .../src/expected/CompletionPattern.res.txt | 4 +- 2 files changed, 16 insertions(+), 32 deletions(-) diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 5f524753750..661244d956a 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -1738,7 +1738,7 @@ and parse_array_pattern ~attrs p = let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Pat.array ~loc ~attrs patterns -and parse_constructor_pattern_args p constr start_pos attrs = +and parse_pattern_args (p : Parser.t) = let lparen = p.start_pos in Parser.expect Lparen p; let args = @@ -1746,40 +1746,24 @@ and parse_constructor_pattern_args p constr start_pos attrs = ~f:parse_constrained_pattern_region in Parser.expect Rparen p; - let args = - match args with - | [] -> - let loc = mk_loc lparen p.prev_end_pos in - [ - Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - []; - ] - | patterns -> patterns - in + match args with + | [] -> + let loc = mk_loc lparen p.prev_end_pos in + [ + Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + []; + ] + | patterns -> patterns + +and parse_constructor_pattern_args p constr start_pos attrs = + let args = parse_pattern_args p in Ast_helper.Pat.construct ~loc:(mk_loc start_pos p.prev_end_pos) ~attrs constr args and parse_variant_pattern_args p ident start_pos attrs = - let lparen = p.start_pos in - Parser.expect Lparen p; - let patterns = - parse_comma_delimited_region p ~grammar:Grammar.PatternList ~closing:Rparen - ~f:parse_constrained_pattern_region - in - let args = - match patterns with - | [] -> - let loc = mk_loc lparen p.prev_end_pos in - [ - Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - []; - ] - | patterns -> patterns - in - Parser.expect Rparen p; + let args = parse_pattern_args p in Ast_helper.Pat.variant ~loc:(mk_loc start_pos p.prev_end_pos) ~attrs ident args diff --git a/tests/analysis_tests/tests/src/expected/CompletionPattern.res.txt b/tests/analysis_tests/tests/src/expected/CompletionPattern.res.txt index ecde04f0f47..2dc4d2f8968 100644 --- a/tests/analysis_tests/tests/src/expected/CompletionPattern.res.txt +++ b/tests/analysis_tests/tests/src/expected/CompletionPattern.res.txt @@ -437,8 +437,8 @@ Path z Complete src/CompletionPattern.res 103:21 posCursor:[103:21] posNoWhite:[103:20] Found pattern:[103:16->103:22] -posCursor:[103:21] posNoWhite:[103:20] Found pattern:[103:20->103:21] -Ppat_construct ():[103:20->103:21] +posCursor:[103:21] posNoWhite:[103:20] Found pattern:[103:20->103:22] +Ppat_construct ():[103:20->103:22] Completable: Cpattern Value[b]->polyvariantPayload::two($0) Package opens Stdlib.place holder Pervasives.JsxModules.place holder Resolved opens 1 Stdlib From a2e5db1e69f63ba04f7fb35e98f6a34cd648edf1 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:09:05 +0200 Subject: [PATCH 04/40] Share constructor argument printing Signed-off-by: Christoph Knittel --- compiler/syntax/src/res_printer.ml | 288 +++++++++-------------------- 1 file changed, 92 insertions(+), 196 deletions(-) diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 3703648f981..40c6f5b196b 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -2622,6 +2622,49 @@ and print_extension ~state ~at_module_lvl (string_loc, payload) cmt_tbl = in Doc.group (Doc.concat [ext_name; print_payload ~state payload cmt_tbl]) +and print_pattern_args ~state (patterns : Parsetree.pattern list) cmt_tbl = + match patterns with + | [] -> Doc.nil + | [{ppat_loc; ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)}] + -> + Doc.concat [Doc.lparen; print_comments_inside cmt_tbl ppat_loc; Doc.rparen] + | [{ppat_desc = Ppat_tuple []; ppat_loc = loc}] -> + Doc.concat [Doc.lparen; print_comments_inside cmt_tbl loc; Doc.rparen] + | _ :: _ :: _ -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map + (fun pat -> print_pattern ~state pat cmt_tbl) + patterns); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rparen; + ] + | [arg] -> + let arg_doc = print_pattern ~state arg cmt_tbl in + let should_hug = Parsetree_viewer.is_huggable_pattern arg in + Doc.concat + [ + Doc.lparen; + (if should_hug then arg_doc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.soft_line; arg_doc]); + Doc.trailing_comma; + Doc.soft_line; + ]); + Doc.rparen; + ] + and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = let pattern_without_attributes = match p.ppat_desc with @@ -2719,101 +2762,13 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = ]) | Ppat_construct (constr_name, constructor_args) -> let constr_name = print_longident_location constr_name cmt_tbl in - let args_doc = - match constructor_args with - | [] -> Doc.nil - | [ - { - ppat_loc; - ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _); - }; - ] -> - Doc.concat - [Doc.lparen; print_comments_inside cmt_tbl ppat_loc; Doc.rparen] - | [{ppat_desc = Ppat_tuple []; ppat_loc = loc}] -> - Doc.concat [Doc.lparen; print_comments_inside cmt_tbl loc; Doc.rparen] - | _ :: _ :: _ as patterns -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.soft_line; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun pat -> print_pattern ~state pat cmt_tbl) - patterns); - ]); - Doc.trailing_comma; - Doc.soft_line; - Doc.rparen; - ] - | [arg] -> - let arg_doc = print_pattern ~state arg cmt_tbl in - let should_hug = Parsetree_viewer.is_huggable_pattern arg in - Doc.concat - [ - Doc.lparen; - (if should_hug then arg_doc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.soft_line; arg_doc]); - Doc.trailing_comma; - Doc.soft_line; - ]); - Doc.rparen; - ] - in + let args_doc = print_pattern_args ~state constructor_args cmt_tbl in Doc.group (Doc.concat [constr_name; args_doc]) - | Ppat_variant (label, []) -> - Doc.concat [Doc.text "#"; print_poly_var_ident label] | Ppat_variant (label, variant_args) -> let variant_name = Doc.concat [Doc.text "#"; print_poly_var_ident label] in - let args_doc = - match variant_args with - | [{ppat_desc = Ppat_construct ({txt = Longident.Lident "()"}, _)}] -> - Doc.text "()" - | _ :: _ :: _ as patterns -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.soft_line; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun pat -> print_pattern ~state pat cmt_tbl) - patterns); - ]); - Doc.trailing_comma; - Doc.soft_line; - Doc.rparen; - ] - | [arg] -> - let arg_doc = print_pattern ~state arg cmt_tbl in - let should_hug = Parsetree_viewer.is_huggable_pattern arg in - Doc.concat - [ - Doc.lparen; - (if should_hug then arg_doc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.soft_line; arg_doc]); - Doc.trailing_comma; - Doc.soft_line; - ]); - Doc.rparen; - ] - | [] -> Doc.nil - in + let args_doc = print_pattern_args ~state variant_args cmt_tbl in Doc.group (Doc.concat [variant_name; args_doc]) | Ppat_type ident when Parsetree_viewer.has_res_pat_variant_spread_attribute @@ -3059,6 +3014,51 @@ and print_expression_with_comments ~state expr cmt_tbl : Doc.t = let doc = print_expression ~state expr cmt_tbl in print_comments doc cmt_tbl expr.Parsetree.pexp_loc +and print_expression_args ~state (args : Parsetree.expression list) cmt_tbl = + let print_arg expr = + let doc = print_expression_with_comments ~state expr cmt_tbl in + match Parens.expr expr with + | Parens.Parenthesized -> add_parens doc + | Braced braces -> print_braces doc expr braces + | Nothing -> doc + in + match args with + | [] -> Doc.nil + | [{pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}] -> + Doc.text "()" + | _ :: _ :: _ -> + Doc.concat + [ + Doc.lparen; + Doc.indent + (Doc.concat + [ + Doc.soft_line; + Doc.join + ~sep:(Doc.concat [Doc.comma; Doc.line]) + (List.map print_arg args); + ]); + Doc.trailing_comma; + Doc.soft_line; + Doc.rparen; + ] + | [arg] -> + let arg_doc = print_arg arg in + let should_hug = Parsetree_viewer.is_huggable_expression arg in + Doc.concat + [ + Doc.lparen; + (if should_hug then arg_doc + else + Doc.concat + [ + Doc.indent (Doc.concat [Doc.soft_line; arg_doc]); + Doc.trailing_comma; + Doc.soft_line; + ]); + Doc.rparen; + ] + and print_if_chain ~state pexp_attributes ifs else_expr cmt_tbl = let if_docs = Doc.join ~sep:Doc.space @@ -3278,59 +3278,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = ]) | Pexp_construct (longident_loc, args) -> let constr = print_longident_location longident_loc cmt_tbl in - let args = - match args with - | [] -> Doc.nil - | [{pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}] -> - Doc.text "()" - | _ :: _ :: _ as args -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.soft_line; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun expr -> - let doc = - print_expression_with_comments ~state expr cmt_tbl - in - match Parens.expr expr with - | Parens.Parenthesized -> add_parens doc - | Braced braces -> print_braces doc expr braces - | Nothing -> doc) - args); - ]); - Doc.trailing_comma; - Doc.soft_line; - Doc.rparen; - ] - | [arg] -> - let arg_doc = - let doc = print_expression_with_comments ~state arg cmt_tbl in - match Parens.expr arg with - | Parens.Parenthesized -> add_parens doc - | Braced braces -> print_braces doc arg braces - | Nothing -> doc - in - let should_hug = Parsetree_viewer.is_huggable_expression arg in - Doc.concat - [ - Doc.lparen; - (if should_hug then arg_doc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.soft_line; arg_doc]); - Doc.trailing_comma; - Doc.soft_line; - ]); - Doc.rparen; - ] - in + let args = print_expression_args ~state args cmt_tbl in Doc.group (Doc.concat [constr; args]) | Pexp_ident path -> print_lident_path path cmt_tbl | Pexp_tuple exprs -> @@ -3392,59 +3340,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = let variant_name = Doc.concat [Doc.text "#"; print_poly_var_ident label] in - let args = - match args with - | [{pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, _)}] -> - Doc.text "()" - | _ :: _ :: _ as args -> - Doc.concat - [ - Doc.lparen; - Doc.indent - (Doc.concat - [ - Doc.soft_line; - Doc.join - ~sep:(Doc.concat [Doc.comma; Doc.line]) - (List.map - (fun expr -> - let doc = - print_expression_with_comments ~state expr cmt_tbl - in - match Parens.expr expr with - | Parens.Parenthesized -> add_parens doc - | Braced braces -> print_braces doc expr braces - | Nothing -> doc) - args); - ]); - Doc.trailing_comma; - Doc.soft_line; - Doc.rparen; - ] - | [arg] -> - let arg_doc = - let doc = print_expression_with_comments ~state arg cmt_tbl in - match Parens.expr arg with - | Parens.Parenthesized -> add_parens doc - | Braced braces -> print_braces doc arg braces - | Nothing -> doc - in - let should_hug = Parsetree_viewer.is_huggable_expression arg in - Doc.concat - [ - Doc.lparen; - (if should_hug then arg_doc - else - Doc.concat - [ - Doc.indent (Doc.concat [Doc.soft_line; arg_doc]); - Doc.trailing_comma; - Doc.soft_line; - ]); - Doc.rparen; - ] - | [] -> Doc.nil - in + let args = print_expression_args ~state args cmt_tbl in Doc.group (Doc.concat [variant_name; args]) | Pexp_record (rows, spread_expr) -> if rows = [] then From bc05fa5e2bd68a31bf94d7ae4daa69d03b58bb12 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:09:08 +0200 Subject: [PATCH 05/40] Centralize AST0 constructor argument bridging Signed-off-by: Christoph Knittel --- compiler/ml/ast_mapper_from0.ml | 65 ++++++++++++++++++++------------- compiler/ml/ast_mapper_to0.ml | 46 +++++++++-------------- 2 files changed, 57 insertions(+), 54 deletions(-) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index cd4e3f399f2..3e27e0e0ada 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -176,6 +176,13 @@ let remove_constructor_args_attr (attrs : Pt.attributes) = in loop [] attrs +let decode_args ~map ~tuple_args ~split_tuple = function + | None -> [] + | Some arg -> ( + match tuple_args arg with + | Some args when split_tuple -> List.map map args + | _ -> [map arg]) + let record_rest_of_pattern (rest : Pt.pattern) = match rest.Pt.ppat_desc with | Pt.Ppat_constraint ({ppat_desc = Pt.Ppat_var rest_name; _}, rest_type) -> @@ -862,14 +869,16 @@ module E = struct let lid1 = map_loc sub lid in let has_constructor_args, attrs = remove_constructor_args_attr attrs in let args = - match arg with - | None -> [] - | Some {pexp_desc = Pexp_tuple args} - when has_constructor_args - || Builtin_attributes.explicit_arity attrs - || lid.txt = Longident.Lident "::" -> - List.map (sub.expr sub) args - | Some arg -> [sub.expr sub arg] + decode_args ~map:(sub.expr sub) + ~tuple_args:(fun arg -> + match arg.pexp_desc with + | Pexp_tuple args -> Some args + | _ -> None) + ~split_tuple: + (has_constructor_args + || Builtin_attributes.explicit_arity attrs + || lid.txt = Longident.Lident "::") + arg in let exp1 = construct ~loc ~attrs lid1 args in match lid.txt with @@ -931,11 +940,12 @@ module E = struct | Pexp_variant (lab, arg) -> let has_constructor_args, attrs = remove_constructor_args_attr attrs in let args = - match arg with - | None -> [] - | Some {pexp_desc = Pexp_tuple args} when has_constructor_args -> - List.map (sub.expr sub) args - | Some arg -> [sub.expr sub arg] + decode_args ~map:(sub.expr sub) + ~tuple_args:(fun arg -> + match arg.pexp_desc with + | Pexp_tuple args -> Some args + | _ -> None) + ~split_tuple:has_constructor_args arg in variant ~loc ~attrs lab args | Pexp_record (l, eo) -> @@ -1107,24 +1117,27 @@ module P = struct | Ppat_construct (l, arg) -> let has_constructor_args, attrs = remove_constructor_args_attr attrs in let args = - match arg with - | None -> [] - | Some {ppat_desc = Ppat_tuple args} - when has_constructor_args - || Builtin_attributes.explicit_arity attrs - || l.txt = Longident.Lident "::" -> - List.map (sub.pat sub) args - | Some arg -> [sub.pat sub arg] + decode_args ~map:(sub.pat sub) + ~tuple_args:(fun arg -> + match arg.ppat_desc with + | Ppat_tuple args -> Some args + | _ -> None) + ~split_tuple: + (has_constructor_args + || Builtin_attributes.explicit_arity attrs + || l.txt = Longident.Lident "::") + arg in construct ~loc ~attrs (map_loc sub l) args | Ppat_variant (l, arg) -> let has_constructor_args, attrs = remove_constructor_args_attr attrs in let args = - match arg with - | None -> [] - | Some {ppat_desc = Ppat_tuple args} when has_constructor_args -> - List.map (sub.pat sub) args - | Some arg -> [sub.pat sub arg] + decode_args ~map:(sub.pat sub) + ~tuple_args:(fun arg -> + match arg.ppat_desc with + | Ppat_tuple args -> Some args + | _ -> None) + ~split_tuple:has_constructor_args arg in variant ~loc ~attrs l args | Ppat_record (lpl, cf) -> diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index ffc129f093e..4ea6963fb6c 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -112,6 +112,12 @@ let constructor_args_attr_name = "_res.constructor_args" let add_constructor_args_attr attrs = (Location.mknoloc constructor_args_attr_name, Pt.PStr []) :: attrs +let encode_args ~map ~tuple ~loc ~attrs args = + match List.map map args with + | [] -> (None, attrs) + | [arg] -> (Some arg, attrs) + | args -> (Some (tuple ~loc args), add_constructor_args_attr attrs) + let add_record_rest_attr ~rest attrs = (Location.mknoloc record_rest_attr_name, Pt.PPat (rest, None)) :: attrs @@ -571,25 +577,17 @@ module E = struct | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) | Pexp_construct (lid, args) -> - let args = List.map (sub.expr sub) args in let arg, attrs = - match args with - | [] -> (None, attrs) - | [arg] -> (Some arg, attrs) - | args -> - ( Some (Ast_helper0.Exp.tuple ~loc args), - add_constructor_args_attr attrs ) + encode_args ~map:(sub.expr sub) + ~tuple:(fun ~loc args -> Ast_helper0.Exp.tuple ~loc args) + ~loc ~attrs args in construct ~loc ~attrs (map_loc sub lid) arg | Pexp_variant (lab, args) -> - let args = List.map (sub.expr sub) args in let arg, attrs = - match args with - | [] -> (None, attrs) - | [arg] -> (Some arg, attrs) - | args -> - ( Some (Ast_helper0.Exp.tuple ~loc args), - add_constructor_args_attr attrs ) + encode_args ~map:(sub.expr sub) + ~tuple:(fun ~loc args -> Ast_helper0.Exp.tuple ~loc args) + ~loc ~attrs args in variant ~loc ~attrs lab arg | Pexp_record (l, eo) -> @@ -826,25 +824,17 @@ module P = struct interval ~loc ~attrs (map_constant c1) (map_constant c2) | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) | Ppat_construct (l, args) -> - let args = List.map (sub.pat sub) args in let arg, attrs = - match args with - | [] -> (None, attrs) - | [arg] -> (Some arg, attrs) - | args -> - ( Some (Ast_helper0.Pat.tuple ~loc args), - add_constructor_args_attr attrs ) + encode_args ~map:(sub.pat sub) + ~tuple:(fun ~loc args -> Ast_helper0.Pat.tuple ~loc args) + ~loc ~attrs args in construct ~loc ~attrs (map_loc sub l) arg | Ppat_variant (l, args) -> - let args = List.map (sub.pat sub) args in let arg, attrs = - match args with - | [] -> (None, attrs) - | [arg] -> (Some arg, attrs) - | args -> - ( Some (Ast_helper0.Pat.tuple ~loc args), - add_constructor_args_attr attrs ) + encode_args ~map:(sub.pat sub) + ~tuple:(fun ~loc args -> Ast_helper0.Pat.tuple ~loc args) + ~loc ~attrs args in variant ~loc ~attrs l arg | Ppat_record (lpl, cf, rest) -> From fe2cddeb4829d1446b6a62e0e979f92953fb5821 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:33:01 +0200 Subject: [PATCH 06/40] Localize legacy explicit arity handling Signed-off-by: Christoph Knittel --- compiler/ml/ast_mapper_from0.ml | 11 +++++++++-- compiler/ml/builtin_attributes.ml | 5 ----- compiler/ml/builtin_attributes.mli | 2 -- 3 files changed, 9 insertions(+), 9 deletions(-) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 3e27e0e0ada..3c03af87dbf 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -166,6 +166,13 @@ let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} let record_rest_attr_name = "_res.record_rest" let constructor_args_attr_name = "_res.constructor_args" +let has_explicit_arity_attr (attrs : Pt.attributes) = + List.exists + (function + | {txt = "ocaml.explicit_arity" | "explicit_arity"}, _ -> true + | _ -> false) + attrs + let remove_constructor_args_attr (attrs : Pt.attributes) = let rec loop rev_attrs = function | ({Location.txt; _}, Pt.PStr []) :: attrs @@ -876,7 +883,7 @@ module E = struct | _ -> None) ~split_tuple: (has_constructor_args - || Builtin_attributes.explicit_arity attrs + || has_explicit_arity_attr attrs || lid.txt = Longident.Lident "::") arg in @@ -1124,7 +1131,7 @@ module P = struct | _ -> None) ~split_tuple: (has_constructor_args - || Builtin_attributes.explicit_arity attrs + || has_explicit_arity_attr attrs || l.txt = Longident.Lident "::") arg in diff --git a/compiler/ml/builtin_attributes.ml b/compiler/ml/builtin_attributes.ml index dd0a0d5e56b..dfc1922feb2 100644 --- a/compiler/ml/builtin_attributes.ml +++ b/compiler/ml/builtin_attributes.ml @@ -203,11 +203,6 @@ let warn_on_literal_pattern = true | _ -> false) -let explicit_arity = - List.exists (function - | {txt = "ocaml.explicit_arity" | "explicit_arity"; _}, _ -> true - | _ -> false) - let immediate = List.exists (function | {txt = "ocaml.immediate" | "immediate"; _}, _ -> true diff --git a/compiler/ml/builtin_attributes.mli b/compiler/ml/builtin_attributes.mli index b60a13ceb3f..24b3fd2d436 100644 --- a/compiler/ml/builtin_attributes.mli +++ b/compiler/ml/builtin_attributes.mli @@ -20,7 +20,6 @@ ocaml.ppwarning ocaml.warning ocaml.warnerror - ocaml.explicit_arity (for camlp4/camlp5) ocaml.warn_on_literal_pattern ocaml.deprecated_mutable ocaml.immediate @@ -80,7 +79,6 @@ val warning_scope : *) val warn_on_literal_pattern : Parsetree.attributes -> bool -val explicit_arity : Parsetree.attributes -> bool val immediate : Parsetree.attributes -> bool From 3469bc8b6e58044211934e308d5660c6b448fa37 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:33:33 +0200 Subject: [PATCH 07/40] Use plural names for constructor source arguments Signed-off-by: Christoph Knittel --- compiler/ml/typecore.ml | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 452ece7d593..3072a267067 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1390,7 +1390,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp pat_attributes = sp.ppat_attributes; pat_env = !env; }) - | Ppat_construct (lid, sarg) -> + | Ppat_construct (lid, sargs) -> let opath = try let p0, p, _ = extract_concrete_variant !env expected_ty in @@ -1425,7 +1425,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp correct head *) if constr.cstr_generalized then unify_head_only loc !env expected_ty constr; let sargs = - match sarg with + match sargs with | [({ppat_desc = Ppat_any} as sp)] when constr.cstr_arity <> 1 -> if constr.cstr_arity = 0 then Location.prerr_warning sp.ppat_loc @@ -2741,8 +2741,8 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp exp_attributes = sexp.pexp_attributes; exp_env = env; } - | Pexp_construct (lid, sarg) -> - type_construct ~context env loc lid sarg ty_expected sexp.pexp_attributes + | Pexp_construct (lid, sargs) -> + type_construct ~context env loc lid sargs ty_expected sexp.pexp_attributes | Pexp_variant (l, sargs) -> ( check_polyvar_name env loc l; let sarg = From f44271038318e57a88c83c1a94cf2cb520355a50 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:41:05 +0200 Subject: [PATCH 08/40] Add constructor arity changelog entry Signed-off-by: Christoph Knittel --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 5f4034ef92b..76adb2df8cc 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -14,6 +14,7 @@ #### :boom: Breaking Change +- Distinguish multiple constructor arguments from a tuple passed as a single argument. Constructors with one tuple payload must now use nested parentheses, for example `Some((x, y))`; `Some(x, y)` now reports an arity mismatch. This makes constructor arity explicit in the parsetree and removes the separate parser modes for printing and type checking. https://github.com/rescript-lang/rescript/pull/8610 - Reject malformed UTF-8 in documentation comments and invalid string or template literal escapes that were previously accepted, including empty or out-of-range braced Unicode escapes (`\u{}`, `\u{110000}`) and legacy decimal or octal escapes in templates (`\1`, `\01`, `\8`). These inputs now produce syntax diagnostics instead of compiling to invalid or inconsistent JavaScript. https://github.com/rescript-lang/rescript/pull/8606 - Reject tagged template literals in patterns. Patterns cannot invoke their tag; previously their raw payload was compiled as a plain string comparison. https://github.com/rescript-lang/rescript/pull/8606 - Remove runtime APIs that were deprecated for removal in ReScript 13, including the `Char` module, unsafe `Obj` operations, legacy `Pervasives` helpers, and `Array.unsafe_get`. https://github.com/rescript-lang/rescript/pull/8564 From ef87eba38c4d5360962863b6f9954ec86027f491 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:51:28 +0200 Subject: [PATCH 09/40] Preserve fresh AST0 constructor arity Signed-off-by: Christoph Knittel --- compiler/ml/ast_mapper_from0.ml | 65 ++++++++++++++++---- compiler/ml/ast_mapper_to0.ml | 23 ++++++- compiler/ml/typecore.ml | 29 +++++++++ tests/ounit_tests/ounit_ast_mapper0_tests.ml | 65 +++++++++++++++++++- 4 files changed, 168 insertions(+), 14 deletions(-) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 3c03af87dbf..b8af459e1cd 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -165,6 +165,8 @@ let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} (* Internal Parsetree0 bridge metadata; public res.* attributes pass through. *) let record_rest_attr_name = "_res.record_rest" let constructor_args_attr_name = "_res.constructor_args" +let constructor_tuple_arg_attr_name = "_res.constructor_tuple_arg" +let legacy_constructor_payload_attr_name = "_res.legacy_constructor_payload" let has_explicit_arity_attr (attrs : Pt.attributes) = List.exists @@ -183,12 +185,27 @@ let remove_constructor_args_attr (attrs : Pt.attributes) = in loop [] attrs -let decode_args ~map ~tuple_args ~split_tuple = function - | None -> [] +let remove_constructor_tuple_arg_attr (attrs : Pt.attributes) = + let rec loop rev_attrs = function + | ({Location.txt; _}, Pt.PStr []) :: attrs + when txt = constructor_tuple_arg_attr_name -> + (true, List.rev_append rev_attrs attrs) + | attr :: attrs -> loop (attr :: rev_attrs) attrs + | [] -> (false, List.rev rev_attrs) + in + loop [] attrs + +let add_legacy_constructor_payload_attr attrs = + (Location.mknoloc legacy_constructor_payload_attr_name, Pt.PStr []) :: attrs + +let decode_args ~map ~tuple_args ~split_tuple ~known_tuple_arg = function + | None -> ([], false) | Some arg -> ( match tuple_args arg with - | Some args when split_tuple -> List.map map args - | _ -> [map arg]) + | Some args when split_tuple -> (List.map map args, false) + | Some _ when known_tuple_arg -> ([map arg], false) + | Some _ -> ([map arg], true) + | None -> ([map arg], false)) let record_rest_of_pattern (rest : Pt.pattern) = match rest.Pt.ppat_desc with @@ -875,7 +892,10 @@ module E = struct | Pexp_construct (lid, arg) -> ( let lid1 = map_loc sub lid in let has_constructor_args, attrs = remove_constructor_args_attr attrs in - let args = + let has_constructor_tuple_arg, attrs = + remove_constructor_tuple_arg_attr attrs + in + let args, has_legacy_constructor_payload = decode_args ~map:(sub.expr sub) ~tuple_args:(fun arg -> match arg.pexp_desc with @@ -885,7 +905,12 @@ module E = struct (has_constructor_args || has_explicit_arity_attr attrs || lid.txt = Longident.Lident "::") - arg + ~known_tuple_arg:has_constructor_tuple_arg arg + in + let attrs = + if has_legacy_constructor_payload then + add_legacy_constructor_payload_attr attrs + else attrs in let exp1 = construct ~loc ~attrs lid1 args in match lid.txt with @@ -946,13 +971,17 @@ module E = struct | _ -> exp1) | Pexp_variant (lab, arg) -> let has_constructor_args, attrs = remove_constructor_args_attr attrs in - let args = + let has_constructor_tuple_arg, attrs = + remove_constructor_tuple_arg_attr attrs + in + let args, _ = decode_args ~map:(sub.expr sub) ~tuple_args:(fun arg -> match arg.pexp_desc with | Pexp_tuple args -> Some args | _ -> None) - ~split_tuple:has_constructor_args arg + ~split_tuple:has_constructor_args + ~known_tuple_arg:has_constructor_tuple_arg arg in variant ~loc ~attrs lab args | Pexp_record (l, eo) -> @@ -1123,7 +1152,10 @@ module P = struct | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) | Ppat_construct (l, arg) -> let has_constructor_args, attrs = remove_constructor_args_attr attrs in - let args = + let has_constructor_tuple_arg, attrs = + remove_constructor_tuple_arg_attr attrs + in + let args, has_legacy_constructor_payload = decode_args ~map:(sub.pat sub) ~tuple_args:(fun arg -> match arg.ppat_desc with @@ -1133,18 +1165,27 @@ module P = struct (has_constructor_args || has_explicit_arity_attr attrs || l.txt = Longident.Lident "::") - arg + ~known_tuple_arg:has_constructor_tuple_arg arg + in + let attrs = + if has_legacy_constructor_payload then + add_legacy_constructor_payload_attr attrs + else attrs in construct ~loc ~attrs (map_loc sub l) args | Ppat_variant (l, arg) -> let has_constructor_args, attrs = remove_constructor_args_attr attrs in - let args = + let has_constructor_tuple_arg, attrs = + remove_constructor_tuple_arg_attr attrs + in + let args, _ = decode_args ~map:(sub.pat sub) ~tuple_args:(fun arg -> match arg.ppat_desc with | Ppat_tuple args -> Some args | _ -> None) - ~split_tuple:has_constructor_args arg + ~split_tuple:has_constructor_args + ~known_tuple_arg:has_constructor_tuple_arg arg in variant ~loc ~attrs l args | Ppat_record (lpl, cf) -> diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 4ea6963fb6c..ab50f755df2 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -108,13 +108,18 @@ let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} (* Internal Parsetree0 bridge metadata; public res.* attributes pass through. *) let record_rest_attr_name = "_res.record_rest" let constructor_args_attr_name = "_res.constructor_args" +let constructor_tuple_arg_attr_name = "_res.constructor_tuple_arg" let add_constructor_args_attr attrs = (Location.mknoloc constructor_args_attr_name, Pt.PStr []) :: attrs -let encode_args ~map ~tuple ~loc ~attrs args = +let add_constructor_tuple_arg_attr attrs = + (Location.mknoloc constructor_tuple_arg_attr_name, Pt.PStr []) :: attrs + +let encode_args ~map ~is_tuple ~tuple ~loc ~attrs args = match List.map map args with | [] -> (None, attrs) + | [arg] when is_tuple arg -> (Some arg, add_constructor_tuple_arg_attr attrs) | [arg] -> (Some arg, attrs) | args -> (Some (tuple ~loc args), add_constructor_args_attr attrs) @@ -579,6 +584,10 @@ module E = struct | Pexp_construct (lid, args) -> let arg, attrs = encode_args ~map:(sub.expr sub) + ~is_tuple:(fun arg -> + match arg.pexp_desc with + | Pexp_tuple _ -> true + | _ -> false) ~tuple:(fun ~loc args -> Ast_helper0.Exp.tuple ~loc args) ~loc ~attrs args in @@ -586,6 +595,10 @@ module E = struct | Pexp_variant (lab, args) -> let arg, attrs = encode_args ~map:(sub.expr sub) + ~is_tuple:(fun arg -> + match arg.pexp_desc with + | Pexp_tuple _ -> true + | _ -> false) ~tuple:(fun ~loc args -> Ast_helper0.Exp.tuple ~loc args) ~loc ~attrs args in @@ -826,6 +839,10 @@ module P = struct | Ppat_construct (l, args) -> let arg, attrs = encode_args ~map:(sub.pat sub) + ~is_tuple:(fun arg -> + match arg.ppat_desc with + | Ppat_tuple _ -> true + | _ -> false) ~tuple:(fun ~loc args -> Ast_helper0.Pat.tuple ~loc args) ~loc ~attrs args in @@ -833,6 +850,10 @@ module P = struct | Ppat_variant (l, args) -> let arg, attrs = encode_args ~map:(sub.pat sub) + ~is_tuple:(fun arg -> + match arg.ppat_desc with + | Ppat_tuple _ -> true + | _ -> false) ~tuple:(fun ~loc args -> Ast_helper0.Pat.tuple ~loc args) ~loc ~attrs args in diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 3072a267067..a2d47961400 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1218,6 +1218,18 @@ exception Need_backtrack Unification may update the typing environment. *) (* constrs <> None => called from parmatch: backtrack on or-patterns explode > 0 => explode Ppat_any for gadts *) +let legacy_constructor_payload_attr_name = "_res.legacy_constructor_payload" + +let remove_legacy_constructor_payload_attr attrs = + let rec loop rev_attrs = function + | ({Location.txt; _}, PStr []) :: attrs + when txt = legacy_constructor_payload_attr_name -> + (true, List.rev_append rev_attrs attrs) + | attr :: attrs -> loop (attr :: rev_attrs) attrs + | [] -> (false, List.rev rev_attrs) + in + loop [] attrs + let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env sp expected_ty k = Builtin_attributes.warning_scope sp.ppat_attributes (fun () -> @@ -1391,6 +1403,10 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp pat_env = !env; }) | Ppat_construct (lid, sargs) -> + let has_legacy_constructor_payload, ppat_attributes = + remove_legacy_constructor_payload_attr sp.ppat_attributes + in + let sp = {sp with ppat_attributes} in let opath = try let p0, p, _ = extract_concrete_variant !env expected_ty in @@ -1426,6 +1442,9 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp if constr.cstr_generalized then unify_head_only loc !env expected_ty constr; let sargs = match sargs with + | [{ppat_desc = Ppat_tuple sargs}] + when has_legacy_constructor_payload && constr.cstr_arity > 1 -> + sargs | [({ppat_desc = Ppat_any} as sp)] when constr.cstr_arity <> 1 -> if constr.cstr_arity = 0 then Location.prerr_warning sp.ppat_loc @@ -4411,6 +4430,9 @@ and type_application ~context total_app env funct (sargs : sargs) : Apply_non_function (expand_head env funct.exp_type) ))) and type_construct ~context env loc lid sargs ty_expected attrs = + let has_legacy_constructor_payload, attrs = + remove_legacy_constructor_payload_attr attrs + in let opath = try let p0, p, _ = extract_concrete_variant env ty_expected in @@ -4426,6 +4448,13 @@ and type_construct ~context env loc lid sargs ty_expected attrs = Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr; Builtin_attributes.check_deprecated loc constr.cstr_attributes constr.cstr_name; + let sargs = + match sargs with + | [{pexp_desc = Pexp_tuple sargs}] + when has_legacy_constructor_payload && constr.cstr_arity > 1 -> + sargs + | sargs -> sargs + in if List.length sargs <> constr.cstr_arity then raise (Error diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index 8dc613c6a40..a2130b5ab29 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -323,7 +323,12 @@ let test_constructor_args_roundtrip_through_ast0 _ = let expr0 = map_expr_to0 expr in OUnit.assert_bool "a single tuple argument does not carry bridge metadata" (not (has_attr "_res.constructor_args" expr0.pexp_attributes)); - (match (map_expr0 expr0).pexp_desc with + OUnit.assert_bool "a single tuple argument records its v0 shape" + (has_attr "_res.constructor_tuple_arg" expr0.pexp_attributes); + let expr = map_expr0 expr0 in + OUnit.assert_bool "a known tuple argument is not marked as legacy" + (not (has_attr "_res.legacy_constructor_payload" expr.pexp_attributes)); + (match expr.pexp_desc with | Parsetree.Pexp_construct (_, [{pexp_desc = Pexp_tuple [_; _]}]) -> () | _ -> assert_failure "Expected one tuple argument after roundtrip"); let pat = Ast_helper.Pat.construct ~loc lid [int_pat "1"; int_pat "2"] in @@ -351,6 +356,62 @@ let test_ast0_explicit_arity_becomes_constructor_args _ = | Parsetree.Pexp_construct (_, [_; _]) -> () | _ -> assert_failure "Expected explicit-arity v0 payload to become arguments" +let test_fresh_ast0_constructor_tuple_defers_arity_to_typechecker _ = + let int_expr value = + Ast_helper0.Exp.constant ~loc (Parsetree0.Pconst_integer (value, None)) + in + let int_pat value = + Ast_helper0.Pat.constant ~loc (Parsetree0.Pconst_integer (value, None)) + in + let lid = Location.mknoloc (Longident.Lident "FreshPairForAst0") in + let expr = + map_expr0 + (Ast_helper0.Exp.construct ~loc lid + (Some (Ast_helper0.Exp.tuple ~loc [int_expr "1"; int_expr "2"]))) + in + let pat = + map_pat0 + (Ast_helper0.Pat.construct ~loc lid + (Some (Ast_helper0.Pat.tuple ~loc [int_pat "1"; int_pat "2"]))) + in + OUnit.assert_bool "fresh v0 expression carries deferred-arity metadata" + (has_attr "_res.legacy_constructor_payload" expr.pexp_attributes); + OUnit.assert_bool "fresh v0 pattern carries deferred-arity metadata" + (has_attr "_res.legacy_constructor_payload" pat.ppat_attributes); + let parsed = + Res_driver.parse_implementation_from_source + ~display_filename:"Ast0ConstructorArgsTest.res" + ~source: + "type freshPairForAst0 = FreshPairForAst0(int, int)\n\ + let value = FreshPairForAst0(1, 2)\n\ + let FreshPairForAst0(a, b) = value" + in + let structure = + match parsed.parsetree with + | [type_item; value_item; pattern_item] -> + let value_item = + match value_item.pstr_desc with + | Pstr_value (rec_flag, [binding]) -> + { + value_item with + pstr_desc = Pstr_value (rec_flag, [{binding with pvb_expr = expr}]); + } + | _ -> assert_failure "Expected value binding" + in + let pattern_item = + match pattern_item.pstr_desc with + | Pstr_value (rec_flag, [binding]) -> + { + pattern_item with + pstr_desc = Pstr_value (rec_flag, [{binding with pvb_pat = pat}]); + } + | _ -> assert_failure "Expected pattern binding" + in + [type_item; value_item; pattern_item] + | _ -> assert_failure "Expected type declaration and two value bindings" + in + ignore (Typemod.type_structure Env.initial_safe_string structure loc) + let test_polyvariant_args_roundtrip_through_ast0 _ = let int_expr value = Ast_helper.Exp.constant ~loc (Parsetree.Pconst_integer (value, None)) @@ -929,6 +990,8 @@ let suites = >:: test_constructor_args_roundtrip_through_ast0; "ast0_explicit_arity_becomes_constructor_args" >:: test_ast0_explicit_arity_becomes_constructor_args; + "fresh_ast0_constructor_tuple_defers_arity_to_typechecker" + >:: test_fresh_ast0_constructor_tuple_defers_arity_to_typechecker; "polyvariant_args_roundtrip_through_ast0" >:: test_polyvariant_args_roundtrip_through_ast0; "value_constraint_roundtrips_through_ast0" From 62d26cce9c0173170f1aa7f502fbb332dd969bb4 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:52:23 +0200 Subject: [PATCH 10/40] Partition polymorphic variant argument comments Signed-off-by: Christoph Knittel --- compiler/syntax/src/res_comments_table.ml | 4 ++-- .../data/printer/comments/expected/polyVariant.res.txt | 6 ++++++ tests/syntax_tests/data/printer/comments/polyVariant.res | 6 ++++++ 3 files changed, 14 insertions(+), 2 deletions(-) create mode 100644 tests/syntax_tests/data/printer/comments/expected/polyVariant.res.txt create mode 100644 tests/syntax_tests/data/printer/comments/polyVariant.res diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index 403c856ce2a..a43c76ef8f4 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -1167,7 +1167,7 @@ and walk_expression expr t comments = walk_list (List.map (fun expr -> Expression expr) exprs) t rest | [] -> attach t.trailing longident.loc trailing) | Pexp_variant (_label, args) -> - List.iter (fun e -> walk_expression e t comments) args + walk_list (List.map (fun expr -> Expression expr) args) t comments | Pexp_array exprs | Pexp_tuple exprs -> walk_list (exprs |> List.map (fun e -> Expression e)) t comments | Pexp_record (rows, spread_expr) -> @@ -2079,7 +2079,7 @@ and walk_pattern pat t comments = attach t.trailing constr.loc after_constructor; walk_list (List.map (fun pat -> Pattern pat) pats) t rest | Ppat_variant (_label, args) -> - List.iter (fun p -> walk_pattern p t comments) args + walk_list (List.map (fun pat -> Pattern pat) args) t comments | Ppat_type _ -> () | Ppat_record (record_rows, _, rest) -> let nodes = diff --git a/tests/syntax_tests/data/printer/comments/expected/polyVariant.res.txt b/tests/syntax_tests/data/printer/comments/expected/polyVariant.res.txt new file mode 100644 index 00000000000..9942e00123c --- /dev/null +++ b/tests/syntax_tests/data/printer/comments/expected/polyVariant.res.txt @@ -0,0 +1,6 @@ +let value = #Pair(a, /* between */ b) + +let read = value => + switch value { + | #Pair(a, /* between pattern */ b) => (a, b) + } diff --git a/tests/syntax_tests/data/printer/comments/polyVariant.res b/tests/syntax_tests/data/printer/comments/polyVariant.res new file mode 100644 index 00000000000..9942e00123c --- /dev/null +++ b/tests/syntax_tests/data/printer/comments/polyVariant.res @@ -0,0 +1,6 @@ +let value = #Pair(a, /* between */ b) + +let read = value => + switch value { + | #Pair(a, /* between pattern */ b) => (a, b) + } From a9d34a7848f006275080134beb587463f9e155a0 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 20:41:06 +0200 Subject: [PATCH 11/40] Fix AST0 constructor payload locations and printing Signed-off-by: Christoph Knittel --- compiler/ml/ast_mapper_to0.ml | 17 +++- compiler/syntax/src/res_parsetree_viewer.ml | 3 +- compiler/syntax/src/res_printer.ml | 28 ++++++ tests/ounit_tests/ounit_ast_mapper0_tests.ml | 93 ++++++++++++++++++++ 4 files changed, 136 insertions(+), 5 deletions(-) diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index ab50f755df2..e2e4613941e 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -582,6 +582,11 @@ module E = struct | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) | Pexp_construct (lid, args) -> + let lid = map_loc sub lid in + let args_loc = + if lid.loc.loc_ghost then loc + else {loc with loc_start = lid.loc.loc_end} + in let arg, attrs = encode_args ~map:(sub.expr sub) ~is_tuple:(fun arg -> @@ -589,9 +594,9 @@ module E = struct | Pexp_tuple _ -> true | _ -> false) ~tuple:(fun ~loc args -> Ast_helper0.Exp.tuple ~loc args) - ~loc ~attrs args + ~loc:args_loc ~attrs args in - construct ~loc ~attrs (map_loc sub lid) arg + construct ~loc ~attrs lid arg | Pexp_variant (lab, args) -> let arg, attrs = encode_args ~map:(sub.expr sub) @@ -837,6 +842,10 @@ module P = struct interval ~loc ~attrs (map_constant c1) (map_constant c2) | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) | Ppat_construct (l, args) -> + let l = map_loc sub l in + let args_loc = + if l.loc.loc_ghost then loc else {loc with loc_start = l.loc.loc_end} + in let arg, attrs = encode_args ~map:(sub.pat sub) ~is_tuple:(fun arg -> @@ -844,9 +853,9 @@ module P = struct | Ppat_tuple _ -> true | _ -> false) ~tuple:(fun ~loc args -> Ast_helper0.Pat.tuple ~loc args) - ~loc ~attrs args + ~loc:args_loc ~attrs args in - construct ~loc ~attrs (map_loc sub l) arg + construct ~loc ~attrs l arg | Ppat_variant (l, args) -> let arg, attrs = encode_args ~map:(sub.pat sub) diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index 693dcac9265..22632d44744 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -227,7 +227,8 @@ let filter_parsing_attrs attrs = Location.txt = ( "res.braces" | "ns.braces" | "res.iflet" | "res.ternary" | "res.await" | "res.patVariantSpread" | "res.dictPattern" - | "res.dictSpread" | "res.inlineRecordDefinition" ); + | "res.dictSpread" | "res.inlineRecordDefinition" + | "_res.legacy_constructor_payload" ); }, _ ) -> false diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 40c6f5b196b..0f5a39cc2e3 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -2622,6 +2622,16 @@ and print_extension ~state ~at_module_lvl (string_loc, payload) cmt_tbl = in Doc.group (Doc.concat [ext_name; print_payload ~state payload cmt_tbl]) +and remove_legacy_constructor_payload_attr attrs = + let rec loop rev_attrs = function + | ({Location.txt = "_res.legacy_constructor_payload"}, Parsetree.PStr []) + :: attrs -> + (true, List.rev_append rev_attrs attrs) + | attr :: attrs -> loop (attr :: rev_attrs) attrs + | [] -> (false, List.rev rev_attrs) + in + loop [] attrs + and print_pattern_args ~state (patterns : Parsetree.pattern list) cmt_tbl = match patterns with | [] -> Doc.nil @@ -2666,6 +2676,15 @@ and print_pattern_args ~state (patterns : Parsetree.pattern list) cmt_tbl = ] and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = + let has_legacy_constructor_payload, ppat_attributes = + remove_legacy_constructor_payload_attr p.ppat_attributes + in + let p = + match (has_legacy_constructor_payload, p.ppat_desc) with + | true, Ppat_construct (constr, [{ppat_desc = Ppat_tuple args}]) -> + {p with ppat_desc = Ppat_construct (constr, args); ppat_attributes} + | _ -> {p with ppat_attributes} + in let pattern_without_attributes = match p.ppat_desc with | Ppat_any -> Doc.text "_" @@ -3182,6 +3201,15 @@ and print_object_get_doc ~state parent_expr (label : string Location.loc) Doc.group (Doc.concat [parent_doc; Doc.lbracket; member; Doc.rbracket]) and print_expression ~state (e : Parsetree.expression) cmt_tbl = + let has_legacy_constructor_payload, pexp_attributes = + remove_legacy_constructor_payload_attr e.pexp_attributes + in + let e = + match (has_legacy_constructor_payload, e.pexp_desc) with + | true, Pexp_construct (constr, [{pexp_desc = Pexp_tuple args}]) -> + {e with pexp_desc = Pexp_construct (constr, args); pexp_attributes} + | _ -> {e with pexp_attributes} + in let printed_expression = match e.pexp_desc with | Pexp_fun diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index a2130b5ab29..9c1e93008c0 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -342,6 +342,95 @@ let test_constructor_args_roundtrip_through_ast0 _ = | Parsetree.Ppat_construct (_, [_; _]) -> () | _ -> assert_failure "Expected two pattern arguments after roundtrip" +let test_constructor_args_keep_parentheses_location_in_ast0 _ = + let source = "let Pair(a, b) = Pair(1, 2)" in + let parsed = + Res_driver.parse_implementation_from_source + ~display_filename:"ConstructorArgsLocation.res" ~source + in + let pat, expr = + match parsed.parsetree with + | [{pstr_desc = Pstr_value (_, [{pvb_pat; pvb_expr}])}] -> + (pvb_pat, pvb_expr) + | _ -> assert_failure "Expected one constructor value binding" + in + let assert_payload_loc ~expected_start ~expected_end + {Location.loc_start; loc_end} = + OUnit.assert_equal expected_start loc_start.pos_cnum; + OUnit.assert_equal expected_end loc_end.pos_cnum + in + let pattern_lparen = String.index source '(' in + let pattern_rparen = String.index_from source pattern_lparen ')' in + let expression_lparen = String.index_from source (pattern_rparen + 1) '(' in + let expression_rparen = String.index_from source expression_lparen ')' in + (match (map_pat_to0 pat).ppat_desc with + | Ppat_construct (_, Some {ppat_desc = Ppat_tuple _; ppat_loc}) -> + assert_payload_loc ~expected_start:pattern_lparen + ~expected_end:(pattern_rparen + 1) ppat_loc + | _ -> assert_failure "Expected a tuple-encoded constructor pattern"); + match (map_expr_to0 expr).pexp_desc with + | Pexp_construct (_, Some {pexp_desc = Pexp_tuple _; pexp_loc}) -> + assert_payload_loc ~expected_start:expression_lparen + ~expected_end:(expression_rparen + 1) pexp_loc + | _ -> assert_failure "Expected a tuple-encoded constructor expression" + +let test_fresh_ast0_constructor_tuple_reprints_without_internal_metadata _ = + let int_expr value = + Ast_helper0.Exp.constant ~loc (Parsetree0.Pconst_integer (value, None)) + in + let expr = + map_expr0 + (Ast_helper0.Exp.construct ~loc + (Location.mknoloc (Longident.Lident "Pair")) + (Some (Ast_helper0.Exp.tuple ~loc [int_expr "1"; int_expr "2"]))) + in + let pat = + map_pat0 + (Ast_helper0.Pat.construct ~loc + (Location.mknoloc (Longident.Lident "Pair")) + (Some + (Ast_helper0.Pat.tuple ~loc + [ + Ast_helper0.Pat.var ~loc (Location.mknoloc "a"); + Ast_helper0.Pat.var ~loc (Location.mknoloc "b"); + ]))) + in + List.iter + (fun width -> + let printed = + Res_printer.print_implementation + [ + Ast_helper.Str.value ~loc Nonrecursive + [Ast_helper.Vb.mk ~loc pat expr]; + ] + ~comments:[] ~width + in + OUnit.assert_bool "internal deferred-arity metadata is not printed" + (not + (Ext_string.contain_substring printed + "_res.legacy_constructor_payload")); + let parsed = + Res_driver.parse_implementation_from_source + ~display_filename:"FreshAst0Constructor.res" ~source:printed + in + match parsed.parsetree with + | [ + { + pstr_desc = + Pstr_value + ( _, + [ + { + pvb_pat = {ppat_desc = Ppat_construct (_, [_; _])}; + pvb_expr = {pexp_desc = Pexp_construct (_, [_; _])}; + }; + ] ); + }; + ] -> + () + | _ -> assert_failure "Expected two printed constructor arguments") + [10; 80] + let test_ast0_explicit_arity_becomes_constructor_args _ = let arg value = Ast_helper0.Exp.constant ~loc (Parsetree0.Pconst_integer (value, None)) @@ -988,6 +1077,10 @@ let suites = >:: test_record_rest_roundtrips_through_ast0; "constructor_args_roundtrip_through_ast0" >:: test_constructor_args_roundtrip_through_ast0; + "constructor_args_keep_parentheses_location_in_ast0" + >:: test_constructor_args_keep_parentheses_location_in_ast0; + "fresh_ast0_constructor_tuple_reprints_without_internal_metadata" + >:: test_fresh_ast0_constructor_tuple_reprints_without_internal_metadata; "ast0_explicit_arity_becomes_constructor_args" >:: test_ast0_explicit_arity_becomes_constructor_args; "fresh_ast0_constructor_tuple_defers_arity_to_typechecker" From fc1288577f52e57aa001fc9e8eabe366a6596ed2 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 21:15:28 +0200 Subject: [PATCH 12/40] Bump compiled artifact versions for constructor AST changes Signed-off-by: Christoph Knittel --- compiler/ext/config.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/compiler/ext/config.ml b/compiler/ext/config.ml index ab2051670b1..6225cf4bfdd 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -1,4 +1,4 @@ -let cmi_magic_number = "Caml1999I032" +let cmi_magic_number = "Caml1999I033" (* Magic numbers for marshaled values of the *current* parsetree, whose layout changes across compiler versions. *) @@ -13,6 +13,6 @@ and ast0_impl_magic_number = "Caml1999M022" and ast0_intf_magic_number = "Caml1999N022" -and cmt_magic_number = "Caml1999T034" +and cmt_magic_number = "Caml1999T035" let load_path = ref ([] : string list) From 2af82aa0a700c3ca6465b400b5e654fd5421edfa Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 21:32:25 +0200 Subject: [PATCH 13/40] Deduplicate AST0 bridge marker removal Signed-off-by: Christoph Knittel --- compiler/ml/ast_mapper_from0.ml | 19 +++++++------------ 1 file changed, 7 insertions(+), 12 deletions(-) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index b8af459e1cd..4bc5009d5d6 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -175,25 +175,20 @@ let has_explicit_arity_attr (attrs : Pt.attributes) = | _ -> false) attrs -let remove_constructor_args_attr (attrs : Pt.attributes) = +let remove_internal_marker_attr ~name (attrs : Pt.attributes) = let rec loop rev_attrs = function - | ({Location.txt; _}, Pt.PStr []) :: attrs - when txt = constructor_args_attr_name -> + | ({Location.txt}, Pt.PStr []) :: attrs when txt = name -> (true, List.rev_append rev_attrs attrs) | attr :: attrs -> loop (attr :: rev_attrs) attrs | [] -> (false, List.rev rev_attrs) in loop [] attrs -let remove_constructor_tuple_arg_attr (attrs : Pt.attributes) = - let rec loop rev_attrs = function - | ({Location.txt; _}, Pt.PStr []) :: attrs - when txt = constructor_tuple_arg_attr_name -> - (true, List.rev_append rev_attrs attrs) - | attr :: attrs -> loop (attr :: rev_attrs) attrs - | [] -> (false, List.rev rev_attrs) - in - loop [] attrs +let remove_constructor_args_attr attrs = + remove_internal_marker_attr ~name:constructor_args_attr_name attrs + +let remove_constructor_tuple_arg_attr attrs = + remove_internal_marker_attr ~name:constructor_tuple_arg_attr_name attrs let add_legacy_constructor_payload_attr attrs = (Location.mknoloc legacy_constructor_payload_attr_name, Pt.PStr []) :: attrs From fbfe9ab89e20ae5bc9e98ea6b5d5a32d31a6411f Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 09:34:18 +0200 Subject: [PATCH 14/40] Preserve polymorphic variant payload spans across AST0 Signed-off-by: Christoph Knittel --- compiler/ml/ast_mapper_from0.ml | 16 +++++++ compiler/ml/ast_mapper_to0.ml | 17 ++++++- compiler/syntax/src/res_core.ml | 21 ++++++++- compiler/syntax/src/res_parsetree_viewer.ml | 7 +-- tests/ounit_tests/ounit_ast_mapper0_tests.ml | 46 +++++++++++++++++++ .../PolyVariantPayloadLocation.res | 5 ++ .../PolyVariantPayloadLocation.res.txt | 6 +++ .../expressions/expected/arrow.res.txt | 7 +-- .../expressions/expected/binary.res.txt | 5 +- .../expressions/expected/polyvariant.res.txt | 4 +- .../grammar/pattern/expected/constant.res.txt | 5 +- .../pattern/expected/polyvariants.res.txt | 45 ++++++++++-------- .../grammar/pattern/expected/variants.res.txt | 43 +++++++++-------- .../pattern/expected/polyvariant.res.txt | 6 +-- 14 files changed, 178 insertions(+), 55 deletions(-) create mode 100644 tests/syntax_tests/data/ast-mapping/PolyVariantPayloadLocation.res create mode 100644 tests/syntax_tests/data/ast-mapping/expected/PolyVariantPayloadLocation.res.txt diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 4bc5009d5d6..d8e60370f78 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -966,6 +966,14 @@ module E = struct | _ -> exp1) | Pexp_variant (lab, arg) -> let has_constructor_args, attrs = remove_constructor_args_attr attrs in + let attrs = + match arg with + | Some {pexp_desc = Pexp_tuple _; pexp_loc} when has_constructor_args -> + ( Location.mkloc "res.variantArgs" (sub.location sub pexp_loc), + Pt.PStr [] ) + :: attrs + | _ -> attrs + in let has_constructor_tuple_arg, attrs = remove_constructor_tuple_arg_attr attrs in @@ -1170,6 +1178,14 @@ module P = struct construct ~loc ~attrs (map_loc sub l) args | Ppat_variant (l, arg) -> let has_constructor_args, attrs = remove_constructor_args_attr attrs in + let attrs = + match arg with + | Some {ppat_desc = Ppat_tuple _; ppat_loc} when has_constructor_args -> + ( Location.mkloc "res.variantArgs" (sub.location sub ppat_loc), + Pt.PStr [] ) + :: attrs + | _ -> attrs + in let has_constructor_tuple_arg, attrs = remove_constructor_tuple_arg_attr attrs in diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index e2e4613941e..7f310406d57 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -123,6 +123,17 @@ let encode_args ~map ~is_tuple ~tuple ~loc ~attrs args = | [arg] -> (Some arg, attrs) | args -> (Some (tuple ~loc args), add_constructor_args_attr attrs) +(* The argument list no longer has a tuple node to carry its parentheses span. + Consume the parser's location metadata when rebuilding that v0 node. *) +let variant_args_loc ~loc attrs = + let rec loop rev_attrs = function + | ({Location.txt = "res.variantArgs"; loc}, Pt.PStr []) :: attrs -> + (loc, List.rev_append rev_attrs attrs) + | attr :: attrs -> loop (attr :: rev_attrs) attrs + | [] -> (loc, List.rev rev_attrs) + in + loop [] attrs + let add_record_rest_attr ~rest attrs = (Location.mknoloc record_rest_attr_name, Pt.PPat (rest, None)) :: attrs @@ -598,6 +609,7 @@ module E = struct in construct ~loc ~attrs lid arg | Pexp_variant (lab, args) -> + let args_loc, attrs = variant_args_loc ~loc attrs in let arg, attrs = encode_args ~map:(sub.expr sub) ~is_tuple:(fun arg -> @@ -605,7 +617,7 @@ module E = struct | Pexp_tuple _ -> true | _ -> false) ~tuple:(fun ~loc args -> Ast_helper0.Exp.tuple ~loc args) - ~loc ~attrs args + ~loc:args_loc ~attrs args in variant ~loc ~attrs lab arg | Pexp_record (l, eo) -> @@ -857,6 +869,7 @@ module P = struct in construct ~loc ~attrs l arg | Ppat_variant (l, args) -> + let args_loc, attrs = variant_args_loc ~loc attrs in let arg, attrs = encode_args ~map:(sub.pat sub) ~is_tuple:(fun arg -> @@ -864,7 +877,7 @@ module P = struct | Ppat_tuple _ -> true | _ -> false) ~tuple:(fun ~loc args -> Ast_helper0.Pat.tuple ~loc args) - ~loc ~attrs args + ~loc:args_loc ~attrs args in variant ~loc ~attrs l arg | Ppat_record (lpl, cf, rest) -> diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 661244d956a..cbce6703e0f 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -1763,7 +1763,16 @@ and parse_constructor_pattern_args p constr start_pos attrs = ~attrs constr args and parse_variant_pattern_args p ident start_pos attrs = + let args_start = p.Parser.start_pos in let args = parse_pattern_args p in + let attrs = + match args with + | _ :: _ :: _ -> + ( Location.mkloc "res.variantArgs" (mk_loc args_start p.prev_end_pos), + Parsetree.PStr [] ) + :: attrs + | _ -> attrs + in Ast_helper.Pat.variant ~loc:(mk_loc start_pos p.prev_end_pos) ~attrs ident args @@ -4216,9 +4225,19 @@ and parse_poly_variant_expr p = let ident, _loc = parse_hash_ident ~start_pos p in match p.Parser.token with | Lparen when p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> + let args_start = p.start_pos in let args = parse_constructor_args p in let loc = mk_loc start_pos p.prev_end_pos in - Ast_helper.Exp.variant ~loc ident args + let attrs = + match args with + | _ :: _ :: _ -> + [ + ( Location.mkloc "res.variantArgs" (mk_loc args_start p.prev_end_pos), + Parsetree.PStr [] ); + ] + | _ -> [] + in + Ast_helper.Exp.variant ~loc ~attrs ident args | _ -> let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.variant ~loc ident [] diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index 22632d44744..c78cb740086 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -228,7 +228,7 @@ let filter_parsing_attrs attrs = ( "res.braces" | "ns.braces" | "res.iflet" | "res.ternary" | "res.await" | "res.patVariantSpread" | "res.dictPattern" | "res.dictSpread" | "res.inlineRecordDefinition" - | "_res.legacy_constructor_payload" ); + | "res.variantArgs" | "_res.legacy_constructor_payload" ); }, _ ) -> false @@ -387,7 +387,7 @@ let has_attributes attrs = | ( { Location.txt = ( "res.braces" | "ns.braces" | "res.iflet" | "res.ternary" - | "res.await" | "res.inlineRecordDefinition" ); + | "res.await" | "res.inlineRecordDefinition" | "res.variantArgs" ); }, _ ) -> false @@ -563,7 +563,8 @@ let is_printable_attribute attr = | ( { Location.txt = ( "res.iflet" | "res.braces" | "ns.braces" | "JSX" | "res.await" - | "res.ternary" | "res.inlineRecordDefinition" | "res.dictSpread" ); + | "res.ternary" | "res.inlineRecordDefinition" | "res.dictSpread" + | "res.variantArgs" ); }, _ ) -> false diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index 9c1e93008c0..812d55e239d 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -374,6 +374,50 @@ let test_constructor_args_keep_parentheses_location_in_ast0 _ = ~expected_end:(expression_rparen + 1) pexp_loc | _ -> assert_failure "Expected a tuple-encoded constructor expression" +let test_polyvariant_args_keep_parentheses_location_in_ast0 _ = + List.iter + (fun source -> + let parsed = + Res_driver.parse_implementation_from_source + ~display_filename:"VariantArgsLocation.res" ~source + in + let pat, expr = + match parsed.parsetree with + | [{pstr_desc = Pstr_value (_, [{pvb_pat; pvb_expr}])}] -> + (pvb_pat, pvb_expr) + | _ -> assert_failure "Expected one polymorphic variant binding" + in + let pattern_start = String.index source '(' in + let pattern_end = 1 + String.index_from source pattern_start ')' in + let expression_start = String.index_from source pattern_end '(' in + let expression_end = 1 + String.index_from source expression_start ')' in + let assert_loc start finish {Location.loc_start; loc_end} = + OUnit.assert_equal start loc_start.pos_cnum; + OUnit.assert_equal finish loc_end.pos_cnum + in + let check pat expr = + OUnit.assert_bool "parser location metadata stays out of v0" + ((not (has_attr "res.variantArgs" pat.Parsetree0.ppat_attributes)) + && not (has_attr "res.variantArgs" expr.Parsetree0.pexp_attributes)); + (match pat.ppat_desc with + | Ppat_variant (_, Some {ppat_desc = Ppat_tuple _; ppat_loc}) -> + assert_loc pattern_start pattern_end ppat_loc + | _ -> assert_failure "Expected v0 polymorphic variant pattern tuple"); + match expr.pexp_desc with + | Pexp_variant (_, Some {pexp_desc = Pexp_tuple _; pexp_loc}) -> + assert_loc expression_start expression_end pexp_loc + | _ -> assert_failure "Expected v0 polymorphic variant expression tuple" + in + let pat0 = map_pat_to0 pat in + let expr0 = map_expr_to0 expr in + check pat0 expr0; + check (map_pat_to0 (map_pat0 pat0)) (map_expr_to0 (map_expr0 expr0))) + [ + "let #Pair(a, b) = #Pair(1, 2)"; + "let #Pair /* pattern */ (a, b) = #Pair /* expression */ (1, 2)"; + "let #\"quoted label\"(a,\n b) = #\"quoted label\"(1,\n 2)"; + ] + let test_fresh_ast0_constructor_tuple_reprints_without_internal_metadata _ = let int_expr value = Ast_helper0.Exp.constant ~loc (Parsetree0.Pconst_integer (value, None)) @@ -1087,6 +1131,8 @@ let suites = >:: test_fresh_ast0_constructor_tuple_defers_arity_to_typechecker; "polyvariant_args_roundtrip_through_ast0" >:: test_polyvariant_args_roundtrip_through_ast0; + "polyvariant_args_keep_parentheses_location_in_ast0" + >:: test_polyvariant_args_keep_parentheses_location_in_ast0; "value_constraint_roundtrips_through_ast0" >:: test_value_constraint_roundtrips_through_ast0; "function_cases_desugar_to_fun_match" diff --git a/tests/syntax_tests/data/ast-mapping/PolyVariantPayloadLocation.res b/tests/syntax_tests/data/ast-mapping/PolyVariantPayloadLocation.res new file mode 100644 index 00000000000..e09a35df317 --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/PolyVariantPayloadLocation.res @@ -0,0 +1,5 @@ +let pair = #Pair /* payload */ (1, 2) + +let read = value => switch value { +| #"quoted label" /* payload */ (a, b) => (a, b) +} diff --git a/tests/syntax_tests/data/ast-mapping/expected/PolyVariantPayloadLocation.res.txt b/tests/syntax_tests/data/ast-mapping/expected/PolyVariantPayloadLocation.res.txt new file mode 100644 index 00000000000..a9bd62fbdde --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/expected/PolyVariantPayloadLocation.res.txt @@ -0,0 +1,6 @@ +let pair = #Pair(/* payload */ 1, 2) + +let read = value => + switch value { + | #"quoted label"(/* payload */ a, b) => (a, b) + } diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/arrow.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/arrow.res.txt index dc435527365..bae88bd32b2 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/arrow.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/arrow.res.txt @@ -65,9 +65,10 @@ let x = ((fun [arity:1]_ -> copyChecklistItemCB ()), (fun [arity:1]_ -> copyChecklistItemCB ())) let y = - `Constructore - ((fun [arity:1]_ -> copyChecklistItemCB ()), - (fun [arity:1]_ -> copyChecklistItemCB ())) + ((`Constructore + ((fun [arity:1]_ -> copyChecklistItemCB ()), + (fun [arity:1]_ -> copyChecklistItemCB ()))) + [@res.variantArgs ]) let f [arity:1]list = list + 1 let foo = (() : unit) type nonrec u = unit diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/binary.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/binary.res.txt index eb4809b8cb8..6eed76554cb 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/binary.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/binary.res.txt @@ -23,7 +23,8 @@ let x = (a >>> a) == 0 let x = a - b let x = a -. b ;;Constructor (a, b) -;;`Constructor (a, b) -let _ = ((Constructor (a, b); `Constructor (a, b))[@res.braces ]) +;;((`Constructor (a, b))[@res.variantArgs ]) +let _ = ((Constructor (a, b); ((`Constructor (a, b))[@res.variantArgs ])) + [@res.braces ]) ;;(library.getBalance account) -> (Promise.catch (fun [arity:1]_ -> ((Promise.resolve None)[@res.braces ]))) \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/polyvariant.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/polyvariant.res.txt index 5de14a9eaa7..95ca9d1f7a1 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/polyvariant.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/polyvariant.res.txt @@ -1,9 +1,9 @@ let x = `Red let z = `Rgb () -let v = `Vertex (1., 2., 3., 4.) +let v = ((`Vertex (1., 2., 3., 4.))[@res.variantArgs ]) let animation = `ease-in let one = `1 let fortyTwo = `42 let long = `42444 let oneString = `1 {js|payload|js} -let twoIntString = `2 (3, {js|payload|js}) \ No newline at end of file +let twoIntString = ((`2 (3, {js|payload|js}))[@res.variantArgs ]) \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/pattern/expected/constant.res.txt b/tests/syntax_tests/data/parsing/grammar/pattern/expected/constant.res.txt index ee5896002b0..7ec98156b33 100644 --- a/tests/syntax_tests/data/parsing/grammar/pattern/expected/constant.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/pattern/expected/constant.res.txt @@ -62,7 +62,7 @@ let (-1)..(-1.) = x | 1.12::(-3.13)::[] -> true | { x = 1.12; y = (-3.13) } -> true | Constructor (1.12, (-2.45)) -> true - | `Constuctor (1.12, (-2.45)) -> true + | ((`Constuctor (1.12, (-2.45)))[@res.variantArgs ]) -> true | (-4.15) as x -> true | (-4.15)|4.15 -> true | ((-3.14) : float) -> true @@ -75,7 +75,8 @@ let (-1)..(-1.) = x | {js|literal1|js}::{js|literal2|js}::[] -> true | { x = {js|literal1|js}; y = {js|literal2|js} } -> true | Constructor ({js|literal1|js}, {js|literal2|js}) -> true - | `Constuctor ({js|literal1|js}, {js|literal2|js}) -> true + | ((`Constuctor ({js|literal1|js}, {js|literal2|js}))[@res.variantArgs ]) + -> true | {js|literal|js} as x -> true | {js|literal|js}|{js|literal|js} -> true | ({js|literal|js} : string) -> true diff --git a/tests/syntax_tests/data/parsing/grammar/pattern/expected/polyvariants.res.txt b/tests/syntax_tests/data/parsing/grammar/pattern/expected/polyvariants.res.txt index 9f2268f07f2..13990b7a567 100644 --- a/tests/syntax_tests/data/parsing/grammar/pattern/expected/polyvariants.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/pattern/expected/polyvariants.res.txt @@ -6,15 +6,15 @@ let `Instance component = i let `Instance { render; subtree } = i let `Instance { render; subtree } as x = i let `Instance ({ render; subtree } as inst) = i -let `Instance ({ render; subtree }, inst) = i +let ((`Instance ({ render; subtree }, inst))[@res.variantArgs ]) = i let `Instance ({ render; subtree } : Instance.t) = i let `Instance ({ render; subtree } : Instance.t) as inst = i let `Instance ({ render; subtree } : Instance.t) = i -let `Instance (component, tree) = i -let `Instance (component, tree) as x = i -let `Instance ((component as x), (tree as y)) = i -let `Instance (component, tree) as inst = i -let `Instance (component, tree) = i +let ((`Instance (component, tree))[@res.variantArgs ]) = i +let ((`Instance (component, tree))[@res.variantArgs ]) as x = i +let ((`Instance ((component as x), (tree as y)))[@res.variantArgs ]) = i +let ((`Instance (component, tree))[@res.variantArgs ]) as inst = i +let ((`Instance (component, tree))[@res.variantArgs ]) = i let (`Instance : React.t) = i let (`Instance : React.t) as t = i let (`Instance : React.t) as x = i @@ -26,21 +26,22 @@ let ((`Instance (component : comp)) : React.t) = i | `Instance comp -> () | `Instance comp as inst -> () | `Instance { render; subtree } -> () - | `Instance ({ render; subtree }, inst) -> () + | ((`Instance ({ render; subtree }, inst))[@res.variantArgs ]) -> () | `Instance ({ render; subtree } : Instance.t) -> () | `Instance ({ render; subtree } : Instance.t) -> () - | `Instance (comp, tree) -> () + | ((`Instance (comp, tree))[@res.variantArgs ]) -> () | (`Instance (comp : Component.t) : React.t) -> () let f [arity:1]`Instance = i let f [arity:1](`Instance as i) = i let f [arity:1](`Instance component) = i let f [arity:1](`Instance component) = i let f [arity:1](`Instance { render; subtree }) = i -let f [arity:1](`Instance ({ render; subtree }, inst)) = i +let f [arity:1]((`Instance ({ render; subtree }, inst))[@res.variantArgs ]) = + i let f [arity:1](`Instance ({ render; subtree } : Instance.t)) = i let f [arity:1](`Instance ({ render; subtree } : Instance.t)) = i -let f [arity:1](`Instance (component, tree)) = i -let f [arity:1](`Instance (component, tree)) = i +let f [arity:1]((`Instance (component, tree))[@res.variantArgs ]) = i +let f [arity:1]((`Instance (component, tree))[@res.variantArgs ]) = i let f [arity:1](`Instance : React.t) = i let f [arity:1](`Instance : React.t) = i let f [arity:1](`Instance (comp : Component.t) : React.t) = () @@ -51,13 +52,19 @@ let f [arity:1](`Instance (comp : Component.t) : React.t) = () ;;for (`Blue : Color.t) = x to y do () done ;;for (`Blue : Color.t) as c = x to y do () done ;;for (`Blue : Color.t) as c = x to y do () done -;;for `Rgba (r, g, b) = x to y do () done -;;for `Rgba (r, g, b) as c = x to y do () done +;;for ((`Rgba (r, g, b))[@res.variantArgs ]) = x to y do () done +;;for ((`Rgba (r, g, b))[@res.variantArgs ]) as c = x to y do () done ;;for Rgba ((r : float), (g : float), (b : float)) = x to y do () done -;;for `Rgba ((r : float), (g : float), (b : float)) as c = x to y do () done -;;for (`Rgba (r, g, b) : Rgb.t) = x to y do () done -;;for (`Rgba (r, g, b) : Rgb.t) as c = x to y do () done -;;for (`Rgba (r, g, b) : Rgb.t) as c = x to y do () done +;;for ((`Rgba ((r : float), (g : float), (b : float)))[@res.variantArgs ]) as + c = + x to y do + () + done +;;for (((`Rgba (r, g, b))[@res.variantArgs ]) : Rgb.t) = x to y do () done +;;for (((`Rgba (r, g, b))[@res.variantArgs ]) : Rgb.t) as c = x to y do () + done +;;for (((`Rgba (r, g, b))[@res.variantArgs ]) : Rgb.t) as c = x to y do () + done ;;for `Point { x; y; z } = x to y do () done ;;for `Point { x; y; z } = x to y do () done ;;for `Point { x; y; z } as p = x to y do () done @@ -69,7 +76,7 @@ let cmp [arity:2]selectedChoice value = | #b::#b::[] -> true | { x = #c; y = #c } -> true | Constructor (#a, #a) -> true - | `Constuctor (#a, #a) -> true + | ((`Constuctor (#a, #a))[@res.variantArgs ]) -> true | #a as x -> true | #a|#b -> true | (#a : typ) -> true @@ -78,5 +85,5 @@ let cmp [arity:2]selectedChoice value = ;;match polyVar with | `ease-in -> () | `ease-out⛰ -> () - | `ease+++ (`1Blue, `r+) -> () + | ((`ease+++ (`1Blue, `r+))[@res.variantArgs ]) -> () | _ -> () \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/pattern/expected/variants.res.txt b/tests/syntax_tests/data/parsing/grammar/pattern/expected/variants.res.txt index 3f0c4fe83a6..e71c03416ae 100644 --- a/tests/syntax_tests/data/parsing/grammar/pattern/expected/variants.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/pattern/expected/variants.res.txt @@ -6,15 +6,15 @@ let `Instance component = i let `Instance { render; subtree } = i let `Instance { render; subtree } as x = i let `Instance ({ render; subtree } as inst) = i -let `Instance ({ render; subtree }, inst) = i +let ((`Instance ({ render; subtree }, inst))[@res.variantArgs ]) = i let `Instance ({ render; subtree } : Instance.t) = i let `Instance ({ render; subtree } : Instance.t) as inst = i let `Instance ({ render; subtree } : Instance.t) = i -let `Instance (component, tree) = i -let `Instance (component, tree) as x = i -let `Instance ((component as x), (tree as y)) = i -let `Instance (component, tree) as inst = i -let `Instance (component, tree) = i +let ((`Instance (component, tree))[@res.variantArgs ]) = i +let ((`Instance (component, tree))[@res.variantArgs ]) as x = i +let ((`Instance ((component as x), (tree as y)))[@res.variantArgs ]) = i +let ((`Instance (component, tree))[@res.variantArgs ]) as inst = i +let ((`Instance (component, tree))[@res.variantArgs ]) = i let (`Instance : React.t) = i let (`Instance : React.t) as t = i let (`Instance : React.t) as x = i @@ -26,21 +26,22 @@ let ((`Instance (component : comp)) : React.t) = i | `Instance comp -> () | `Instance comp as inst -> () | `Instance { render; subtree } -> () - | `Instance ({ render; subtree }, inst) -> () + | ((`Instance ({ render; subtree }, inst))[@res.variantArgs ]) -> () | `Instance ({ render; subtree } : Instance.t) -> () | `Instance ({ render; subtree } : Instance.t) -> () - | `Instance (comp, tree) -> () + | ((`Instance (comp, tree))[@res.variantArgs ]) -> () | (`Instance (comp : Component.t) : React.t) -> () let f [arity:1]`Instance = i let f [arity:1](`Instance as i) = i let f [arity:1](`Instance component) = i let f [arity:1](`Instance component) = i let f [arity:1](`Instance { render; subtree }) = i -let f [arity:1](`Instance ({ render; subtree }, inst)) = i +let f [arity:1]((`Instance ({ render; subtree }, inst))[@res.variantArgs ]) = + i let f [arity:1](`Instance ({ render; subtree } : Instance.t)) = i let f [arity:1](`Instance ({ render; subtree } : Instance.t)) = i -let f [arity:1](`Instance (component, tree)) = i -let f [arity:1](`Instance (component, tree)) = i +let f [arity:1]((`Instance (component, tree))[@res.variantArgs ]) = i +let f [arity:1]((`Instance (component, tree))[@res.variantArgs ]) = i let f [arity:1](`Instance : React.t) = i let f [arity:1](`Instance : React.t) = i let f [arity:1](`Instance (comp : Component.t) : React.t) = () @@ -51,13 +52,19 @@ let f [arity:1](`Instance (comp : Component.t) : React.t) = () ;;for (`Blue : Color.t) = x to y do () done ;;for (`Blue : Color.t) as c = x to y do () done ;;for (`Blue : Color.t) as c = x to y do () done -;;for `Rgba (r, g, b) = x to y do () done -;;for `Rgba (r, g, b) as c = x to y do () done +;;for ((`Rgba (r, g, b))[@res.variantArgs ]) = x to y do () done +;;for ((`Rgba (r, g, b))[@res.variantArgs ]) as c = x to y do () done ;;for Rgba ((r : float), (g : float), (b : float)) = x to y do () done -;;for `Rgba ((r : float), (g : float), (b : float)) as c = x to y do () done -;;for (`Rgba (r, g, b) : Rgb.t) = x to y do () done -;;for (`Rgba (r, g, b) : Rgb.t) as c = x to y do () done -;;for (`Rgba (r, g, b) : Rgb.t) as c = x to y do () done +;;for ((`Rgba ((r : float), (g : float), (b : float)))[@res.variantArgs ]) as + c = + x to y do + () + done +;;for (((`Rgba (r, g, b))[@res.variantArgs ]) : Rgb.t) = x to y do () done +;;for (((`Rgba (r, g, b))[@res.variantArgs ]) : Rgb.t) as c = x to y do () + done +;;for (((`Rgba (r, g, b))[@res.variantArgs ]) : Rgb.t) as c = x to y do () + done ;;for `Point { x; y; z } = x to y do () done ;;for `Point { x; y; z } = x to y do () done ;;for `Point { x; y; z } as p = x to y do () done @@ -66,4 +73,4 @@ let f [arity:1](`Instance (comp : Component.t) : React.t) = () | `1 -> () | `42 -> () | `42444 -> () - | `3 (x, y, z) -> Console.log3 x y z \ No newline at end of file + | ((`3 (x, y, z))[@res.variantArgs ]) -> Console.log3 x y z \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/recovery/pattern/expected/polyvariant.res.txt b/tests/syntax_tests/data/parsing/recovery/pattern/expected/polyvariant.res.txt index c35d2a874a3..4ea4a77783e 100644 --- a/tests/syntax_tests/data/parsing/recovery/pattern/expected/polyvariant.res.txt +++ b/tests/syntax_tests/data/parsing/recovery/pattern/expected/polyvariant.res.txt @@ -34,7 +34,7 @@ Did you forget a `}` here? ;;match x with - | `Rgb (r, g, b) -> () - | `Rgb (r, g, Color (a, b)) -> () - | `Rgb (r, g, 1::2::[]) -> () + | ((`Rgb (r, g, b))[@res.variantArgs ]) -> () + | ((`Rgb (r, g, Color (a, b)))[@res.variantArgs ]) -> () + | ((`Rgb (r, g, 1::2::[]))[@res.variantArgs ]) -> () ;;match x with | `a () -> () | `a () -> () \ No newline at end of file From 158bace4c1a8546cb08729da99ba5101f7a5e436 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 09:34:18 +0200 Subject: [PATCH 15/40] Retain constructor signature help between arguments Signed-off-by: Christoph Knittel --- analysis/src/signature_help.ml | 72 +++--- .../src/SignatureHelpConstructorGaps.res | 34 +++ .../SignatureHelpConstructorGaps.res.txt | 237 ++++++++++++++++++ 3 files changed, 302 insertions(+), 41 deletions(-) create mode 100644 tests/analysis_tests/tests/src/SignatureHelpConstructorGaps.res create mode 100644 tests/analysis_tests/tests/src/expected/SignatureHelpConstructorGaps.res.txt diff --git a/analysis/src/signature_help.ml b/analysis/src/signature_help.ml index b7583810f7d..f96c5a7378e 100644 --- a/analysis/src/signature_help.ml +++ b/analysis/src/signature_help.ml @@ -257,6 +257,22 @@ let signature_help ~debug ~source ~kind_file ~pos let loc_has_cursor loc = loc |> Cursor_position.loc_has_cursor ~pos:pos_before_cursor in + let constructor_has_cursor lid_loc loc = + loc_has_cursor loc && pos_before_cursor >= Loc.end_ lid_loc + in + let constructor_arg_index locations = + let rec loop index = function + | [] -> -1 + | [_] -> index + | loc :: (next :: _ as rest) -> + if pos_before_cursor < Loc.end_ loc then index + else if pos_before_cursor < Loc.start next then + if first_char_before_cursor_no_white = Some ',' then index + 1 + else index + else loop (index + 1) rest + in + loop 0 locations + in let supports_markdown_links = true in let result = ref None in let print_thing thg = @@ -401,12 +417,7 @@ let signature_help ~debug ~source ~kind_file ~pos set_result (exp.pexp_loc, `FunctionCall (arg_at_cursor, exp, extracted_args)) | {pexp_desc = Pexp_construct (lid, payload_exps); pexp_loc} - when List.exists - (fun (payload_exp : Parsetree.expression) -> - loc_has_cursor payload_exp.pexp_loc - || Completion_expressions.is_expr_hole payload_exp - && loc_has_cursor pexp_loc) - payload_exps -> + when payload_exps <> [] && constructor_has_cursor lid.loc pexp_loc -> (* Constructor payloads *) set_result (lid.loc, `ConstructorExpr (lid, payload_exps)) | _ -> ()); @@ -414,11 +425,8 @@ let signature_help ~debug ~source ~kind_file ~pos in let pat (iterator : Ast_iterator.iterator) (pat : Parsetree.pattern) = (match pat with - | {ppat_desc = Ppat_construct (lid, payload_pats)} - when List.exists - (fun (payload_pat : Parsetree.pattern) -> - loc_has_cursor payload_pat.ppat_loc) - payload_pats -> + | {ppat_desc = Ppat_construct (lid, payload_pats); ppat_loc} + when payload_pats <> [] && constructor_has_cursor lid.loc ppat_loc -> (* Constructor payloads *) set_result (lid.loc, `ConstructorPat (lid, payload_pats)) | _ -> ()); @@ -626,19 +634,11 @@ let signature_help ~debug ~source ~kind_file ~pos in let active_parameter = match cs with - | `ConstructorExpr (_, items) when List.length items > 1 -> ( - let idx = ref 0 in - let tuple_item_with_cursor = - items - |> List.find_map (fun (item : Parsetree.expression) -> - let current_index = !idx in - idx := current_index + 1; - if loc_has_cursor item.pexp_loc then Some current_index - else None) - in - match tuple_item_with_cursor with - | None -> -1 - | Some i -> i) + | `ConstructorExpr (_, items) when List.length items > 1 -> + constructor_arg_index + (List.map + (fun (item : Parsetree.expression) -> item.pexp_loc) + items) | `ConstructorExpr (_, [{pexp_desc = Pexp_record (fields, _)}]) -> ( let field_name_with_cursor = @@ -668,22 +668,12 @@ let signature_help ~debug ~source ~kind_file ~pos else ()); !field_index | _ -> -1) - | `ConstructorExpr (_, [expr]) when loc_has_cursor expr.pexp_loc - -> - 0 - | `ConstructorPat (_, items) when List.length items > 1 -> ( - let idx = ref 0 in - let tuple_item_with_cursor = - items - |> List.find_map (fun (item : Parsetree.pattern) -> - let current_index = !idx in - idx := current_index + 1; - if loc_has_cursor item.ppat_loc then Some current_index - else None) - in - match tuple_item_with_cursor with - | None -> -1 - | Some i -> i) + | `ConstructorExpr (_, [_]) -> 0 + | `ConstructorPat (_, items) when List.length items > 1 -> + constructor_arg_index + (List.map + (fun (item : Parsetree.pattern) -> item.ppat_loc) + items) | `ConstructorPat (_, [{ppat_desc = Ppat_record (fields, _, _rest)}]) -> ( let field_name_with_cursor = @@ -713,7 +703,7 @@ let signature_help ~debug ~source ~kind_file ~pos else ()); !field_index | _ -> -1) - | `ConstructorPat (_, [pat]) when loc_has_cursor pat.ppat_loc -> 0 + | `ConstructorPat (_, [_]) -> 0 | _ -> -1 in diff --git a/tests/analysis_tests/tests/src/SignatureHelpConstructorGaps.res b/tests/analysis_tests/tests/src/SignatureHelpConstructorGaps.res new file mode 100644 index 00000000000..8d1093d30c1 --- /dev/null +++ b/tests/analysis_tests/tests/src/SignatureHelpConstructorGaps.res @@ -0,0 +1,34 @@ +type t = Three(string, array) | Unary(string) + +let a = Three("", []) +// ^she +let b = Three("", []) +// ^she +let c = Three("", []) +// ^she +let d = Three( "", []) +// ^she +let e = Unary( "") +// ^she + +let f = Three("", []) +// ^she +let g = Three("" , []) +// ^she +let h = Three( + "", + [], +//^she +) + +let i = Three("", []) +// ^she + +let read = value => switch value { +| Three(a, []) => a +// ^she +| Three(a, _) => a +// ^she +| Unary( a) => a +// ^she +} diff --git a/tests/analysis_tests/tests/src/expected/SignatureHelpConstructorGaps.res.txt b/tests/analysis_tests/tests/src/expected/SignatureHelpConstructorGaps.res.txt new file mode 100644 index 00000000000..8915f21ec08 --- /dev/null +++ b/tests/analysis_tests/tests/src/expected/SignatureHelpConstructorGaps.res.txt @@ -0,0 +1,237 @@ +Signature help src/SignatureHelpConstructorGaps.res 2:17 +{ + "activeParameter": 1, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 1, + "label": "Three(string, array)", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 6, 12 ] + }, + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 14, 24 ] + } + ] + } + ] +} + +Signature help src/SignatureHelpConstructorGaps.res 4:18 +{ + "activeParameter": 1, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 1, + "label": "Three(string, array)", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 6, 12 ] + }, + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 14, 24 ] + } + ] + } + ] +} + +Signature help src/SignatureHelpConstructorGaps.res 6:19 +{ + "activeParameter": 1, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 1, + "label": "Three(string, array)", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 6, 12 ] + }, + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 14, 24 ] + } + ] + } + ] +} + +Signature help src/SignatureHelpConstructorGaps.res 8:14 +{ + "activeParameter": 0, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 0, + "label": "Three(string, array)", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 6, 12 ] + }, + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 14, 24 ] + } + ] + } + ] +} + +Signature help src/SignatureHelpConstructorGaps.res 10:14 +{ + "activeParameter": 0, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 0, + "label": "Unary(string)", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 6, 12 ] + } + ] + } + ] +} + +Signature help src/SignatureHelpConstructorGaps.res 13:20 +{ + "activeParameter": 1, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 1, + "label": "Three(string, array)", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 6, 12 ] + }, + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 14, 24 ] + } + ] + } + ] +} + +Signature help src/SignatureHelpConstructorGaps.res 15:17 +{ + "activeParameter": 0, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 0, + "label": "Three(string, array)", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 6, 12 ] + }, + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 14, 24 ] + } + ] + } + ] +} + +Signature help src/SignatureHelpConstructorGaps.res 19:2 +{ + "activeParameter": 1, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 1, + "label": "Three(string, array)", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 6, 12 ] + }, + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 14, 24 ] + } + ] + } + ] +} + +Signature help src/SignatureHelpConstructorGaps.res 23:11 +null + +Signature help src/SignatureHelpConstructorGaps.res 27:10 +{ + "activeParameter": 1, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 1, + "label": "Three(string, array)", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 6, 12 ] + }, + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 14, 24 ] + } + ] + } + ] +} + +Signature help src/SignatureHelpConstructorGaps.res 29:11 +{ + "activeParameter": 1, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 1, + "label": "Three(string, array)", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 6, 12 ] + }, + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 14, 24 ] + } + ] + } + ] +} + +Signature help src/SignatureHelpConstructorGaps.res 31:8 +{ + "activeParameter": 0, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 0, + "label": "Unary(string)", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 6, 12 ] + } + ] + } + ] +} + From e8c906fad4b2da36e2c1432dc3e096d89f69d3ce Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 16:59:51 +0200 Subject: [PATCH 16/40] Preserve constructor compatibility without parser modes Apply the normalization approach proposed by @cristianoc in PR #8610. Keep source argument lists for printing and resolve semantic grouping after constructor disambiguation, without legacy PPX marker handling in the type checker or printer. Signed-off-by: Christoph Knittel --- CHANGELOG.md | 2 +- compiler/ml/ast_mapper_from0.ml | 60 ++++--------- compiler/ml/parsetree.ml | 6 ++ compiler/ml/typecore.ml | 53 +++++------ compiler/syntax/src/res_parsetree_viewer.ml | 2 +- compiler/syntax/src/res_printer.ml | 28 ------ tests/ERROR_VARIANTS.md | 2 +- ...structor_tuple_arity_mismatch.res.expected | 8 +- ..._tuple_arity_mismatch_pattern.res.expected | 6 +- .../constructor_tuple_arity_mismatch.res | 4 +- ...nstructor_tuple_arity_mismatch_pattern.res | 2 +- .../Cross_inline_record_constructor.expected | 2 +- tests/ounit_tests/ounit_ast_mapper0_tests.ml | 88 +++++++++++-------- .../data/ast-mapping/ConstructorArguments.res | 13 +++ .../expected/ConstructorArguments.res.txt | 13 +++ .../tests/src/constructor_explicit_arity.mjs | 42 +++++++++ .../tests/src/constructor_explicit_arity.res | 20 +++++ ...constructor_payload_compatibility_test.mjs | 29 ++++++ ...constructor_payload_compatibility_test.res | 22 +++++ 19 files changed, 250 insertions(+), 152 deletions(-) create mode 100644 tests/tests/src/constructor_payload_compatibility_test.mjs create mode 100644 tests/tests/src/constructor_payload_compatibility_test.res diff --git a/CHANGELOG.md b/CHANGELOG.md index 76adb2df8cc..be8d45caeed 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -14,7 +14,6 @@ #### :boom: Breaking Change -- Distinguish multiple constructor arguments from a tuple passed as a single argument. Constructors with one tuple payload must now use nested parentheses, for example `Some((x, y))`; `Some(x, y)` now reports an arity mismatch. This makes constructor arity explicit in the parsetree and removes the separate parser modes for printing and type checking. https://github.com/rescript-lang/rescript/pull/8610 - Reject malformed UTF-8 in documentation comments and invalid string or template literal escapes that were previously accepted, including empty or out-of-range braced Unicode escapes (`\u{}`, `\u{110000}`) and legacy decimal or octal escapes in templates (`\1`, `\01`, `\8`). These inputs now produce syntax diagnostics instead of compiling to invalid or inconsistent JavaScript. https://github.com/rescript-lang/rescript/pull/8606 - Reject tagged template literals in patterns. Patterns cannot invoke their tag; previously their raw payload was compiled as a plain string comparison. https://github.com/rescript-lang/rescript/pull/8606 - Remove runtime APIs that were deprecated for removal in ReScript 13, including the `Char` module, unsafe `Obj` operations, legacy `Pervasives` helpers, and `Array.unsafe_get`. https://github.com/rescript-lang/rescript/pull/8564 @@ -80,6 +79,7 @@ - Record a record field's `@as` rename on the declaration instead of re-reading the attribute, so every place that needs the runtime name reads one field. https://github.com/rescript-lang/rescript/pull/8619 - Record a variant constructor's `@as` tag on the declaration instead of re-interpreting its attributes, keeping the source spelling for printing. https://github.com/rescript-lang/rescript/pull/8619 - Optimization passes now return the term they were given when they change nothing, rather than rebuilding an identical one. https://github.com/rescript-lang/rescript/pull/8620 +- Remove separate parser modes for printing and type checking by preserving syntactic constructor arguments in the parsetree and resolving their semantic grouping during type checking. Existing constructor spellings and legacy PPX output remain supported. https://github.com/rescript-lang/rescript/pull/8610 - Merge the duplicate Lam intermediate representation into Lambda, removing the conversion layer and obsolete supporting infrastructure. Lambda is now a single private, normalized representation, with generated JavaScript remaining semantically unchanged. https://github.com/rescript-lang/rescript/pull/8608 - Add genType and source map controls and output to the developer playground. https://github.com/rescript-lang/rescript/pull/8448 - Rework the object-type representation end to end: object rows are plain field chains carrying a per-field mutability state (no phantom setter members), object literals are typed directly and property access and assignment are first-class AST and Lambda nodes shared between the Lambda and JS pipelines, and dead class-system remnants (the field-presence lattice, the class-abbreviation memo on object types, method-send typing) are removed. https://github.com/rescript-lang/rescript/pull/8597 diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index d8e60370f78..18fbe23f526 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -166,7 +166,6 @@ let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} let record_rest_attr_name = "_res.record_rest" let constructor_args_attr_name = "_res.constructor_args" let constructor_tuple_arg_attr_name = "_res.constructor_tuple_arg" -let legacy_constructor_payload_attr_name = "_res.legacy_constructor_payload" let has_explicit_arity_attr (attrs : Pt.attributes) = List.exists @@ -190,17 +189,14 @@ let remove_constructor_args_attr attrs = let remove_constructor_tuple_arg_attr attrs = remove_internal_marker_attr ~name:constructor_tuple_arg_attr_name attrs -let add_legacy_constructor_payload_attr attrs = - (Location.mknoloc legacy_constructor_payload_attr_name, Pt.PStr []) :: attrs - -let decode_args ~map ~tuple_args ~split_tuple ~known_tuple_arg = function - | None -> ([], false) +(* Unmarked v0 tuples remain a single syntactic payload. Typecore resolves + semantic argument grouping after it knows the constructor declaration. *) +let decode_args ~map ~tuple_args ~split_tuple = function + | None -> [] | Some arg -> ( match tuple_args arg with - | Some args when split_tuple -> (List.map map args, false) - | Some _ when known_tuple_arg -> ([map arg], false) - | Some _ -> ([map arg], true) - | None -> ([map arg], false)) + | Some args when split_tuple -> List.map map args + | _ -> [map arg]) let record_rest_of_pattern (rest : Pt.pattern) = match rest.Pt.ppat_desc with @@ -887,10 +883,8 @@ module E = struct | Pexp_construct (lid, arg) -> ( let lid1 = map_loc sub lid in let has_constructor_args, attrs = remove_constructor_args_attr attrs in - let has_constructor_tuple_arg, attrs = - remove_constructor_tuple_arg_attr attrs - in - let args, has_legacy_constructor_payload = + let _, attrs = remove_constructor_tuple_arg_attr attrs in + let args = decode_args ~map:(sub.expr sub) ~tuple_args:(fun arg -> match arg.pexp_desc with @@ -900,12 +894,7 @@ module E = struct (has_constructor_args || has_explicit_arity_attr attrs || lid.txt = Longident.Lident "::") - ~known_tuple_arg:has_constructor_tuple_arg arg - in - let attrs = - if has_legacy_constructor_payload then - add_legacy_constructor_payload_attr attrs - else attrs + arg in let exp1 = construct ~loc ~attrs lid1 args in match lid.txt with @@ -974,17 +963,14 @@ module E = struct :: attrs | _ -> attrs in - let has_constructor_tuple_arg, attrs = - remove_constructor_tuple_arg_attr attrs - in - let args, _ = + let _, attrs = remove_constructor_tuple_arg_attr attrs in + let args = decode_args ~map:(sub.expr sub) ~tuple_args:(fun arg -> match arg.pexp_desc with | Pexp_tuple args -> Some args | _ -> None) - ~split_tuple:has_constructor_args - ~known_tuple_arg:has_constructor_tuple_arg arg + ~split_tuple:has_constructor_args arg in variant ~loc ~attrs lab args | Pexp_record (l, eo) -> @@ -1155,10 +1141,8 @@ module P = struct | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) | Ppat_construct (l, arg) -> let has_constructor_args, attrs = remove_constructor_args_attr attrs in - let has_constructor_tuple_arg, attrs = - remove_constructor_tuple_arg_attr attrs - in - let args, has_legacy_constructor_payload = + let _, attrs = remove_constructor_tuple_arg_attr attrs in + let args = decode_args ~map:(sub.pat sub) ~tuple_args:(fun arg -> match arg.ppat_desc with @@ -1168,12 +1152,7 @@ module P = struct (has_constructor_args || has_explicit_arity_attr attrs || l.txt = Longident.Lident "::") - ~known_tuple_arg:has_constructor_tuple_arg arg - in - let attrs = - if has_legacy_constructor_payload then - add_legacy_constructor_payload_attr attrs - else attrs + arg in construct ~loc ~attrs (map_loc sub l) args | Ppat_variant (l, arg) -> @@ -1186,17 +1165,14 @@ module P = struct :: attrs | _ -> attrs in - let has_constructor_tuple_arg, attrs = - remove_constructor_tuple_arg_attr attrs - in - let args, _ = + let _, attrs = remove_constructor_tuple_arg_attr attrs in + let args = decode_args ~map:(sub.pat sub) ~tuple_args:(fun arg -> match arg.ppat_desc with | Ppat_tuple args -> Some args | _ -> None) - ~split_tuple:has_constructor_args - ~known_tuple_arg:has_constructor_tuple_arg arg + ~split_tuple:has_constructor_args arg in variant ~loc ~attrs l args | Ppat_record (lpl, cf) -> diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index 0c6703549d8..ca2beb54960 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -220,6 +220,9 @@ and pattern_desc = C(P) [P] C(P1, ..., Pn) [P1; ...; Pn] C((P1, ..., Pn)) [Ppat_tuple [P1; ...; Pn]] + + This list preserves syntax, not the declared constructor arity. + Type checking normalizes tuple grouping using the resolved constructor. *) | Ppat_variant of label * pattern list (* #A [] @@ -312,6 +315,9 @@ and expression_desc = C(E) [E] C(E1, ..., En) [E1; ...; En] C((E1, ..., En)) [Pexp_tuple [E1; ...; En]] + + This list preserves syntax, not the declared constructor arity. + Type checking normalizes tuple grouping using the resolved constructor. *) | Pexp_variant of label * expression list (* #A [] diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index a2d47961400..bb5148ad3cf 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1213,23 +1213,32 @@ type type_pat_mode = exception Need_backtrack +(* The parser preserves syntactic arguments for printing. Resolve their semantic + grouping only after constructor disambiguation, retaining the historical + equivalence of C(a, b) and C((a, b)), including for legacy PPX output. *) +let constructor_args_of_exp_payload ~arity sargs = + match sargs with + | [{pexp_desc = Pexp_tuple args}] when arity > 1 -> args + | {pexp_loc = first_loc} :: (_ :: _ as rest) when arity = 1 -> + let last = Ext_list.last rest in + let loc = Location.{first_loc with loc_end = last.pexp_loc.loc_end} in + [Ast_helper.Exp.tuple ~loc sargs] + | sargs -> sargs + +let constructor_args_of_pat_payload ~arity sargs = + match sargs with + | [{ppat_desc = Ppat_tuple args}] when arity > 1 -> args + | {ppat_loc = first_loc} :: (_ :: _ as rest) when arity = 1 -> + let last = Ext_list.last rest in + let loc = Location.{first_loc with loc_end = last.ppat_loc.loc_end} in + [Ast_helper.Pat.tuple ~loc sargs] + | sargs -> sargs + (* type_pat propagates the expected type as well as maps for constructors and labels. Unification may update the typing environment. *) (* constrs <> None => called from parmatch: backtrack on or-patterns explode > 0 => explode Ppat_any for gadts *) -let legacy_constructor_payload_attr_name = "_res.legacy_constructor_payload" - -let remove_legacy_constructor_payload_attr attrs = - let rec loop rev_attrs = function - | ({Location.txt; _}, PStr []) :: attrs - when txt = legacy_constructor_payload_attr_name -> - (true, List.rev_append rev_attrs attrs) - | attr :: attrs -> loop (attr :: rev_attrs) attrs - | [] -> (false, List.rev rev_attrs) - in - loop [] attrs - let rec type_pat ~constrs ~labels ~no_existentials ~mode ~explode ~env sp expected_ty k = Builtin_attributes.warning_scope sp.ppat_attributes (fun () -> @@ -1403,10 +1412,6 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp pat_env = !env; }) | Ppat_construct (lid, sargs) -> - let has_legacy_constructor_payload, ppat_attributes = - remove_legacy_constructor_payload_attr sp.ppat_attributes - in - let sp = {sp with ppat_attributes} in let opath = try let p0, p, _ = extract_concrete_variant !env expected_ty in @@ -1441,10 +1446,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp correct head *) if constr.cstr_generalized then unify_head_only loc !env expected_ty constr; let sargs = - match sargs with - | [{ppat_desc = Ppat_tuple sargs}] - when has_legacy_constructor_payload && constr.cstr_arity > 1 -> - sargs + match constructor_args_of_pat_payload ~arity:constr.cstr_arity sargs with | [({ppat_desc = Ppat_any} as sp)] when constr.cstr_arity <> 1 -> if constr.cstr_arity = 0 then Location.prerr_warning sp.ppat_loc @@ -4430,9 +4432,6 @@ and type_application ~context total_app env funct (sargs : sargs) : Apply_non_function (expand_head env funct.exp_type) ))) and type_construct ~context env loc lid sargs ty_expected attrs = - let has_legacy_constructor_payload, attrs = - remove_legacy_constructor_payload_attr attrs - in let opath = try let p0, p, _ = extract_concrete_variant env ty_expected in @@ -4448,13 +4447,7 @@ and type_construct ~context env loc lid sargs ty_expected attrs = Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr; Builtin_attributes.check_deprecated loc constr.cstr_attributes constr.cstr_name; - let sargs = - match sargs with - | [{pexp_desc = Pexp_tuple sargs}] - when has_legacy_constructor_payload && constr.cstr_arity > 1 -> - sargs - | sargs -> sargs - in + let sargs = constructor_args_of_exp_payload ~arity:constr.cstr_arity sargs in if List.length sargs <> constr.cstr_arity then raise (Error diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index c78cb740086..86b27db5ffe 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -228,7 +228,7 @@ let filter_parsing_attrs attrs = ( "res.braces" | "ns.braces" | "res.iflet" | "res.ternary" | "res.await" | "res.patVariantSpread" | "res.dictPattern" | "res.dictSpread" | "res.inlineRecordDefinition" - | "res.variantArgs" | "_res.legacy_constructor_payload" ); + | "res.variantArgs" ); }, _ ) -> false diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 0f5a39cc2e3..40c6f5b196b 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -2622,16 +2622,6 @@ and print_extension ~state ~at_module_lvl (string_loc, payload) cmt_tbl = in Doc.group (Doc.concat [ext_name; print_payload ~state payload cmt_tbl]) -and remove_legacy_constructor_payload_attr attrs = - let rec loop rev_attrs = function - | ({Location.txt = "_res.legacy_constructor_payload"}, Parsetree.PStr []) - :: attrs -> - (true, List.rev_append rev_attrs attrs) - | attr :: attrs -> loop (attr :: rev_attrs) attrs - | [] -> (false, List.rev rev_attrs) - in - loop [] attrs - and print_pattern_args ~state (patterns : Parsetree.pattern list) cmt_tbl = match patterns with | [] -> Doc.nil @@ -2676,15 +2666,6 @@ and print_pattern_args ~state (patterns : Parsetree.pattern list) cmt_tbl = ] and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = - let has_legacy_constructor_payload, ppat_attributes = - remove_legacy_constructor_payload_attr p.ppat_attributes - in - let p = - match (has_legacy_constructor_payload, p.ppat_desc) with - | true, Ppat_construct (constr, [{ppat_desc = Ppat_tuple args}]) -> - {p with ppat_desc = Ppat_construct (constr, args); ppat_attributes} - | _ -> {p with ppat_attributes} - in let pattern_without_attributes = match p.ppat_desc with | Ppat_any -> Doc.text "_" @@ -3201,15 +3182,6 @@ and print_object_get_doc ~state parent_expr (label : string Location.loc) Doc.group (Doc.concat [parent_doc; Doc.lbracket; member; Doc.rbracket]) and print_expression ~state (e : Parsetree.expression) cmt_tbl = - let has_legacy_constructor_payload, pexp_attributes = - remove_legacy_constructor_payload_attr e.pexp_attributes - in - let e = - match (has_legacy_constructor_payload, e.pexp_desc) with - | true, Pexp_construct (constr, [{pexp_desc = Pexp_tuple args}]) -> - {e with pexp_desc = Pexp_construct (constr, args); pexp_attributes} - | _ -> {e with pexp_attributes} - in let printed_expression = match e.pexp_desc with | Pexp_fun diff --git a/tests/ERROR_VARIANTS.md b/tests/ERROR_VARIANTS.md index 043df0891a1..012ca594881 100644 --- a/tests/ERROR_VARIANTS.md +++ b/tests/ERROR_VARIANTS.md @@ -201,7 +201,7 @@ Source: [typecore.ml:27](../compiler/ml/typecore.ml). | Variant | Status | Fixture | Notes | |---|---|---|---| | `Polymorphic_label` | ✓ | `polymorphic_label.res` | Pattern that instantiates a polymorphic record field: `({f: (f: int => int)}: t) =>` constrains the universal `'a` of `f: 'a. 'a => 'a` to `int => int`. | -| `Constructor_arity_mismatch` | ✓ | `constructor_arity_mismatch.res`, `constructor_arity_mismatch_pattern.res`, `constructor_tuple_arity_mismatch.res`, `constructor_tuple_arity_mismatch_pattern.res`, `arity_mismatch*.res` | Triggers in both expression and pattern paths, including the distinction between multiple arguments and one tuple argument. | +| `Constructor_arity_mismatch` | ✓ | `constructor_arity_mismatch.res`, `constructor_arity_mismatch_pattern.res`, `constructor_tuple_arity_mismatch.res`, `constructor_tuple_arity_mismatch_pattern.res`, `arity_mismatch*.res` | Triggers in both expression and pattern paths, after semantic argument normalization. | | `Label_mismatch` | ✓ | `label_mismatch_record_literal.res` | Record literal without expected type mixing fields from two different record types — disambiguation picks one type per label, and the cross-type unify fails inside `type_label_exp`. | | `Pattern_type_clash` | ✓ | many `*_pattern_type_clash.res` etc. | Most-fired pattern error. Sub-case fixtures: `pattern_matching_on_option_but_value_not_option.res` and `pattern_matching_on_value_but_is_option.res` (option-vs-non-option trace), `pattern_type_clash_polyvariant.res` (polyvariant tag against concrete type), `pattern_type_clash_tuple_arity.res` (tuple arity mismatch). | | `Or_pattern_type_clash` | ✓ | `or_pattern_type_clash.res` | | diff --git a/tests/build_tests/super_errors/expected/constructor_tuple_arity_mismatch.res.expected b/tests/build_tests/super_errors/expected/constructor_tuple_arity_mismatch.res.expected index d0d1e0ed0b2..a74292b9c7e 100644 --- a/tests/build_tests/super_errors/expected/constructor_tuple_arity_mismatch.res.expected +++ b/tests/build_tests/super_errors/expected/constructor_tuple_arity_mismatch.res.expected @@ -1,10 +1,10 @@ We've found a bug for you! - /.../fixtures/constructor_tuple_arity_mismatch.res:3:15-25 + /.../fixtures/constructor_tuple_arity_mismatch.res:3:15-31 - 1 │ type unary = Unary((int, int)) + 1 │ type binary = Binary(int, int) 2 │ - 3 │ let invalid = Unary(1, 2) + 3 │ let invalid = Binary((1, 2, 3)) 4 │ - This variant constructor Unary expects 1 argument, but it's being passed 2. \ No newline at end of file + This variant constructor Binary expects 2 arguments, but it's being passed 3. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/constructor_tuple_arity_mismatch_pattern.res.expected b/tests/build_tests/super_errors/expected/constructor_tuple_arity_mismatch_pattern.res.expected index ebc857c4318..3fab3c019e8 100644 --- a/tests/build_tests/super_errors/expected/constructor_tuple_arity_mismatch_pattern.res.expected +++ b/tests/build_tests/super_errors/expected/constructor_tuple_arity_mismatch_pattern.res.expected @@ -1,11 +1,11 @@ We've found a bug for you! - /.../fixtures/constructor_tuple_arity_mismatch_pattern.res:5:5-18 + /.../fixtures/constructor_tuple_arity_mismatch_pattern.res:5:5-21 3 │ let read = value => 4 │ switch value { - 5 │ | Binary((x, y)) => x + y + 5 │ | Binary((x, y, z)) => x + y + z 6 │ } 7 │ - This variant constructor Binary expects 2 arguments, but it's only being passed 1. \ No newline at end of file + This variant constructor Binary expects 2 arguments, but it's being passed 3. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/constructor_tuple_arity_mismatch.res b/tests/build_tests/super_errors/fixtures/constructor_tuple_arity_mismatch.res index 988cf303c56..8853d5c437a 100644 --- a/tests/build_tests/super_errors/fixtures/constructor_tuple_arity_mismatch.res +++ b/tests/build_tests/super_errors/fixtures/constructor_tuple_arity_mismatch.res @@ -1,3 +1,3 @@ -type unary = Unary((int, int)) +type binary = Binary(int, int) -let invalid = Unary(1, 2) +let invalid = Binary((1, 2, 3)) diff --git a/tests/build_tests/super_errors/fixtures/constructor_tuple_arity_mismatch_pattern.res b/tests/build_tests/super_errors/fixtures/constructor_tuple_arity_mismatch_pattern.res index f40de8e9b3c..13aa5b245df 100644 --- a/tests/build_tests/super_errors/fixtures/constructor_tuple_arity_mismatch_pattern.res +++ b/tests/build_tests/super_errors/fixtures/constructor_tuple_arity_mismatch_pattern.res @@ -2,5 +2,5 @@ type binary = Binary(int, int) let read = value => switch value { - | Binary((x, y)) => x + y + | Binary((x, y, z)) => x + y + z } diff --git a/tests/build_tests/super_errors_multi/expected/Cross_inline_record_constructor.expected b/tests/build_tests/super_errors_multi/expected/Cross_inline_record_constructor.expected index b41ec138a12..6a1cdb1ef84 100644 --- a/tests/build_tests/super_errors_multi/expected/Cross_inline_record_constructor.expected +++ b/tests/build_tests/super_errors_multi/expected/Cross_inline_record_constructor.expected @@ -6,4 +6,4 @@ 1 │ let v = Defs.Pair(1, 2) 2 │ - This variant constructor Defs.Pair expects an inline record as payload. \ No newline at end of file + This constructor expects an inlined record argument. \ No newline at end of file diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index 812d55e239d..dc7dc9aef5e 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -465,14 +465,22 @@ let test_fresh_ast0_constructor_tuple_reprints_without_internal_metadata _ = ( _, [ { - pvb_pat = {ppat_desc = Ppat_construct (_, [_; _])}; - pvb_expr = {pexp_desc = Pexp_construct (_, [_; _])}; + pvb_pat = + { + ppat_desc = + Ppat_construct (_, [{ppat_desc = Ppat_tuple [_; _]}]); + }; + pvb_expr = + { + pexp_desc = + Pexp_construct (_, [{pexp_desc = Pexp_tuple [_; _]}]); + }; }; ] ); }; ] -> () - | _ -> assert_failure "Expected two printed constructor arguments") + | _ -> assert_failure "Expected a printed tuple payload") [10; 80] let test_ast0_explicit_arity_becomes_constructor_args _ = @@ -507,43 +515,47 @@ let test_fresh_ast0_constructor_tuple_defers_arity_to_typechecker _ = (Ast_helper0.Pat.construct ~loc lid (Some (Ast_helper0.Pat.tuple ~loc [int_pat "1"; int_pat "2"]))) in - OUnit.assert_bool "fresh v0 expression carries deferred-arity metadata" - (has_attr "_res.legacy_constructor_payload" expr.pexp_attributes); - OUnit.assert_bool "fresh v0 pattern carries deferred-arity metadata" - (has_attr "_res.legacy_constructor_payload" pat.ppat_attributes); - let parsed = - Res_driver.parse_implementation_from_source - ~display_filename:"Ast0ConstructorArgsTest.res" - ~source: - "type freshPairForAst0 = FreshPairForAst0(int, int)\n\ - let value = FreshPairForAst0(1, 2)\n\ - let FreshPairForAst0(a, b) = value" - in - let structure = - match parsed.parsetree with - | [type_item; value_item; pattern_item] -> - let value_item = - match value_item.pstr_desc with - | Pstr_value (rec_flag, [binding]) -> - { - value_item with - pstr_desc = Pstr_value (rec_flag, [{binding with pvb_expr = expr}]); - } - | _ -> assert_failure "Expected value binding" + OUnit.assert_equal [] expr.pexp_attributes; + OUnit.assert_equal [] pat.ppat_attributes; + List.iter + (fun payload_type -> + let parsed = + Res_driver.parse_implementation_from_source + ~display_filename:"Ast0ConstructorArgsTest.res" + ~source: + (Printf.sprintf + "type freshPairForAst0 = FreshPairForAst0(%s)\n\ + let value = FreshPairForAst0(1, 2)\n\ + let FreshPairForAst0(a, b) = value" + payload_type) in - let pattern_item = - match pattern_item.pstr_desc with - | Pstr_value (rec_flag, [binding]) -> - { - pattern_item with - pstr_desc = Pstr_value (rec_flag, [{binding with pvb_pat = pat}]); - } - | _ -> assert_failure "Expected pattern binding" + let structure = + match parsed.parsetree with + | [type_item; value_item; pattern_item] -> + let value_item = + match value_item.pstr_desc with + | Pstr_value (rec_flag, [binding]) -> + { + value_item with + pstr_desc = + Pstr_value (rec_flag, [{binding with pvb_expr = expr}]); + } + | _ -> assert_failure "Expected value binding" + in + let pattern_item = + match pattern_item.pstr_desc with + | Pstr_value (rec_flag, [binding]) -> + { + pattern_item with + pstr_desc = Pstr_value (rec_flag, [{binding with pvb_pat = pat}]); + } + | _ -> assert_failure "Expected pattern binding" + in + [type_item; value_item; pattern_item] + | _ -> assert_failure "Expected type declaration and two value bindings" in - [type_item; value_item; pattern_item] - | _ -> assert_failure "Expected type declaration and two value bindings" - in - ignore (Typemod.type_structure Env.initial_safe_string structure loc) + ignore (Typemod.type_structure Env.initial_safe_string structure loc)) + ["int, int"; "(int, int)"] let test_polyvariant_args_roundtrip_through_ast0 _ = let int_expr value = diff --git a/tests/syntax_tests/data/ast-mapping/ConstructorArguments.res b/tests/syntax_tests/data/ast-mapping/ConstructorArguments.res index 909bdb76b7d..b47c22e489f 100644 --- a/tests/syntax_tests/data/ast-mapping/ConstructorArguments.res +++ b/tests/syntax_tests/data/ast-mapping/ConstructorArguments.res @@ -4,6 +4,19 @@ type binary = Binary(int, int) let unary = Unary((1, 2)) let binary = Binary(1, 2) +let unaryUnparenthesized = Unary(1, 2) +let binaryParenthesized = Binary((1, 2)) + +let readUnaryUnparenthesized = value => + switch value { + | Unary(x, y) => x + y + } + +let readBinaryParenthesized = value => + switch value { + | Binary((x, y)) => x + y + } + let readUnary = value => switch value { | Unary((x, y)) => x + y diff --git a/tests/syntax_tests/data/ast-mapping/expected/ConstructorArguments.res.txt b/tests/syntax_tests/data/ast-mapping/expected/ConstructorArguments.res.txt index 909bdb76b7d..b47c22e489f 100644 --- a/tests/syntax_tests/data/ast-mapping/expected/ConstructorArguments.res.txt +++ b/tests/syntax_tests/data/ast-mapping/expected/ConstructorArguments.res.txt @@ -4,6 +4,19 @@ type binary = Binary(int, int) let unary = Unary((1, 2)) let binary = Binary(1, 2) +let unaryUnparenthesized = Unary(1, 2) +let binaryParenthesized = Binary((1, 2)) + +let readUnaryUnparenthesized = value => + switch value { + | Unary(x, y) => x + y + } + +let readBinaryParenthesized = value => + switch value { + | Binary((x, y)) => x + y + } + let readUnary = value => switch value { | Unary((x, y)) => x + y diff --git a/tests/tests/src/constructor_explicit_arity.mjs b/tests/tests/src/constructor_explicit_arity.mjs index e84a82dcfab..6c74dbf055f 100644 --- a/tests/tests/src/constructor_explicit_arity.mjs +++ b/tests/tests/src/constructor_explicit_arity.mjs @@ -10,6 +10,23 @@ function readBinary(value) { return value._0 + value._1 | 0; } +function readUnaryUnparenthesized(value) { + let match = value._0; + return match[0] + match[1] | 0; +} + +function readBinaryParenthesized(value) { + return value._0 + value._1 | 0; +} + +function readOptionUnparenthesized(value) { + if (value !== undefined) { + return value[0] + value[1] | 0; + } else { + return 0; + } +} + function readPoly(value) { return value.VAL[0] + value.VAL[1] | 0; } @@ -28,6 +45,25 @@ let binary = { _1: 2 }; +let unaryUnparenthesized = { + TAG: "Unary", + _0: [ + 1, + 2 + ] +}; + +let binaryParenthesized = { + TAG: "Binary", + _0: 1, + _1: 2 +}; + +let optionUnparenthesized = [ + 1, + 2 +]; + let polyUnary = { NAME: "UnaryTuple", VAL: [ @@ -47,8 +83,14 @@ let polyBinary = { export { unary, binary, + unaryUnparenthesized, + binaryParenthesized, + optionUnparenthesized, readUnary, readBinary, + readUnaryUnparenthesized, + readBinaryParenthesized, + readOptionUnparenthesized, polyUnary, polyBinary, readPoly, diff --git a/tests/tests/src/constructor_explicit_arity.res b/tests/tests/src/constructor_explicit_arity.res index 909bdb76b7d..c783421b2c9 100644 --- a/tests/tests/src/constructor_explicit_arity.res +++ b/tests/tests/src/constructor_explicit_arity.res @@ -4,6 +4,10 @@ type binary = Binary(int, int) let unary = Unary((1, 2)) let binary = Binary(1, 2) +let unaryUnparenthesized = Unary(1, 2) +let binaryParenthesized = Binary((1, 2)) +let optionUnparenthesized = Some(1, 2) + let readUnary = value => switch value { | Unary((x, y)) => x + y @@ -14,6 +18,22 @@ let readBinary = value => | Binary(x, y) => x + y } +let readUnaryUnparenthesized = value => + switch value { + | Unary(x, y) => x + y + } + +let readBinaryParenthesized = value => + switch value { + | Binary((x, y)) => x + y + } + +let readOptionUnparenthesized = value => + switch value { + | Some(x, y) => x + y + | None => 0 + } + type poly = [#UnaryTuple((int, int)) | #BinaryArgs(int, int)] let polyUnary: poly = #UnaryTuple((1, 2)) diff --git a/tests/tests/src/constructor_payload_compatibility_test.mjs b/tests/tests/src/constructor_payload_compatibility_test.mjs new file mode 100644 index 00000000000..984682ce07b --- /dev/null +++ b/tests/tests/src/constructor_payload_compatibility_test.mjs @@ -0,0 +1,29 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as Mocha from "mocha"; +import * as Test_utils from "./test_utils.mjs"; +import * as Constructor_explicit_arity from "./constructor_explicit_arity.mjs"; + +Mocha.describe("constructor payload compatibility", () => { + Mocha.test("accepts both unary tuple spellings", () => { + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 7, characters 7-14", Constructor_explicit_arity.readUnary(Constructor_explicit_arity.unary), 3); + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 8, characters 7-14", Constructor_explicit_arity.readUnary(Constructor_explicit_arity.unaryUnparenthesized), 3); + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 9, characters 7-14", Constructor_explicit_arity.readUnaryUnparenthesized(Constructor_explicit_arity.unary), 3); + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 10, characters 7-14", Constructor_explicit_arity.readUnaryUnparenthesized(Constructor_explicit_arity.unaryUnparenthesized), 3); + }); + Mocha.test("accepts both binary constructor spellings", () => { + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 13, characters 7-14", Constructor_explicit_arity.readBinary(Constructor_explicit_arity.binary), 3); + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 14, characters 7-14", Constructor_explicit_arity.readBinary(Constructor_explicit_arity.binaryParenthesized), 3); + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 15, characters 7-14", Constructor_explicit_arity.readBinaryParenthesized(Constructor_explicit_arity.binary), 3); + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 16, characters 7-14", Constructor_explicit_arity.readBinaryParenthesized(Constructor_explicit_arity.binaryParenthesized), 3); + }); + Mocha.test("accepts unparenthesized option tuple payloads", () => { + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 19, characters 7-14", Constructor_explicit_arity.readOptionUnparenthesized(Constructor_explicit_arity.optionUnparenthesized), 3); + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 20, characters 7-14", Constructor_explicit_arity.readOptionUnparenthesized([ + 1, + 2 + ]), 3); + }); +}); + +/* Not a pure module */ diff --git a/tests/tests/src/constructor_payload_compatibility_test.res b/tests/tests/src/constructor_payload_compatibility_test.res new file mode 100644 index 00000000000..89a48ddbb02 --- /dev/null +++ b/tests/tests/src/constructor_payload_compatibility_test.res @@ -0,0 +1,22 @@ +open Mocha +open Test_utils +open Constructor_explicit_arity + +describe("constructor payload compatibility", () => { + test("accepts both unary tuple spellings", () => { + eq(__LOC__, readUnary(unary), 3) + eq(__LOC__, readUnary(unaryUnparenthesized), 3) + eq(__LOC__, readUnaryUnparenthesized(unary), 3) + eq(__LOC__, readUnaryUnparenthesized(unaryUnparenthesized), 3) + }) + test("accepts both binary constructor spellings", () => { + eq(__LOC__, readBinary(binary), 3) + eq(__LOC__, readBinary(binaryParenthesized), 3) + eq(__LOC__, readBinaryParenthesized(binary), 3) + eq(__LOC__, readBinaryParenthesized(binaryParenthesized), 3) + }) + test("accepts unparenthesized option tuple payloads", () => { + eq(__LOC__, readOptionUnparenthesized(optionUnparenthesized), 3) + eq(__LOC__, readOptionUnparenthesized(Some((1, 2))), 3) + }) +}) From c5db70aa9d60f16c8a4617635d547b3c5050be43 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 17:10:00 +0200 Subject: [PATCH 17/40] Remove redundant single-tuple AST0 bridge marker Signed-off-by: Christoph Knittel --- compiler/ml/ast_mapper_from0.ml | 8 ------- compiler/ml/ast_mapper_to0.ml | 23 +------------------- tests/ounit_tests/ounit_ast_mapper0_tests.ml | 7 +++--- 3 files changed, 4 insertions(+), 34 deletions(-) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 18fbe23f526..7002e33769a 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -165,7 +165,6 @@ let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} (* Internal Parsetree0 bridge metadata; public res.* attributes pass through. *) let record_rest_attr_name = "_res.record_rest" let constructor_args_attr_name = "_res.constructor_args" -let constructor_tuple_arg_attr_name = "_res.constructor_tuple_arg" let has_explicit_arity_attr (attrs : Pt.attributes) = List.exists @@ -186,9 +185,6 @@ let remove_internal_marker_attr ~name (attrs : Pt.attributes) = let remove_constructor_args_attr attrs = remove_internal_marker_attr ~name:constructor_args_attr_name attrs -let remove_constructor_tuple_arg_attr attrs = - remove_internal_marker_attr ~name:constructor_tuple_arg_attr_name attrs - (* Unmarked v0 tuples remain a single syntactic payload. Typecore resolves semantic argument grouping after it knows the constructor declaration. *) let decode_args ~map ~tuple_args ~split_tuple = function @@ -883,7 +879,6 @@ module E = struct | Pexp_construct (lid, arg) -> ( let lid1 = map_loc sub lid in let has_constructor_args, attrs = remove_constructor_args_attr attrs in - let _, attrs = remove_constructor_tuple_arg_attr attrs in let args = decode_args ~map:(sub.expr sub) ~tuple_args:(fun arg -> @@ -963,7 +958,6 @@ module E = struct :: attrs | _ -> attrs in - let _, attrs = remove_constructor_tuple_arg_attr attrs in let args = decode_args ~map:(sub.expr sub) ~tuple_args:(fun arg -> @@ -1141,7 +1135,6 @@ module P = struct | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) | Ppat_construct (l, arg) -> let has_constructor_args, attrs = remove_constructor_args_attr attrs in - let _, attrs = remove_constructor_tuple_arg_attr attrs in let args = decode_args ~map:(sub.pat sub) ~tuple_args:(fun arg -> @@ -1165,7 +1158,6 @@ module P = struct :: attrs | _ -> attrs in - let _, attrs = remove_constructor_tuple_arg_attr attrs in let args = decode_args ~map:(sub.pat sub) ~tuple_args:(fun arg -> diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 7f310406d57..6d98afde974 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -108,18 +108,13 @@ let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} (* Internal Parsetree0 bridge metadata; public res.* attributes pass through. *) let record_rest_attr_name = "_res.record_rest" let constructor_args_attr_name = "_res.constructor_args" -let constructor_tuple_arg_attr_name = "_res.constructor_tuple_arg" let add_constructor_args_attr attrs = (Location.mknoloc constructor_args_attr_name, Pt.PStr []) :: attrs -let add_constructor_tuple_arg_attr attrs = - (Location.mknoloc constructor_tuple_arg_attr_name, Pt.PStr []) :: attrs - -let encode_args ~map ~is_tuple ~tuple ~loc ~attrs args = +let encode_args ~map ~tuple ~loc ~attrs args = match List.map map args with | [] -> (None, attrs) - | [arg] when is_tuple arg -> (Some arg, add_constructor_tuple_arg_attr attrs) | [arg] -> (Some arg, attrs) | args -> (Some (tuple ~loc args), add_constructor_args_attr attrs) @@ -600,10 +595,6 @@ module E = struct in let arg, attrs = encode_args ~map:(sub.expr sub) - ~is_tuple:(fun arg -> - match arg.pexp_desc with - | Pexp_tuple _ -> true - | _ -> false) ~tuple:(fun ~loc args -> Ast_helper0.Exp.tuple ~loc args) ~loc:args_loc ~attrs args in @@ -612,10 +603,6 @@ module E = struct let args_loc, attrs = variant_args_loc ~loc attrs in let arg, attrs = encode_args ~map:(sub.expr sub) - ~is_tuple:(fun arg -> - match arg.pexp_desc with - | Pexp_tuple _ -> true - | _ -> false) ~tuple:(fun ~loc args -> Ast_helper0.Exp.tuple ~loc args) ~loc:args_loc ~attrs args in @@ -860,10 +847,6 @@ module P = struct in let arg, attrs = encode_args ~map:(sub.pat sub) - ~is_tuple:(fun arg -> - match arg.ppat_desc with - | Ppat_tuple _ -> true - | _ -> false) ~tuple:(fun ~loc args -> Ast_helper0.Pat.tuple ~loc args) ~loc:args_loc ~attrs args in @@ -872,10 +855,6 @@ module P = struct let args_loc, attrs = variant_args_loc ~loc attrs in let arg, attrs = encode_args ~map:(sub.pat sub) - ~is_tuple:(fun arg -> - match arg.ppat_desc with - | Ppat_tuple _ -> true - | _ -> false) ~tuple:(fun ~loc args -> Ast_helper0.Pat.tuple ~loc args) ~loc:args_loc ~attrs args in diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index dc7dc9aef5e..244565d3468 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -321,10 +321,9 @@ let test_constructor_args_roundtrip_through_ast0 _ = let tuple_expr = Ast_helper.Exp.tuple ~loc [int_expr "1"; int_expr "2"] in let expr = Ast_helper.Exp.construct ~loc lid [tuple_expr] in let expr0 = map_expr_to0 expr in - OUnit.assert_bool "a single tuple argument does not carry bridge metadata" - (not (has_attr "_res.constructor_args" expr0.pexp_attributes)); - OUnit.assert_bool "a single tuple argument records its v0 shape" - (has_attr "_res.constructor_tuple_arg" expr0.pexp_attributes); + OUnit.assert_equal + ~msg:"a single tuple argument does not carry bridge metadata" [] + expr0.pexp_attributes; let expr = map_expr0 expr0 in OUnit.assert_bool "a known tuple argument is not marked as legacy" (not (has_attr "_res.legacy_constructor_payload" expr.pexp_attributes)); From 9d4b6761c93a165ef52eb742d098c19ee17cdd31 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 17:10:00 +0200 Subject: [PATCH 18/40] Revert unnecessary constructor syntax migrations Signed-off-by: Christoph Knittel --- packages/@rescript/belt/src/Belt_List.res | 4 ++-- packages/@rescript/belt/src/Belt_Map.resi | 2 +- packages/@rescript/belt/src/Belt_MapInt.resi | 2 +- packages/@rescript/belt/src/Belt_MapString.resi | 2 +- packages/@rescript/belt/src/Belt_internalAVLtree.res | 2 +- packages/@rescript/runtime/Stdlib_List.res | 4 ++-- tests/belt_tests/src/belt_list_test.res | 12 ++++++------ tests/tests/src/exception_raise_test.res | 2 +- tests/tests/src/mario_game.res | 12 ++++++------ tests/tests/src/unboxed_attribute.res | 2 +- tests/tests/src/variant.res | 6 +++--- 11 files changed, 25 insertions(+), 25 deletions(-) diff --git a/packages/@rescript/belt/src/Belt_List.res b/packages/@rescript/belt/src/Belt_List.res index 4a7cd832f53..a000e415d4c 100644 --- a/packages/@rescript/belt/src/Belt_List.res +++ b/packages/@rescript/belt/src/Belt_List.res @@ -338,7 +338,7 @@ let splitAt = (lst, n) => if n < 0 { None } else if n == 0 { - Some((list{}, lst)) + Some(list{}, lst) } else { switch lst { | list{} => None @@ -346,7 +346,7 @@ let splitAt = (lst, n) => let cell = mutableCell(x, list{}) let rest = splitAtAux(n - 1, xs, cell) switch rest { - | Some(rest) => Some((cell, rest)) + | Some(rest) => Some(cell, rest) | None => None } } diff --git a/packages/@rescript/belt/src/Belt_Map.resi b/packages/@rescript/belt/src/Belt_Map.resi index 7a238f86a2c..78dd3482db0 100644 --- a/packages/@rescript/belt/src/Belt_Map.resi +++ b/packages/@rescript/belt/src/Belt_Map.resi @@ -123,7 +123,7 @@ module IntCmp = Belt.Id.MakeComparable({ let s0 = Belt.Map.fromArray(~id=module(IntCmp), [(4, "4"), (1, "1"), (2, "2"), (3, "")]) -s0->Belt.Map.findFirstBy((k, _) => k == 4) == Some((4, "4")) +s0->Belt.Map.findFirstBy((k, _) => k == 4) == Some(4, "4") ``` */ let findFirstBy: (t<'k, 'v, 'id>, ('k, 'v) => bool) => option<('k, 'v)> diff --git a/packages/@rescript/belt/src/Belt_MapInt.resi b/packages/@rescript/belt/src/Belt_MapInt.resi index 8cb314338dd..42b2e1de683 100644 --- a/packages/@rescript/belt/src/Belt_MapInt.resi +++ b/packages/@rescript/belt/src/Belt_MapInt.resi @@ -35,7 +35,7 @@ to match predicate `p`. ```rescript let mapInt = Belt.Map.Int.fromArray([(1, "one"), (2, "two"), (3, "three")]) -mapInt->Belt.Map.Int.findFirstBy((k, v) => k == 1 && v == "one") == Some((1, "one")) +mapInt->Belt.Map.Int.findFirstBy((k, v) => k == 1 && v == "one") == Some(1, "one") ``` */ let findFirstBy: (t<'v>, (key, 'v) => bool) => option<(key, 'v)> diff --git a/packages/@rescript/belt/src/Belt_MapString.resi b/packages/@rescript/belt/src/Belt_MapString.resi index 7da55813c8c..0469496376e 100644 --- a/packages/@rescript/belt/src/Belt_MapString.resi +++ b/packages/@rescript/belt/src/Belt_MapString.resi @@ -35,7 +35,7 @@ to match predicate `p`. ```rescript let mapString = Belt.Map.String.fromArray([("1", "one"), ("2", "two"), ("3", "three")]) -mapString->Belt.Map.String.findFirstBy((k, v) => k == "1" && v == "one") == Some(("1", "one")) +mapString->Belt.Map.String.findFirstBy((k, v) => k == "1" && v == "one") == Some("1", "one") ``` */ let findFirstBy: (t<'v>, (key, 'v) => bool) => option<(key, 'v)> diff --git a/packages/@rescript/belt/src/Belt_internalAVLtree.res b/packages/@rescript/belt/src/Belt_internalAVLtree.res index 7482c2bfa22..80f3ded37c1 100644 --- a/packages/@rescript/belt/src/Belt_internalAVLtree.res +++ b/packages/@rescript/belt/src/Belt_internalAVLtree.res @@ -203,7 +203,7 @@ let rec findFirstBy = (n, p) => let {key: v, value: d} = n let pvd = p(v, d) if pvd { - Some((v, d)) + Some(v, d) } else { let right = findFirstBy(n.right, p) if right != None { diff --git a/packages/@rescript/runtime/Stdlib_List.res b/packages/@rescript/runtime/Stdlib_List.res index 20723081edc..46c60d7c4d5 100644 --- a/packages/@rescript/runtime/Stdlib_List.res +++ b/packages/@rescript/runtime/Stdlib_List.res @@ -358,7 +358,7 @@ let splitAt = (lst, n) => if n < 0 { None } else if n == 0 { - Some((list{}, lst)) + Some(list{}, lst) } else { switch lst { | list{} => None @@ -366,7 +366,7 @@ let splitAt = (lst, n) => let cell = mutableCell(x, list{}) let rest = splitAtAux(n - 1, xs, cell) switch rest { - | Some(rest) => Some((cell, rest)) + | Some(rest) => Some(cell, rest) | None => None } } diff --git a/tests/belt_tests/src/belt_list_test.res b/tests/belt_tests/src/belt_list_test.res index 0ba7fdd2582..9f84baa3dfd 100644 --- a/tests/belt_tests/src/belt_list_test.res +++ b/tests/belt_tests/src/belt_list_test.res @@ -159,12 +159,12 @@ describe(__MODULE__, () => { let a = N.makeBy(5, id) eq(__LOC__, N.splitAt(list{}, 1), None) eq(__LOC__, N.splitAt(a, 6), None) - eq(__LOC__, N.splitAt(a, 5), Some((a, list{}))) - eq(__LOC__, N.splitAt(a, 4), Some((list{0, 1, 2, 3}, list{4}))) - eq(__LOC__, N.splitAt(a, 3), Some((list{0, 1, 2}, list{3, 4}))) - eq(__LOC__, N.splitAt(a, 2), Some((list{0, 1}, list{2, 3, 4}))) - eq(__LOC__, N.splitAt(a, 1), Some((list{0}, list{1, 2, 3, 4}))) - eq(__LOC__, N.splitAt(a, 0), Some((list{}, a))) + eq(__LOC__, N.splitAt(a, 5), Some(a, list{})) + eq(__LOC__, N.splitAt(a, 4), Some(list{0, 1, 2, 3}, list{4})) + eq(__LOC__, N.splitAt(a, 3), Some(list{0, 1, 2}, list{3, 4})) + eq(__LOC__, N.splitAt(a, 2), Some(list{0, 1}, list{2, 3, 4})) + eq(__LOC__, N.splitAt(a, 1), Some(list{0}, list{1, 2, 3, 4})) + eq(__LOC__, N.splitAt(a, 0), Some(list{}, a)) eq(__LOC__, N.splitAt(a, -1), None) }) diff --git a/tests/tests/src/exception_raise_test.res b/tests/tests/src/exception_raise_test.res index 010139b2f0b..ca6ea90f722 100644 --- a/tests/tests/src/exception_raise_test.res +++ b/tests/tests/src/exception_raise_test.res @@ -18,7 +18,7 @@ let appf = (g, x) => { | U.A(_) => 3 | B(list{_, _, x, ..._}) => x | C(x, _) - | D((x, _)) => x + | D(x, _) => x | _ => 4 } } diff --git a/tests/tests/src/mario_game.res b/tests/tests/src/mario_game.res index b4d7fe2acdc..20345edbbe7 100644 --- a/tests/tests/src/mario_game.res +++ b/tests/tests/src/mario_game.res @@ -1123,17 +1123,17 @@ module Object: { BigM } if !prev_jumping && player.jumping { - Some((pl_typ, Sprite.make(SPlayer(pl_typ, Jumping), player.dir, context))) + Some(pl_typ, Sprite.make(SPlayer(pl_typ, Jumping), player.dir, context)) } else if ( prev_dir != player.dir || (prev_vx == 0. && Math.abs(player.vel.x) > 0. && !player.jumping) ) { - Some((pl_typ, Sprite.make(SPlayer(pl_typ, Running), player.dir, context))) + Some(pl_typ, Sprite.make(SPlayer(pl_typ, Running), player.dir, context)) } else if prev_dir != player.dir && (player.jumping && prev_jumping) { - Some((pl_typ, Sprite.make(SPlayer(pl_typ, Jumping), player.dir, context))) + Some(pl_typ, Sprite.make(SPlayer(pl_typ, Jumping), player.dir, context)) } else if player.vel.y == 0. && player.crouch { - Some((pl_typ, Sprite.make(SPlayer(pl_typ, Crouching), player.dir, context))) + Some(pl_typ, Sprite.make(SPlayer(pl_typ, Crouching), player.dir, context)) } else if player.vel.y == 0. && player.vel.x == 0. { - Some((pl_typ, Sprite.make(SPlayer(pl_typ, Standing), player.dir, context))) + Some(pl_typ, Sprite.make(SPlayer(pl_typ, Standing), player.dir, context)) } else { None } @@ -2020,7 +2020,7 @@ module Director: { o.crouch = false let player = switch Object.update_player(o, keys, state.ctx) { | None => p - | Some((new_typ, new_spr)) => + | Some(new_typ, new_spr) => Object.normalize_pos(o.pos, s.params, new_spr.params) Player(new_typ, new_spr, o) } diff --git a/tests/tests/src/unboxed_attribute.res b/tests/tests/src/unboxed_attribute.res index d1e16b75c1f..0cc4e87d866 100644 --- a/tests/tests/src/unboxed_attribute.res +++ b/tests/tests/src/unboxed_attribute.res @@ -1,4 +1,4 @@ type rec func<'a, 'b, 'i> = 'i => res<'a, 'b, 'i> @unboxed and res<'a, 'b, 'i> = Val(('b, func<'a, 'b, 'i>)) -let rec u = _ => Val((3, u)) +let rec u = _ => Val(3, u) diff --git a/tests/tests/src/variant.res b/tests/tests/src/variant.res index 0e7c9e19999..5b4aaab9d71 100644 --- a/tests/tests/src/variant.res +++ b/tests/tests/src/variant.res @@ -9,7 +9,7 @@ let b = B(34) let c = C(4, 2) -let d = D((4, 2)) +let d = D(4, 2) let foo = x => switch x { @@ -17,7 +17,7 @@ let foo = x => | A2 => 2 | B(n) => n | C(n, m) => n + m - | D((n, m)) => n + m + | D(n, m) => n + m } let fooA1 = x => @@ -83,5 +83,5 @@ let fooExn = f => | EA2 => 2 | EB(n) => n | EC(n, m) => n + m - | ED((n, m)) => n + m + | ED(n, m) => n + m } From 23602f2aba06da0d39ed2fd0291f37953ce17706 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 17:19:39 +0200 Subject: [PATCH 19/40] Simplify constructor bridge metadata handling and assertions Signed-off-by: Christoph Knittel --- compiler/ml/ast_mapper_from0.ml | 8 +++----- tests/ounit_tests/ounit_ast_mapper0_tests.ml | 12 ++++++------ 2 files changed, 9 insertions(+), 11 deletions(-) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 7002e33769a..29669ebab19 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -173,18 +173,16 @@ let has_explicit_arity_attr (attrs : Pt.attributes) = | _ -> false) attrs -let remove_internal_marker_attr ~name (attrs : Pt.attributes) = +let remove_constructor_args_attr (attrs : Pt.attributes) = let rec loop rev_attrs = function - | ({Location.txt}, Pt.PStr []) :: attrs when txt = name -> + | ({Location.txt}, Pt.PStr []) :: attrs + when txt = constructor_args_attr_name -> (true, List.rev_append rev_attrs attrs) | attr :: attrs -> loop (attr :: rev_attrs) attrs | [] -> (false, List.rev rev_attrs) in loop [] attrs -let remove_constructor_args_attr attrs = - remove_internal_marker_attr ~name:constructor_args_attr_name attrs - (* Unmarked v0 tuples remain a single syntactic payload. Typecore resolves semantic argument grouping after it knows the constructor declaration. *) let decode_args ~map ~tuple_args ~split_tuple = function diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index 244565d3468..a166ac75689 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -325,8 +325,8 @@ let test_constructor_args_roundtrip_through_ast0 _ = ~msg:"a single tuple argument does not carry bridge metadata" [] expr0.pexp_attributes; let expr = map_expr0 expr0 in - OUnit.assert_bool "a known tuple argument is not marked as legacy" - (not (has_attr "_res.legacy_constructor_payload" expr.pexp_attributes)); + OUnit.assert_equal ~msg:"tuple roundtrip preserves empty attributes" [] + expr.pexp_attributes; (match expr.pexp_desc with | Parsetree.Pexp_construct (_, [{pexp_desc = Pexp_tuple [_; _]}]) -> () | _ -> assert_failure "Expected one tuple argument after roundtrip"); @@ -438,6 +438,10 @@ let test_fresh_ast0_constructor_tuple_reprints_without_internal_metadata _ = Ast_helper0.Pat.var ~loc (Location.mknoloc "b"); ]))) in + OUnit.assert_equal ~msg:"fresh v0 expression needs no internal metadata" [] + expr.pexp_attributes; + OUnit.assert_equal ~msg:"fresh v0 pattern needs no internal metadata" [] + pat.ppat_attributes; List.iter (fun width -> let printed = @@ -448,10 +452,6 @@ let test_fresh_ast0_constructor_tuple_reprints_without_internal_metadata _ = ] ~comments:[] ~width in - OUnit.assert_bool "internal deferred-arity metadata is not printed" - (not - (Ext_string.contain_substring printed - "_res.legacy_constructor_payload")); let parsed = Res_driver.parse_implementation_from_source ~display_filename:"FreshAst0Constructor.res" ~source:printed From 3dd09af2ba45b08c2742795feb98482893841f77 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 17:19:39 +0200 Subject: [PATCH 20/40] Clarify constructor argument naming and simplify traversal Signed-off-by: Christoph Knittel --- compiler/ml/ast_iterator.ml | 8 ++++---- compiler/ml/ast_mapper.ml | 8 ++++---- compiler/ml/depend.ml | 8 ++++---- compiler/ml/printast.ml | 4 ++-- compiler/ml/typecore.ml | 16 +++++++++------- 5 files changed, 23 insertions(+), 21 deletions(-) diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index 71b285798c2..0ff7f9e8d12 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -315,9 +315,9 @@ module E = struct sub.expr sub e; sub.cases sub pel | Pexp_tuple el -> List.iter (sub.expr sub) el - | Pexp_construct (lid, arg) -> + | Pexp_construct (lid, args) -> iter_loc sub lid; - List.iter (sub.expr sub) arg + List.iter (sub.expr sub) args | Pexp_variant (_lab, args) -> List.iter (sub.expr sub) args | Pexp_record (l, eo) -> List.iter @@ -427,9 +427,9 @@ module P = struct | Ppat_constant _ -> () | Ppat_interval _ -> () | Ppat_tuple pl -> List.iter (sub.pat sub) pl - | Ppat_construct (l, p) -> + | Ppat_construct (l, args) -> iter_loc sub l; - List.iter (sub.pat sub) p + List.iter (sub.pat sub) args | Ppat_variant (_l, args) -> List.iter (sub.pat sub) args | Ppat_record (lpl, _cf, rest) -> List.iter diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 6b0407bdc4d..77e68981f66 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -316,8 +316,8 @@ module E = struct match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (List.map (sub.expr sub) arg) + | Pexp_construct (lid, args) -> + construct ~loc ~attrs (map_loc sub lid) (List.map (sub.expr sub) args) | Pexp_variant (lab, args) -> variant ~loc ~attrs lab (List.map (sub.expr sub) args) | Pexp_record (l, eo) -> @@ -424,8 +424,8 @@ module P = struct | Ppat_constant c -> constant ~loc ~attrs c | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) (List.map (sub.pat sub) p) + | Ppat_construct (l, args) -> + construct ~loc ~attrs (map_loc sub l) (List.map (sub.pat sub) args) | Ppat_variant (l, args) -> variant ~loc ~attrs l (List.map (sub.pat sub) args) | Ppat_record (lpl, cf, rest) -> diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index 0a4ad59ad6f..7c44e38c365 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -175,9 +175,9 @@ let rec add_pattern bv pat = | Ppat_alias (p, _) -> add_pattern bv p | Ppat_interval _ | Ppat_constant _ -> () | Ppat_tuple pl -> List.iter (add_pattern bv) pl - | Ppat_construct (c, op) -> + | Ppat_construct (c, args) -> add bv c; - List.iter (add_pattern bv) op + List.iter (add_pattern bv) args | Ppat_record (pl, _, rest) -> List.iter (fun {lid = lbl; x = p} -> @@ -236,9 +236,9 @@ let rec add_expr bv exp = add_expr bv e; add_cases bv pel | Pexp_tuple el -> List.iter (add_expr bv) el - | Pexp_construct (c, opte) -> + | Pexp_construct (c, args) -> add bv c; - List.iter (add_expr bv) opte + List.iter (add_expr bv) args | Pexp_variant (_, args) -> List.iter (add_expr bv) args | Pexp_record (lblel, opte) -> List.iter diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index 82ebba24b5a..b1315d57dbf 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -294,9 +294,9 @@ and expression i ppf x = | Pexp_tuple l -> line i ppf "Pexp_tuple\n"; list i expression ppf l - | Pexp_construct (li, eo) -> + | Pexp_construct (li, args) -> line i ppf "Pexp_construct %a\n" fmt_longident_loc li; - list i expression ppf eo + list i expression ppf args | Pexp_variant (l, args) -> line i ppf "Pexp_variant \"%s\"\n" l; list i expression ppf args diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index bb5148ad3cf..35aa5162b35 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -184,9 +184,11 @@ let iter_expression f e = | Pexp_match (e, pel) | Pexp_try (e, pel) -> expr e; List.iter case pel - | Pexp_array el | Pexp_tuple el -> List.iter expr el - | Pexp_construct (_, el) -> List.iter expr el - | Pexp_variant (_, args) -> List.iter expr args + | Pexp_array args + | Pexp_tuple args + | Pexp_construct (_, args) + | Pexp_variant (_, args) -> + List.iter expr args | Pexp_record (iel, eo) -> may expr eo; List.iter (fun {x = e} -> expr e) iel @@ -1216,7 +1218,7 @@ exception Need_backtrack (* The parser preserves syntactic arguments for printing. Resolve their semantic grouping only after constructor disambiguation, retaining the historical equivalence of C(a, b) and C((a, b)), including for legacy PPX output. *) -let constructor_args_of_exp_payload ~arity sargs = +let normalize_constructor_expr_args ~arity sargs = match sargs with | [{pexp_desc = Pexp_tuple args}] when arity > 1 -> args | {pexp_loc = first_loc} :: (_ :: _ as rest) when arity = 1 -> @@ -1225,7 +1227,7 @@ let constructor_args_of_exp_payload ~arity sargs = [Ast_helper.Exp.tuple ~loc sargs] | sargs -> sargs -let constructor_args_of_pat_payload ~arity sargs = +let normalize_constructor_pat_args ~arity sargs = match sargs with | [{ppat_desc = Ppat_tuple args}] when arity > 1 -> args | {ppat_loc = first_loc} :: (_ :: _ as rest) when arity = 1 -> @@ -1446,7 +1448,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp correct head *) if constr.cstr_generalized then unify_head_only loc !env expected_ty constr; let sargs = - match constructor_args_of_pat_payload ~arity:constr.cstr_arity sargs with + match normalize_constructor_pat_args ~arity:constr.cstr_arity sargs with | [({ppat_desc = Ppat_any} as sp)] when constr.cstr_arity <> 1 -> if constr.cstr_arity = 0 then Location.prerr_warning sp.ppat_loc @@ -4447,7 +4449,7 @@ and type_construct ~context env loc lid sargs ty_expected attrs = Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr; Builtin_attributes.check_deprecated loc constr.cstr_attributes constr.cstr_name; - let sargs = constructor_args_of_exp_payload ~arity:constr.cstr_arity sargs in + let sargs = normalize_constructor_expr_args ~arity:constr.cstr_arity sargs in if List.length sargs <> constr.cstr_arity then raise (Error From da1d7e07659336d1f1fcd4443b3763d23a268e31 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 17:19:39 +0200 Subject: [PATCH 21/40] Rename constructor argument compatibility fixture Signed-off-by: Christoph Knittel --- ...it_arity.mjs => constructor_arguments.mjs} | 0 ...it_arity.res => constructor_arguments.res} | 0 ...constructor_payload_compatibility_test.mjs | 22 +++++++++---------- ...constructor_payload_compatibility_test.res | 2 +- 4 files changed, 12 insertions(+), 12 deletions(-) rename tests/tests/src/{constructor_explicit_arity.mjs => constructor_arguments.mjs} (100%) rename tests/tests/src/{constructor_explicit_arity.res => constructor_arguments.res} (100%) diff --git a/tests/tests/src/constructor_explicit_arity.mjs b/tests/tests/src/constructor_arguments.mjs similarity index 100% rename from tests/tests/src/constructor_explicit_arity.mjs rename to tests/tests/src/constructor_arguments.mjs diff --git a/tests/tests/src/constructor_explicit_arity.res b/tests/tests/src/constructor_arguments.res similarity index 100% rename from tests/tests/src/constructor_explicit_arity.res rename to tests/tests/src/constructor_arguments.res diff --git a/tests/tests/src/constructor_payload_compatibility_test.mjs b/tests/tests/src/constructor_payload_compatibility_test.mjs index 984682ce07b..f0512a15f6b 100644 --- a/tests/tests/src/constructor_payload_compatibility_test.mjs +++ b/tests/tests/src/constructor_payload_compatibility_test.mjs @@ -2,24 +2,24 @@ import * as Mocha from "mocha"; import * as Test_utils from "./test_utils.mjs"; -import * as Constructor_explicit_arity from "./constructor_explicit_arity.mjs"; +import * as Constructor_arguments from "./constructor_arguments.mjs"; Mocha.describe("constructor payload compatibility", () => { Mocha.test("accepts both unary tuple spellings", () => { - Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 7, characters 7-14", Constructor_explicit_arity.readUnary(Constructor_explicit_arity.unary), 3); - Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 8, characters 7-14", Constructor_explicit_arity.readUnary(Constructor_explicit_arity.unaryUnparenthesized), 3); - Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 9, characters 7-14", Constructor_explicit_arity.readUnaryUnparenthesized(Constructor_explicit_arity.unary), 3); - Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 10, characters 7-14", Constructor_explicit_arity.readUnaryUnparenthesized(Constructor_explicit_arity.unaryUnparenthesized), 3); + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 7, characters 7-14", Constructor_arguments.readUnary(Constructor_arguments.unary), 3); + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 8, characters 7-14", Constructor_arguments.readUnary(Constructor_arguments.unaryUnparenthesized), 3); + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 9, characters 7-14", Constructor_arguments.readUnaryUnparenthesized(Constructor_arguments.unary), 3); + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 10, characters 7-14", Constructor_arguments.readUnaryUnparenthesized(Constructor_arguments.unaryUnparenthesized), 3); }); Mocha.test("accepts both binary constructor spellings", () => { - Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 13, characters 7-14", Constructor_explicit_arity.readBinary(Constructor_explicit_arity.binary), 3); - Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 14, characters 7-14", Constructor_explicit_arity.readBinary(Constructor_explicit_arity.binaryParenthesized), 3); - Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 15, characters 7-14", Constructor_explicit_arity.readBinaryParenthesized(Constructor_explicit_arity.binary), 3); - Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 16, characters 7-14", Constructor_explicit_arity.readBinaryParenthesized(Constructor_explicit_arity.binaryParenthesized), 3); + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 13, characters 7-14", Constructor_arguments.readBinary(Constructor_arguments.binary), 3); + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 14, characters 7-14", Constructor_arguments.readBinary(Constructor_arguments.binaryParenthesized), 3); + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 15, characters 7-14", Constructor_arguments.readBinaryParenthesized(Constructor_arguments.binary), 3); + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 16, characters 7-14", Constructor_arguments.readBinaryParenthesized(Constructor_arguments.binaryParenthesized), 3); }); Mocha.test("accepts unparenthesized option tuple payloads", () => { - Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 19, characters 7-14", Constructor_explicit_arity.readOptionUnparenthesized(Constructor_explicit_arity.optionUnparenthesized), 3); - Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 20, characters 7-14", Constructor_explicit_arity.readOptionUnparenthesized([ + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 19, characters 7-14", Constructor_arguments.readOptionUnparenthesized(Constructor_arguments.optionUnparenthesized), 3); + Test_utils.eq("File \"constructor_payload_compatibility_test.res\", line 20, characters 7-14", Constructor_arguments.readOptionUnparenthesized([ 1, 2 ]), 3); diff --git a/tests/tests/src/constructor_payload_compatibility_test.res b/tests/tests/src/constructor_payload_compatibility_test.res index 89a48ddbb02..5a1aa49467b 100644 --- a/tests/tests/src/constructor_payload_compatibility_test.res +++ b/tests/tests/src/constructor_payload_compatibility_test.res @@ -1,6 +1,6 @@ open Mocha open Test_utils -open Constructor_explicit_arity +open Constructor_arguments describe("constructor payload compatibility", () => { test("accepts both unary tuple spellings", () => { From d4babe2b9c10f6062130ad7316c3570c46825d3f Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 17:31:13 +0200 Subject: [PATCH 22/40] Preserve constructor argument-list locations explicitly Signed-off-by: Christoph Knittel --- CHANGELOG.md | 2 +- analysis/reanalyze/src/annotation.ml | 7 +- analysis/src/completion_expressions.ml | 21 +- analysis/src/completion_front_end.ml | 15 +- analysis/src/completion_patterns.ml | 22 +- analysis/src/dump_ast.ml | 8 +- analysis/src/process_attributes.ml | 2 +- analysis/src/signature_help.ml | 4 +- analysis/src/xform.ml | 14 +- compiler/common/pattern_printer.ml | 6 +- compiler/frontend/ast_derive_js_mapper.ml | 2 +- compiler/frontend/ast_exp_apply.ml | 26 ++- compiler/frontend/bs_builtin_ppx.ml | 34 +-- compiler/ml/ast_helper.ml | 12 +- compiler/ml/ast_helper.mli | 28 ++- compiler/ml/ast_iterator.ml | 14 +- compiler/ml/ast_mapper.ml | 45 +++- compiler/ml/ast_mapper_from0.ml | 36 +-- compiler/ml/ast_mapper_to0.ml | 32 +-- compiler/ml/ast_payload.ml | 4 +- compiler/ml/depend.ml | 10 +- compiler/ml/error_message_utils.ml | 7 +- compiler/ml/parmatch.ml | 4 +- compiler/ml/parsetree.ml | 19 +- compiler/ml/pprintast.ml | 22 +- compiler/ml/printast.ml | 8 +- compiler/ml/typecore.ml | 38 ++-- compiler/syntax/src/res_ast_debugger.ml | 8 +- compiler/syntax/src/res_comments_table.ml | 21 +- compiler/syntax/src/res_core.ml | 35 ++- compiler/syntax/src/res_parsetree_viewer.ml | 12 +- compiler/syntax/src/res_printer.ml | 15 +- tests/ounit_tests/ounit_ast_mapper0_tests.ml | 210 +++++++++++++----- .../ConstructorPayloadLocation.res | 5 + .../ConstructorPayloadLocation.res.txt | 6 + .../expressions/expected/arrow.res.txt | 7 +- .../expressions/expected/binary.res.txt | 5 +- .../expressions/expected/polyvariant.res.txt | 4 +- .../grammar/pattern/expected/constant.res.txt | 5 +- .../pattern/expected/polyvariants.res.txt | 45 ++-- .../grammar/pattern/expected/variants.res.txt | 43 ++-- .../pattern/expected/polyvariant.res.txt | 6 +- tools/src/migrate.ml | 18 +- tools/src/transforms.ml | 2 +- 44 files changed, 547 insertions(+), 342 deletions(-) create mode 100644 tests/syntax_tests/data/ast-mapping/ConstructorPayloadLocation.res create mode 100644 tests/syntax_tests/data/ast-mapping/expected/ConstructorPayloadLocation.res.txt diff --git a/CHANGELOG.md b/CHANGELOG.md index be8d45caeed..94537860f15 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -79,7 +79,7 @@ - Record a record field's `@as` rename on the declaration instead of re-reading the attribute, so every place that needs the runtime name reads one field. https://github.com/rescript-lang/rescript/pull/8619 - Record a variant constructor's `@as` tag on the declaration instead of re-interpreting its attributes, keeping the source spelling for printing. https://github.com/rescript-lang/rescript/pull/8619 - Optimization passes now return the term they were given when they change nothing, rather than rebuilding an identical one. https://github.com/rescript-lang/rescript/pull/8620 -- Remove separate parser modes for printing and type checking by preserving syntactic constructor arguments in the parsetree and resolving their semantic grouping during type checking. Existing constructor spellings and legacy PPX output remain supported. https://github.com/rescript-lang/rescript/pull/8610 +- Remove separate parser modes for printing and type checking by preserving syntactic constructor arguments and their source locations in the parsetree and resolving their semantic grouping during type checking. Existing constructor spellings and legacy PPX output remain supported. https://github.com/rescript-lang/rescript/pull/8610 - Merge the duplicate Lam intermediate representation into Lambda, removing the conversion layer and obsolete supporting infrastructure. Lambda is now a single private, normalized representation, with generated JavaScript remaining semantically unchanged. https://github.com/rescript-lang/rescript/pull/8608 - Add genType and source map controls and output to the developer playground. https://github.com/rescript-lang/rescript/pull/8448 - Rework the object-type representation end to end: object rows are plain field chains carrying a per-field mutability state (no phantom setter members), object literals are typed directly and property access and assignment are first-class AST and Lambda nodes shared between the Lambda and JS pipelines, and dead class-system remnants (the field-presence lattice, the class-abbreviation memo on object types, method-send typing) are removed. https://github.com/rescript-lang/rescript/pull/8597 diff --git a/analysis/reanalyze/src/annotation.ml b/analysis/reanalyze/src/annotation.ml index 78508436050..5f60b5c3037 100644 --- a/analysis/reanalyze/src/annotation.ml +++ b/analysis/reanalyze/src/annotation.ml @@ -30,9 +30,12 @@ let rec get_attribute_payload check_text (attributes : Typedtree.attributes) = _; } -> Some (BoolPayload (s = "true")) - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, [])} -> None + | {pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, {txt = []})} + -> + None | { - pexp_desc = Pexp_construct ({txt = Longident.Lident "::"}, [head; tail]); + pexp_desc = + Pexp_construct ({txt = Longident.Lident "::"}, {txt = [head; tail]}); } -> from_expr {expr with pexp_desc = Pexp_tuple [head; tail]} | {pexp_desc = Pexp_construct ({txt}, _); _} -> diff --git a/analysis/src/completion_expressions.ml b/analysis/src/completion_expressions.ml index 23f52561e16..43f59884003 100644 --- a/analysis/src/completion_expressions.ml +++ b/analysis/src/completion_expressions.ml @@ -24,9 +24,10 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos (txt, [Completable.NRecordBody {seen_fields = []}] @ expr_path) | Pexp_ident {txt = Lident txt} -> some_if_has_cursor (txt, expr_path) | Pexp_construct ({txt = Lident "()"}, _) -> some_if_has_cursor ("", expr_path) - | Pexp_construct ({txt = Lident txt}, []) -> + | Pexp_construct ({txt = Lident txt}, {txt = []}) -> some_if_has_cursor (txt, expr_path) - | Pexp_variant (label, []) -> some_if_has_cursor ("#" ^ label, expr_path) + | Pexp_variant (label, {txt = []}) -> + some_if_has_cursor ("#" ^ label, expr_path) | Pexp_array array_patterns -> ( let next_expr_path = [Completable.NArray] @ expr_path in (* No fields but still has cursor = empty completion *) @@ -121,7 +122,10 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos ("", [Completable.NRecordBody {seen_fields}] @ expr_path) | _ -> None)) | Pexp_construct - ({txt}, [{pexp_loc; pexp_desc = Pexp_construct ({txt = Lident "()"}, _)}]) + ( {txt}, + { + txt = [{pexp_loc; pexp_desc = Pexp_construct ({txt = Lident "()"}, _)}]; + } ) when loc_has_cursor pexp_loc -> (* Empty payload with cursor, like: Test() *) Some @@ -131,7 +135,7 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos {constructor_name = Utils.get_unqualified_name txt; item_num = 0}; ] @ expr_path ) - | Pexp_construct ({txt}, args) + | Pexp_construct ({txt}, {txt = args}) when args <> [] && pos >= ((Ext_list.last args).pexp_loc |> Loc.end_) && first_char_before_cursor_no_white = Some ',' @@ -147,7 +151,7 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos }; ] @ expr_path ) - | Pexp_construct ({txt}, args) when loc_has_cursor exp.pexp_loc -> + | Pexp_construct ({txt}, {txt = args}) when loc_has_cursor exp.pexp_loc -> args |> traverse_expr_tuple_items ~first_char_before_cursor_no_white ~pos ~next_expr_path:(fun item_num -> @@ -166,14 +170,17 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos ] @ expr_path) | Pexp_variant - (txt, [{pexp_loc; pexp_desc = Pexp_construct ({txt = Lident "()"}, _)}]) + ( txt, + { + txt = [{pexp_loc; pexp_desc = Pexp_construct ({txt = Lident "()"}, _)}]; + } ) when loc_has_cursor pexp_loc -> (* Empty payload with cursor, like: #test() *) Some ( "", [Completable.NPolyvariantPayload {constructor_name = txt; item_num = 0}] @ expr_path ) - | Pexp_variant (txt, args) when loc_has_cursor exp.pexp_loc -> + | Pexp_variant (txt, {txt = args}) when loc_has_cursor exp.pexp_loc -> args |> traverse_expr_tuple_items ~first_char_before_cursor_no_white ~pos ~next_expr_path:(fun item_num -> diff --git a/analysis/src/completion_front_end.ml b/analysis/src/completion_front_end.ml index 994b5a84a53..992074d6e4b 100644 --- a/analysis/src/completion_front_end.ml +++ b/analysis/src/completion_front_end.ml @@ -222,7 +222,8 @@ let rec expr_to_context_path_inner ~(in_jsx_context : bool) | None -> None) | Pexp_constant (Pconst_integer _) -> Some CPInt | Pexp_constant (Pconst_float _) -> Some CPFloat - | Pexp_construct ({txt = Lident ("true" | "false")}, []) -> Some CPBool + | Pexp_construct ({txt = Lident ("true" | "false")}, {txt = []}) -> + Some CPBool | Pexp_array exprs -> Some (CPArray @@ -492,8 +493,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file scope_pattern p ~pattern_path:(NTupleItem {item_num = index} :: pattern_path) ?context_path) - | Ppat_construct (_, []) -> () - | Ppat_construct ({txt}, patterns) -> + | Ppat_construct (_, {txt = []}) -> () + | Ppat_construct ({txt}, {txt = patterns}) -> patterns |> List.iteri (fun index p -> scope_pattern p @@ -505,8 +506,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file } :: pattern_path) ?context_path) - | Ppat_variant (_, []) -> () - | Ppat_variant (txt, patterns) -> + | Ppat_variant (_, {txt = []}) -> () + | Ppat_variant (txt, {txt = patterns}) -> patterns |> List.iteri (fun index p -> scope_pattern p @@ -1036,7 +1037,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file Pstr_eval ( { pexp_loc; - pexp_desc = Pexp_construct ({txt = path; loc}, []); + pexp_desc = Pexp_construct ({txt = path; loc}, {txt = []}); }, _ ); }; @@ -1276,7 +1277,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file then ValueOrField else Value); })) - | Pexp_construct (lid, args) -> + | Pexp_construct (lid, {txt = args}) -> let lid_path = flatten_lid_check_dot lid in if debug then Printf.printf "Pexp_construct %s:%s %s\n" diff --git a/analysis/src/completion_patterns.ml b/analysis/src/completion_patterns.ml index f52b3dcef2a..99149a3b728 100644 --- a/analysis/src/completion_patterns.ml +++ b/analysis/src/completion_patterns.ml @@ -86,14 +86,14 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor lot. *) some_if_has_cursor ("", pattern_path) "Ppat_any" | Ppat_var {txt} -> some_if_has_cursor (txt, pattern_path) "Ppat_var" - | Ppat_construct ({txt = Lident "()"}, []) -> + | Ppat_construct ({txt = Lident "()"}, {txt = []}) -> (* switch s { | () }*) some_if_has_cursor ("", pattern_path @ [Completable.NTupleItem {item_num = 0}]) "Ppat_construct()" - | Ppat_construct ({txt = Lident prefix}, []) -> + | Ppat_construct ({txt = Lident prefix}, {txt = []}) -> some_if_has_cursor (prefix, pattern_path) "Ppat_construct(Lident)" - | Ppat_variant (prefix, []) -> + | Ppat_variant (prefix, {txt = []}) -> some_if_has_cursor ("#" ^ prefix, pattern_path) "Ppat_variant" | Ppat_array array_patterns -> let next_pattern_path = [Completable.NArray] @ pattern_path in @@ -179,7 +179,10 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor "firstCharBeforeCursorNoWhite:," | _ -> None)) | Ppat_construct - ({txt}, [{ppat_loc; ppat_desc = Ppat_construct ({txt = Lident "()"}, _)}]) + ( {txt}, + { + txt = [{ppat_loc; ppat_desc = Ppat_construct ({txt = Lident "()"}, _)}]; + } ) when loc_has_cursor ppat_loc -> (* Empty payload with cursor, like: Test() *) Some @@ -189,7 +192,7 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor {constructor_name = Utils.get_unqualified_name txt; item_num = 0}; ] @ pattern_path ) - | Ppat_construct ({txt}, patterns) + | Ppat_construct ({txt}, {txt = patterns}) when patterns <> [] && pos_before_cursor >= ((Ext_list.last patterns).ppat_loc |> Loc.end_) && first_char_before_cursor_no_white = Some ',' @@ -205,7 +208,7 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor }; ] @ pattern_path ) - | Ppat_construct ({txt}, patterns) when loc_has_cursor pat.ppat_loc -> + | Ppat_construct ({txt}, {txt = patterns}) when loc_has_cursor pat.ppat_loc -> patterns |> traverse_tuple_items ~loc_has_cursor ~first_char_before_cursor_no_white ~pos_before_cursor @@ -225,14 +228,17 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor ] @ pattern_path) | Ppat_variant - (txt, [{ppat_loc; ppat_desc = Ppat_construct ({txt = Lident "()"}, _)}]) + ( txt, + { + txt = [{ppat_loc; ppat_desc = Ppat_construct ({txt = Lident "()"}, _)}]; + } ) when loc_has_cursor ppat_loc -> (* Empty payload with cursor, like: #test() *) Some ( "", [Completable.NPolyvariantPayload {constructor_name = txt; item_num = 0}] @ pattern_path ) - | Ppat_variant (txt, patterns) when loc_has_cursor pat.ppat_loc -> + | Ppat_variant (txt, {txt = patterns}) when loc_has_cursor pat.ppat_loc -> patterns |> traverse_tuple_items ~loc_has_cursor ~first_char_before_cursor_no_white ~pos_before_cursor diff --git a/analysis/src/dump_ast.ml b/analysis/src/dump_ast.ml index 34391a1aba6..aa30c5d4610 100644 --- a/analysis/src/dump_ast.ml +++ b/analysis/src/dump_ast.ml @@ -98,7 +98,7 @@ let rec print_pattern pattern ~pos ~indentation = | Ppat_var ({txt} as loc) -> "Ppat_var(" ^ (loc |> print_loc_denominator_loc ~pos) ^ txt ^ ")" | Ppat_constant const -> "Ppat_constant(" ^ print_constant const ^ ")" - | Ppat_construct (({txt} as loc), patterns) -> + | Ppat_construct (({txt} as loc), {txt = patterns}) -> "Ppat_construct(" ^ (loc |> print_loc_denominator_loc ~pos) ^ (Utils.flatten_long_ident txt |> ident |> str) @@ -106,7 +106,7 @@ let rec print_pattern pattern ~pos ~indentation = |> List.map (fun pat -> "," ^ print_pattern pat ~pos ~indentation) |> String.concat "") ^ ")" - | Ppat_variant (label, patterns) -> + | Ppat_variant (label, {txt = patterns}) -> "Ppat_variant(" ^ str label ^ (patterns |> List.map (fun pat -> "," ^ print_pattern pat ~pos ~indentation) @@ -231,7 +231,7 @@ and print_expr_item expr ~pos ~indentation = ^ add_indentation indentation ^ ")" | Pexp_constant constant -> "Pexp_constant(" ^ print_constant constant ^ ")" - | Pexp_construct (({txt} as loc), exprs) -> + | Pexp_construct (({txt} as loc), {txt = exprs}) -> "Pexp_construct(" ^ (loc |> print_loc_denominator_loc ~pos) ^ (Utils.flatten_long_ident txt |> ident |> str) @@ -239,7 +239,7 @@ and print_expr_item expr ~pos ~indentation = |> List.map (fun expr -> ", " ^ print_expr_item expr ~pos ~indentation) |> String.concat "") ^ ")" - | Pexp_variant (label, exprs) -> + | Pexp_variant (label, {txt = exprs}) -> "Pexp_variant(" ^ str label ^ (exprs |> List.map (fun expr -> "," ^ print_expr_item expr ~pos ~indentation) diff --git a/analysis/src/process_attributes.ml b/analysis/src/process_attributes.ml index 068784416b8..10ce3508a43 100644 --- a/analysis/src/process_attributes.ml +++ b/analysis/src/process_attributes.ml @@ -69,7 +69,7 @@ let rec find_editor_complete_from_attribute ?(module_paths = []) attributes = items |> List.filter_map (fun item -> match item.Parsetree.pexp_desc with - | Pexp_construct ({txt = path}, []) -> + | Pexp_construct ({txt = path}, {txt = []}) -> Some (Utils.flatten_long_ident path) | _ -> None) in diff --git a/analysis/src/signature_help.ml b/analysis/src/signature_help.ml index f96c5a7378e..3b54033e5a7 100644 --- a/analysis/src/signature_help.ml +++ b/analysis/src/signature_help.ml @@ -416,7 +416,7 @@ let signature_help ~debug ~source ~kind_file ~pos in set_result (exp.pexp_loc, `FunctionCall (arg_at_cursor, exp, extracted_args)) - | {pexp_desc = Pexp_construct (lid, payload_exps); pexp_loc} + | {pexp_desc = Pexp_construct (lid, {txt = payload_exps}); pexp_loc} when payload_exps <> [] && constructor_has_cursor lid.loc pexp_loc -> (* Constructor payloads *) set_result (lid.loc, `ConstructorExpr (lid, payload_exps)) @@ -425,7 +425,7 @@ let signature_help ~debug ~source ~kind_file ~pos in let pat (iterator : Ast_iterator.iterator) (pat : Parsetree.pattern) = (match pat with - | {ppat_desc = Ppat_construct (lid, payload_pats); ppat_loc} + | {ppat_desc = Ppat_construct (lid, {txt = payload_pats}); ppat_loc} when payload_pats <> [] && constructor_has_cursor lid.loc ppat_loc -> (* Constructor payloads *) set_result (lid.loc, `ConstructorPat (lid, payload_pats)) diff --git a/analysis/src/xform.ml b/analysis/src/xform.ml index 56934158bc9..3ea35b09cf3 100644 --- a/analysis/src/xform.ml +++ b/analysis/src/xform.ml @@ -55,14 +55,16 @@ module If_then_else = struct Ast_helper.Pat.mk ~loc:exp.pexp_loc ~attrs:exp.pexp_attributes ppat_desc in match exp.pexp_desc with - | Pexp_construct (lid, exprs) -> ( + | Pexp_construct (lid, {txt = exprs; loc}) -> ( match list_to_pat ~item_to_pat:exp_to_pat exprs with | None -> None - | Some patterns -> Some (mk_pat (Ppat_construct (lid, patterns)))) - | Pexp_variant (label, exprs) -> ( + | Some patterns -> + Some (mk_pat (Ppat_construct (lid, {txt = patterns; loc})))) + | Pexp_variant (label, {txt = exprs; loc}) -> ( match list_to_pat ~item_to_pat:exp_to_pat exprs with | None -> None - | Some patterns -> Some (mk_pat (Ppat_variant (label, patterns)))) + | Some patterns -> + Some (mk_pat (Ppat_variant (label, {txt = patterns; loc})))) | Pexp_constant c -> Some (mk_pat (Ppat_constant c)) | Pexp_template {source_segments = [{txt = source}]; values = []} -> ( match String_literal.decode_js_template_escapes source with @@ -406,8 +408,8 @@ module Expand_catch_all_for_variants = struct ?(mode : [`option | `default] = `default) ?(constructor_names = []) (p : Parsetree.pattern) = match p.ppat_desc with - | Ppat_construct ({txt = Lident "Some"}, [payload]) when mode = `option - -> + | Ppat_construct ({txt = Lident "Some"}, {txt = [payload]}) + when mode = `option -> find_all_constructor_names ~mode ~constructor_names payload | Ppat_construct ({txt}, _) -> Longident.last txt :: constructor_names | Ppat_variant (name, _) -> name :: constructor_names diff --git a/compiler/common/pattern_printer.ml b/compiler/common/pattern_printer.ml index aa2bcf5f5b0..2745fce6dba 100644 --- a/compiler/common/pattern_printer.ml +++ b/compiler/common/pattern_printer.ml @@ -47,7 +47,7 @@ let[@warning "-4"] rec classify_optional_field_state pat = | _ -> Field_normal let none_pattern = - mkpat (Ppat_construct (mknoloc (Longident.Lident "None"), [])) + mkpat (Ppat_construct (mknoloc (Longident.Lident "None"), mknoloc [])) let[@warning "-4"] strip_synthetic_some pat = match pat.pat_desc with @@ -71,14 +71,14 @@ let untype typed = | Tpat_tuple lst -> mkpat (Ppat_tuple (List.map loop lst)) | Tpat_construct (cstr_lid, cstr, lst) -> let lid = {cstr_lid with txt = Longident.Lident cstr.cstr_name} in - mkpat (Ppat_construct (lid, List.map loop lst)) + mkpat (Ppat_construct (lid, mknoloc (List.map loop lst))) | Tpat_variant (label, p_opt, _row_desc) -> let args = match p_opt with | None -> [] | Some p -> [loop p] in - mkpat (Ppat_variant (label, args)) + mkpat (Ppat_variant (label, mknoloc args)) | Tpat_record (subpatterns, closed_flag, rest) -> let fields, saw_optional_rewrite = List.fold_right diff --git a/compiler/frontend/ast_derive_js_mapper.ml b/compiler/frontend/ast_derive_js_mapper.ml index ea0410bf519..5b66a361243 100644 --- a/compiler/frontend/ast_derive_js_mapper.ml +++ b/compiler/frontend/ast_derive_js_mapper.ml @@ -50,7 +50,7 @@ let handle_config (config : Parsetree.expression option) = { pexp_desc = ( Pexp_construct - ({txt = Lident (("true" | "false") as x)}, []) + ({txt = Lident (("true" | "false") as x)}, {txt = []}) | Pexp_ident {txt = Lident ("newType" as x)} ); }; }; diff --git a/compiler/frontend/ast_exp_apply.ml b/compiler/frontend/ast_exp_apply.ml index c857031c886..b3f7614cbd5 100644 --- a/compiler/frontend/ast_exp_apply.ml +++ b/compiler/frontend/ast_exp_apply.ml @@ -80,10 +80,18 @@ let app_exp_mapper (e : exp) (self : Ast_mapper.mapper) : exp = let a = self.expr self a_ in let f = self.expr self f_ in match f.pexp_desc with - | Pexp_variant (label, []) -> - {f with pexp_desc = Pexp_variant (label, [a]); pexp_loc = e.pexp_loc} - | Pexp_construct (ctor, []) -> - {f with pexp_desc = Pexp_construct (ctor, [a]); pexp_loc = e.pexp_loc} + | Pexp_variant (label, {txt = []}) -> + { + f with + pexp_desc = Pexp_variant (label, {txt = [a]; loc = a.pexp_loc}); + pexp_loc = e.pexp_loc; + } + | Pexp_construct (ctor, {txt = []}) -> + { + f with + pexp_desc = Pexp_construct (ctor, {txt = [a]; loc = a.pexp_loc}); + pexp_loc = e.pexp_loc; + } | Pexp_apply {funct = fn1; args; partial; transformed_jsx} -> Bs_ast_invariant.warn_discarded_unused_attributes fn1.pexp_attributes; { @@ -100,10 +108,16 @@ let app_exp_mapper (e : exp) (self : Ast_mapper.mapper) : exp = Pexp_tuple (Ext_list.map xs (fun fn -> match fn.pexp_desc with - | Pexp_construct (ctor, []) -> + | Pexp_construct (ctor, {txt = []}) -> { fn with - pexp_desc = Pexp_construct (ctor, [bounded_obj_arg]); + pexp_desc = + Pexp_construct + ( ctor, + { + txt = [bounded_obj_arg]; + loc = bounded_obj_arg.pexp_loc; + } ); } | Pexp_apply {funct = fn; args; transformed_jsx} -> Bs_ast_invariant.warn_discarded_unused_attributes diff --git a/compiler/frontend/bs_builtin_ppx.ml b/compiler/frontend/bs_builtin_ppx.ml index 6782c191b82..b28e8de53cb 100644 --- a/compiler/frontend/bs_builtin_ppx.ml +++ b/compiler/frontend/bs_builtin_ppx.ml @@ -164,12 +164,14 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) ( b, [ { - pc_lhs = {ppat_desc = Ppat_construct ({txt = Lident "true"}, [])}; + pc_lhs = + {ppat_desc = Ppat_construct ({txt = Lident "true"}, {txt = []})}; pc_guard = None; pc_rhs = t_exp; }; { - pc_lhs = {ppat_desc = Ppat_construct ({txt = Lident "false"}, [])}; + pc_lhs = + {ppat_desc = Ppat_construct ({txt = Lident "false"}, {txt = []})}; pc_guard = None; pc_rhs = f_exp; }; @@ -178,12 +180,14 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) ( b, [ { - pc_lhs = {ppat_desc = Ppat_construct ({txt = Lident "false"}, [])}; + pc_lhs = + {ppat_desc = Ppat_construct ({txt = Lident "false"}, {txt = []})}; pc_guard = None; pc_rhs = f_exp; }; { - pc_lhs = {ppat_desc = Ppat_construct ({txt = Lident "true"}, [])}; + pc_lhs = + {ppat_desc = Ppat_construct ({txt = Lident "true"}, {txt = []})}; pc_guard = None; pc_rhs = t_exp; }; @@ -204,13 +208,13 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) { ppat_desc = ( Ppat_construct - ({txt = Lident ("Ok" as variant_name)}, _ :: _) + ({txt = Lident ("Ok" as variant_name)}, {txt = _ :: _}) + | Ppat_construct + ({txt = Lident ("Error" as variant_name)}, {txt = _ :: _}) | Ppat_construct - ({txt = Lident ("Error" as variant_name)}, _ :: _) + ({txt = Lident ("Some" as variant_name)}, {txt = _ :: _}) | Ppat_construct - ({txt = Lident ("Some" as variant_name)}, _ :: _) - | Ppat_construct ({txt = Lident ("None" as variant_name)}, []) - ); + ({txt = Lident ("None" as variant_name)}, {txt = []}) ); } as pvb_pat; pvb_expr; pvb_constraint = None; @@ -245,7 +249,7 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) (* Extract the variable name from the pattern (e.g., myVar from Some(myVar)) *) let var_name = match pvb_pat.ppat_desc with - | Ppat_construct (_, [inner_pat]) -> ( + | Ppat_construct (_, {txt = [inner_pat]}) -> ( match Ast_pat.is_single_variable_pattern_conservative inner_pat with | Some name when name <> "" -> name | _ -> "x") @@ -501,7 +505,8 @@ let signature_item_mapper (self : mapper) (sigi : Parsetree.signature_item) : pval_attributes = []; }; } - | Pexp_construct ({txt = Lident (("true" | "false") as txt)}, []) -> + | Pexp_construct ({txt = Lident (("true" | "false") as txt)}, {txt = []}) + -> succeed attr pval_attributes; { sigi with @@ -616,8 +621,9 @@ let structure_item_mapper (self : mapper) (str : Parsetree.structure_item) : pval_prim = Some (Ast_external_mk.inline_float s); }; } - | Some attr, Pexp_construct ({txt = Lident (("true" | "false") as txt)}, []) - -> + | ( Some attr, + Pexp_construct ({txt = Lident (("true" | "false") as txt)}, {txt = []}) + ) -> succeed attr pvb_attributes; { str with @@ -797,7 +803,7 @@ let rec structure_mapper ~await_context (self : mapper) (stru : Ast_structure.t) | Pexp_let (_, vbs, expr) -> aux expr @ spelunk_vbs acc vbs | Pexp_ifthenelse (_, then_expr, Some else_expr) -> aux then_expr @ aux else_expr - | Pexp_construct (_, [expr]) -> aux expr + | Pexp_construct (_, {txt = [expr]}) -> aux expr | Pexp_fun {body = expr} -> aux expr | Pexp_constraint (expr, _) -> aux expr | Pexp_match (expr, cases) -> diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index a02227e71eb..1b7d54ae57f 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -146,8 +146,10 @@ module Pat = struct let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) + let construct ?(loc = !default_loc) ?attrs ?(args_loc = loc) a b = + mk ~loc ?attrs (Ppat_construct (a, {txt = b; loc = args_loc})) + let variant ?(loc = !default_loc) ?attrs ?(args_loc = loc) a b = + mk ~loc ?attrs (Ppat_variant (a, {txt = b; loc = args_loc})) let record ?loc ?attrs ?rest a b = mk ?loc ?attrs (Ppat_record (a, b, rest)) let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) @@ -179,8 +181,10 @@ module Exp = struct let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) - let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) + let construct ?(loc = !default_loc) ?attrs ?(args_loc = loc) a b = + mk ~loc ?attrs (Pexp_construct (a, {txt = b; loc = args_loc})) + let variant ?(loc = !default_loc) ?attrs ?(args_loc = loc) a b = + mk ~loc ?attrs (Pexp_variant (a, {txt = b; loc = args_loc})) let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index f423e3de368..c55904a839d 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -97,8 +97,18 @@ module Pat : sig val constant : ?loc:loc -> ?attrs:attrs -> constant -> pattern val interval : ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern val tuple : ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - val construct : ?loc:loc -> ?attrs:attrs -> lid -> pattern list -> pattern - val variant : ?loc:loc -> ?attrs:attrs -> label -> pattern list -> pattern + + (* [args_loc] spans the argument parentheses. It defaults to [loc] for + generated nodes or constructors without an argument list. *) + val construct : + ?loc:loc -> ?attrs:attrs -> ?args_loc:loc -> lid -> pattern list -> pattern + val variant : + ?loc:loc -> + ?attrs:attrs -> + ?args_loc:loc -> + label -> + pattern list -> + pattern val record : ?loc:loc -> ?attrs:attrs -> @@ -153,9 +163,19 @@ module Exp : sig val try_ : ?loc:loc -> ?attrs:attrs -> expression -> case list -> expression val tuple : ?loc:loc -> ?attrs:attrs -> expression list -> expression val construct : - ?loc:loc -> ?attrs:attrs -> lid -> expression list -> expression + ?loc:loc -> + ?attrs:attrs -> + ?args_loc:loc -> + lid -> + expression list -> + expression val variant : - ?loc:loc -> ?attrs:attrs -> label -> expression list -> expression + ?loc:loc -> + ?attrs:attrs -> + ?args_loc:loc -> + label -> + expression list -> + expression val record : ?loc:loc -> ?attrs:attrs -> diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index 0ff7f9e8d12..a4b6fa9cd62 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -315,10 +315,13 @@ module E = struct sub.expr sub e; sub.cases sub pel | Pexp_tuple el -> List.iter (sub.expr sub) el - | Pexp_construct (lid, args) -> + | Pexp_construct (lid, {txt = args; loc = args_loc}) -> iter_loc sub lid; + sub.location sub args_loc; + List.iter (sub.expr sub) args + | Pexp_variant (_lab, {txt = args; loc = args_loc}) -> + sub.location sub args_loc; List.iter (sub.expr sub) args - | Pexp_variant (_lab, args) -> List.iter (sub.expr sub) args | Pexp_record (l, eo) -> List.iter (fun {lid; x = exp} -> @@ -427,10 +430,13 @@ module P = struct | Ppat_constant _ -> () | Ppat_interval _ -> () | Ppat_tuple pl -> List.iter (sub.pat sub) pl - | Ppat_construct (l, args) -> + | Ppat_construct (l, {txt = args; loc = args_loc}) -> iter_loc sub l; + sub.location sub args_loc; + List.iter (sub.pat sub) args + | Ppat_variant (_l, {txt = args; loc = args_loc}) -> + sub.location sub args_loc; List.iter (sub.pat sub) args - | Ppat_variant (_l, args) -> List.iter (sub.pat sub) args | Ppat_record (lpl, _cf, rest) -> List.iter (fun {lid; x = pat} -> diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 77e68981f66..324cac02c9a 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -316,10 +316,16 @@ module E = struct match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, args) -> - construct ~loc ~attrs (map_loc sub lid) (List.map (sub.expr sub) args) - | Pexp_variant (lab, args) -> - variant ~loc ~attrs lab (List.map (sub.expr sub) args) + | Pexp_construct (lid, {txt = args; loc = args_loc}) -> + construct ~loc ~attrs + ~args_loc:(sub.location sub args_loc) + (map_loc sub lid) + (List.map (sub.expr sub) args) + | Pexp_variant (lab, {txt = args; loc = args_loc}) -> + variant ~loc ~attrs + ~args_loc:(sub.location sub args_loc) + lab + (List.map (sub.expr sub) args) | Pexp_record (l, eo) -> record ~loc ~attrs (List.map @@ -424,10 +430,16 @@ module P = struct | Ppat_constant c -> constant ~loc ~attrs c | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, args) -> - construct ~loc ~attrs (map_loc sub l) (List.map (sub.pat sub) args) - | Ppat_variant (l, args) -> - variant ~loc ~attrs l (List.map (sub.pat sub) args) + | Ppat_construct (l, {txt = args; loc = args_loc}) -> + construct ~loc ~attrs + ~args_loc:(sub.location sub args_loc) + (map_loc sub l) + (List.map (sub.pat sub) args) + | Ppat_variant (l, {txt = args; loc = args_loc}) -> + variant ~loc ~attrs + ~args_loc:(sub.location sub args_loc) + l + (List.map (sub.pat sub) args) | Ppat_record (lpl, cf, rest) -> record ~loc ~attrs ?rest: @@ -671,9 +683,14 @@ module Ppx_context = struct name and get_bool pexp = match pexp with - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, [])} -> + | { + pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, {txt = []}); + } -> true - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "false"}, [])} -> + | { + pexp_desc = + Pexp_construct ({txt = Longident.Lident "false"}, {txt = []}); + } -> false | _ -> raise_errorf @@ -682,10 +699,14 @@ module Ppx_context = struct and get_list elem = function | { pexp_desc = - Pexp_construct ({txt = Longident.Lident "::"}, [exp; rest]); + Pexp_construct ({txt = Longident.Lident "::"}, {txt = [exp; rest]}); } -> elem exp :: get_list elem rest - | {pexp_desc = Pexp_construct ({txt = Longident.Lident "[]"}, [])} -> [] + | { + pexp_desc = + Pexp_construct ({txt = Longident.Lident "[]"}, {txt = []}); + } -> + [] | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context { %s }] list syntax" diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 29669ebab19..1c357c466e2 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -875,6 +875,11 @@ module E = struct jsx_fragment ~loc ~attrs loc.loc_start (map_jsx_children sub e) loc.loc_end | Pexp_construct (lid, arg) -> ( + let args_loc = + match arg with + | Some arg -> sub.location sub arg.pexp_loc + | None -> loc + in let lid1 = map_loc sub lid in let has_constructor_args, attrs = remove_constructor_args_attr attrs in let args = @@ -889,7 +894,7 @@ module E = struct || lid.txt = Longident.Lident "::") arg in - let exp1 = construct ~loc ~attrs lid1 args in + let exp1 = construct ~loc ~attrs ~args_loc lid1 args in match lid.txt with | Lident "Function$" -> ( let rec attributes_to_arity (attrs : Parsetree.attributes) = @@ -948,13 +953,10 @@ module E = struct | _ -> exp1) | Pexp_variant (lab, arg) -> let has_constructor_args, attrs = remove_constructor_args_attr attrs in - let attrs = + let args_loc = match arg with - | Some {pexp_desc = Pexp_tuple _; pexp_loc} when has_constructor_args -> - ( Location.mkloc "res.variantArgs" (sub.location sub pexp_loc), - Pt.PStr [] ) - :: attrs - | _ -> attrs + | Some arg -> sub.location sub arg.pexp_loc + | None -> loc in let args = decode_args ~map:(sub.expr sub) @@ -964,7 +966,7 @@ module E = struct | _ -> None) ~split_tuple:has_constructor_args arg in - variant ~loc ~attrs lab args + variant ~loc ~attrs ~args_loc lab args | Pexp_record (l, eo) -> record ~loc ~attrs (Ext_list.map l (fun (lid, e) -> @@ -1132,6 +1134,11 @@ module P = struct (map_pattern_constant ~loc c2) | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) | Ppat_construct (l, arg) -> + let args_loc = + match arg with + | Some arg -> sub.location sub arg.ppat_loc + | None -> loc + in let has_constructor_args, attrs = remove_constructor_args_attr attrs in let args = decode_args ~map:(sub.pat sub) @@ -1145,16 +1152,13 @@ module P = struct || l.txt = Longident.Lident "::") arg in - construct ~loc ~attrs (map_loc sub l) args + construct ~loc ~attrs ~args_loc (map_loc sub l) args | Ppat_variant (l, arg) -> let has_constructor_args, attrs = remove_constructor_args_attr attrs in - let attrs = + let args_loc = match arg with - | Some {ppat_desc = Ppat_tuple _; ppat_loc} when has_constructor_args -> - ( Location.mkloc "res.variantArgs" (sub.location sub ppat_loc), - Pt.PStr [] ) - :: attrs - | _ -> attrs + | Some arg -> sub.location sub arg.ppat_loc + | None -> loc in let args = decode_args ~map:(sub.pat sub) @@ -1164,7 +1168,7 @@ module P = struct | _ -> None) ~split_tuple:has_constructor_args arg in - variant ~loc ~attrs l args + variant ~loc ~attrs ~args_loc l args | Ppat_record (lpl, cf) -> let rest, attrs = get_record_rest_attr attrs in record ~loc ~attrs ?rest diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 6d98afde974..8855aebdb1d 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -118,17 +118,6 @@ let encode_args ~map ~tuple ~loc ~attrs args = | [arg] -> (Some arg, attrs) | args -> (Some (tuple ~loc args), add_constructor_args_attr attrs) -(* The argument list no longer has a tuple node to carry its parentheses span. - Consume the parser's location metadata when rebuilding that v0 node. *) -let variant_args_loc ~loc attrs = - let rec loop rev_attrs = function - | ({Location.txt = "res.variantArgs"; loc}, Pt.PStr []) :: attrs -> - (loc, List.rev_append rev_attrs attrs) - | attr :: attrs -> loop (attr :: rev_attrs) attrs - | [] -> (loc, List.rev rev_attrs) - in - loop [] attrs - let add_record_rest_attr ~rest attrs = (Location.mknoloc record_rest_attr_name, Pt.PPat (rest, None)) :: attrs @@ -587,20 +576,17 @@ module E = struct match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) - | Pexp_construct (lid, args) -> + | Pexp_construct (lid, {txt = args; loc = args_loc}) -> let lid = map_loc sub lid in - let args_loc = - if lid.loc.loc_ghost then loc - else {loc with loc_start = lid.loc.loc_end} - in + let args_loc = sub.location sub args_loc in let arg, attrs = encode_args ~map:(sub.expr sub) ~tuple:(fun ~loc args -> Ast_helper0.Exp.tuple ~loc args) ~loc:args_loc ~attrs args in construct ~loc ~attrs lid arg - | Pexp_variant (lab, args) -> - let args_loc, attrs = variant_args_loc ~loc attrs in + | Pexp_variant (lab, {txt = args; loc = args_loc}) -> + let args_loc = sub.location sub args_loc in let arg, attrs = encode_args ~map:(sub.expr sub) ~tuple:(fun ~loc args -> Ast_helper0.Exp.tuple ~loc args) @@ -840,19 +826,17 @@ module P = struct | Ppat_interval (c1, c2) -> interval ~loc ~attrs (map_constant c1) (map_constant c2) | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) - | Ppat_construct (l, args) -> + | Ppat_construct (l, {txt = args; loc = args_loc}) -> let l = map_loc sub l in - let args_loc = - if l.loc.loc_ghost then loc else {loc with loc_start = l.loc.loc_end} - in + let args_loc = sub.location sub args_loc in let arg, attrs = encode_args ~map:(sub.pat sub) ~tuple:(fun ~loc args -> Ast_helper0.Pat.tuple ~loc args) ~loc:args_loc ~attrs args in construct ~loc ~attrs l arg - | Ppat_variant (l, args) -> - let args_loc, attrs = variant_args_loc ~loc attrs in + | Ppat_variant (l, {txt = args; loc = args_loc}) -> + let args_loc = sub.location sub args_loc in let arg, attrs = encode_args ~map:(sub.pat sub) ~tuple:(fun ~loc args -> Ast_helper0.Pat.tuple ~loc args) diff --git a/compiler/ml/ast_payload.ml b/compiler/ml/ast_payload.ml index 943b39f6548..dd85d7c660f 100644 --- a/compiler/ml/ast_payload.ml +++ b/compiler/ml/ast_payload.ml @@ -321,8 +321,8 @@ let assert_strings loc (x : t) : string list = let assert_bool_lit (e : Parsetree.expression) = match e.pexp_desc with - | Pexp_construct ({txt = Lident "true"}, []) -> true - | Pexp_construct ({txt = Lident "false"}, []) -> false + | Pexp_construct ({txt = Lident "true"}, {txt = []}) -> true + | Pexp_construct ({txt = Lident "false"}, {txt = []}) -> false | _ -> Location.raise_errorf ~loc:e.pexp_loc "expect `true` or `false` in this field" diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index 7c44e38c365..80fc2dc8cbb 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -175,7 +175,7 @@ let rec add_pattern bv pat = | Ppat_alias (p, _) -> add_pattern bv p | Ppat_interval _ | Ppat_constant _ -> () | Ppat_tuple pl -> List.iter (add_pattern bv) pl - | Ppat_construct (c, args) -> + | Ppat_construct (c, {txt = args}) -> add bv c; List.iter (add_pattern bv) args | Ppat_record (pl, _, rest) -> @@ -192,7 +192,7 @@ let rec add_pattern bv pat = | Ppat_constraint (p, ty) -> add_pattern bv p; add_type bv ty - | Ppat_variant (_, args) -> List.iter (add_pattern bv) args + | Ppat_variant (_, {txt = args}) -> List.iter (add_pattern bv) args | Ppat_type li -> add bv li | Ppat_unpack id -> pattern_bv := String_map.add id.txt bound !pattern_bv | Ppat_open (m, p) -> @@ -236,10 +236,10 @@ let rec add_expr bv exp = add_expr bv e; add_cases bv pel | Pexp_tuple el -> List.iter (add_expr bv) el - | Pexp_construct (c, args) -> + | Pexp_construct (c, {txt = args}) -> add bv c; List.iter (add_expr bv) args - | Pexp_variant (_, args) -> List.iter (add_expr bv) args + | Pexp_variant (_, {txt = args}) -> List.iter (add_expr bv) args | Pexp_record (lblel, opte) -> List.iter (fun {lid = lbl; x = e} -> @@ -302,7 +302,7 @@ let rec add_expr bv exp = (( {txt = "ocaml.extension_constructor" | "extension_constructor"; _}, PStr [item] ) as e) -> ( match item.pstr_desc with - | Pstr_eval ({pexp_desc = Pexp_construct (c, [])}, _) -> add bv c + | Pstr_eval ({pexp_desc = Pexp_construct (c, {txt = []})}, _) -> add bv c | _ -> handle_extension e) | Pexp_extension e -> handle_extension e | Pexp_await e -> add_expr bv e diff --git a/compiler/ml/error_message_utils.ml b/compiler/ml/error_message_utils.ml index 78fc7ecd72c..cafb45f8e1e 100644 --- a/compiler/ml/error_message_utils.ml +++ b/compiler/ml/error_message_utils.ml @@ -676,7 +676,9 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf { exp with Parsetree.pexp_desc = - Pexp_variant (String_literal.string_semantic payload, []); + Pexp_variant + ( String_literal.string_semantic payload, + {txt = []; loc = exp.pexp_loc} ); } | _ -> None) in @@ -734,7 +736,8 @@ let print_extra_type_clash_help ~extract_concrete_typedecl ~env loc ppf exp with Parsetree.pexp_desc = Pexp_construct - ({txt = Lident constructor_name; loc = exp.pexp_loc}, []); + ( {txt = Lident constructor_name; loc = exp.pexp_loc}, + {txt = []; loc = exp.pexp_loc} ); } | _ -> None) in diff --git a/compiler/ml/parmatch.ml b/compiler/ml/parmatch.ml index 6390f747390..418749f5f93 100644 --- a/compiler/ml/parmatch.ml +++ b/compiler/ml/parmatch.ml @@ -1955,14 +1955,14 @@ module Conv = struct let id = fresh cstr.cstr_name in let lid = {cstr_lid with txt = Longident.Lident id} in Hashtbl.add constrs id cstr; - mkpat (Ppat_construct (lid, List.map loop lst)) + mkpat (Ppat_construct (lid, Location.mknoloc (List.map loop lst))) | Tpat_variant (label, p_opt, _row_desc) -> let args = match p_opt with | None -> [] | Some p -> [loop p] in - mkpat (Ppat_variant (label, args)) + mkpat (Ppat_variant (label, Location.mknoloc args)) | Tpat_record (subpatterns, _closed_flag, rest) -> let fields = List.map diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index ca2beb54960..120e518a2cd 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -215,20 +215,27 @@ and pattern_desc = Invariant: n >= 2 *) - | Ppat_construct of Longident.t loc * pattern list + | Ppat_construct of Longident.t loc * pattern list loc (* C [] C(P) [P] C(P1, ..., Pn) [P1; ...; Pn] C((P1, ..., Pn)) [Ppat_tuple [P1; ...; Pn]] + The list's location spans the argument parentheses, including both + delimiters. For constructors without parentheses or generated nodes, + use the enclosing node's location. The v0 bridge uses the payload's + location when the original parentheses span is unavailable. + This list preserves syntax, not the declared constructor arity. Type checking normalizes tuple grouping using the resolved constructor. *) - | Ppat_variant of label * pattern list + | Ppat_variant of label * pattern list loc (* #A [] #A(P) [P] #A(P1, ..., Pn) [P1; ...; Pn] #A((P1, ..., Pn)) [Ppat_tuple [P1; ...; Pn]] + + Argument locations follow Ppat_construct. *) | Ppat_record of pattern record_element list * closed_flag * record_pat_rest option @@ -310,20 +317,24 @@ and expression_desc = Invariant: n >= 2 *) - | Pexp_construct of Longident.t loc * expression list + | Pexp_construct of Longident.t loc * expression list loc (* C [] C(E) [E] C(E1, ..., En) [E1; ...; En] C((E1, ..., En)) [Pexp_tuple [E1; ...; En]] + Argument locations follow Ppat_construct. + This list preserves syntax, not the declared constructor arity. Type checking normalizes tuple grouping using the resolved constructor. *) - | Pexp_variant of label * expression list + | Pexp_variant of label * expression list loc (* #A [] #A(E) [E] #A(E1, ..., En) [E1; ...; En] #A((E1, ..., En)) [Pexp_tuple [E1; ...; En]] + + Argument locations follow Ppat_construct. *) | Pexp_record of expression record_element list * expression option (* { l1=P1; ...; ln=Pn } (None) diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml index b1a6e7c46ad..f04075a07a3 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -110,16 +110,16 @@ let view_expr x = match x.pexp_desc with | Pexp_construct ({txt = Lident "()"; _}, _) -> `tuple | Pexp_construct ({txt = Lident "[]"; _}, _) -> `nil - | Pexp_construct ({txt = Lident "::"; _}, [_; _]) -> + | Pexp_construct ({txt = Lident "::"; _}, {txt = [_; _]}) -> let rec loop exp acc = match exp with | { - pexp_desc = Pexp_construct ({txt = Lident "[]"; _}, []); + pexp_desc = Pexp_construct ({txt = Lident "[]"; _}, {txt = []}); pexp_attributes = []; } -> (List.rev acc, true) | { - pexp_desc = Pexp_construct ({txt = Lident "::"; _}, [e1; e2]); + pexp_desc = Pexp_construct ({txt = Lident "::"; _}, {txt = [e1; e2]}); pexp_attributes = []; } -> loop e2 (e1 :: acc) @@ -127,7 +127,7 @@ let view_expr x = in let ls, b = loop x [] in if b then `list ls else `cons ls - | Pexp_construct (x, []) -> `simple x.txt + | Pexp_construct (x, {txt = []}) -> `simple x.txt | _ -> `normal let is_simple_construct : construct -> bool = function @@ -446,7 +446,7 @@ and pattern ctxt f x = and pattern1 ctxt (f : Format.formatter) (x : pattern) : unit = let rec pattern_list_helper f = function | { - ppat_desc = Ppat_construct ({txt = Lident "::"; _}, [pat1; pat2]); + ppat_desc = Ppat_construct ({txt = Lident "::"; _}, {txt = [pat1; pat2]}); ppat_attributes = []; } -> pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) @@ -455,7 +455,7 @@ and pattern1 ctxt (f : Format.formatter) (x : pattern) : unit = if x.ppat_attributes <> [] then pattern ctxt f x else match x.ppat_desc with - | Ppat_variant (l, args) when args <> [] -> + | Ppat_variant (l, {txt = args}) when args <> [] -> let payload = match args with | [arg] -> arg @@ -464,7 +464,7 @@ and pattern1 ctxt (f : Format.formatter) (x : pattern) : unit = pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) payload | Ppat_construct ({txt = Lident ("()" | "[]"); _}, _) -> simple_pattern ctxt f x - | Ppat_construct (({txt; _} as li), po) -> ( + | Ppat_construct (({txt; _} as li), {txt = po}) -> ( if (* FIXME The third field always false *) txt = Lident "::" @@ -517,7 +517,7 @@ and simple_pattern ctxt (f : Format.formatter) (x : pattern) : unit = pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) | Ppat_constant c -> pp f "%a" constant c | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2 - | Ppat_variant (l, []) -> pp f "`%s" l + | Ppat_variant (l, {txt = []}) -> pp f "`%s" l | Ppat_constraint (p, ct) -> pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct | Ppat_exception p -> pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p @@ -727,7 +727,7 @@ and expression ctxt f x = (* reset here only because [function,match,try,sequence] are lower priority *) (e, l) partial_str) - | Pexp_construct (li, args) + | Pexp_construct (li, {txt = args}) when args <> [] && not (is_simple_construct (view_expr x)) -> ( (* Not efficient FIXME*) match view_expr x with @@ -774,7 +774,7 @@ and expression ctxt f x = | Pexp_open (ovf, lid, e) -> pp f "@[<2>let open%s %a in@;%a@]" (override ovf) longident_loc lid (expression ctxt) e - | Pexp_variant (l, args) when args <> [] -> + | Pexp_variant (l, {txt = args}) when args <> [] -> let payload = match args with | [arg] -> arg @@ -850,7 +850,7 @@ and simple_expr ctxt f x = pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct | Pexp_coerce (e, (), ct) -> pp f "(%a :> %a)" (expression ctxt) e (core_type ctxt) ct - | Pexp_variant (l, []) -> pp f "`%s" l + | Pexp_variant (l, {txt = []}) -> pp f "`%s" l | Pexp_record (l, eo) -> let longident_x_expression f {lid = li; x = e; opt} = let opt_str = if opt then "?" else "" in diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index b1315d57dbf..7b16b1592d4 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -203,10 +203,10 @@ and pattern i ppf x = | Ppat_tuple l -> line i ppf "Ppat_tuple\n"; list i pattern ppf l - | Ppat_construct (li, po) -> + | Ppat_construct (li, {txt = po}) -> line i ppf "Ppat_construct %a\n" fmt_longident_loc li; list i pattern ppf po - | Ppat_variant (l, args) -> + | Ppat_variant (l, {txt = args}) -> line i ppf "Ppat_variant \"%s\"\n" l; list i pattern ppf args | Ppat_record (l, c, rest) -> ( @@ -294,10 +294,10 @@ and expression i ppf x = | Pexp_tuple l -> line i ppf "Pexp_tuple\n"; list i expression ppf l - | Pexp_construct (li, args) -> + | Pexp_construct (li, {txt = args}) -> line i ppf "Pexp_construct %a\n" fmt_longident_loc li; list i expression ppf args - | Pexp_variant (l, args) -> + | Pexp_variant (l, {txt = args}) -> line i ppf "Pexp_variant \"%s\"\n" l; list i expression ppf args | Pexp_record (l, eo) -> diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 35aa5162b35..e09db3b62a5 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -186,8 +186,8 @@ let iter_expression f e = List.iter case pel | Pexp_array args | Pexp_tuple args - | Pexp_construct (_, args) - | Pexp_variant (_, args) -> + | Pexp_construct (_, {txt = args}) + | Pexp_variant (_, {txt = args}) -> List.iter expr args | Pexp_record (iel, eo) -> may expr eo; @@ -680,9 +680,13 @@ let build_ppat_or_for_variant_spread pat env expected_ty = ( Location.mkloc (Longident.Lident (Ident.name c.cd_id)) lident.loc, - match c.cd_args with - | Cstr_tuple [] -> [] - | _ -> [Ast_helper.Pat.any ()] ))) + { + loc = lident.loc; + txt = + (match c.cd_args with + | Cstr_tuple [] -> [] + | _ -> [Ast_helper.Pat.any ()]); + } ))) |> List.rev in let pat = @@ -1413,7 +1417,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp pat_attributes = sp.ppat_attributes; pat_env = !env; }) - | Ppat_construct (lid, sargs) -> + | Ppat_construct (lid, {txt = sargs}) -> let opath = try let p0, p, _ = extract_concrete_variant !env expected_ty in @@ -1506,7 +1510,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp pat_attributes = sp.ppat_attributes; pat_env = !env; }) - | Ppat_variant (l, sargs) -> ( + | Ppat_variant (l, {txt = sargs}) -> ( check_polyvar_name !env loc l; let sarg = match sargs with @@ -2197,8 +2201,8 @@ let iter_ppat f p = | Ppat_or (p1, p2) -> f p1; f p2 - | Ppat_construct (_, args) -> List.iter f args - | Ppat_variant (_, args) -> List.iter f args + | Ppat_construct (_, {txt = args}) -> List.iter f args + | Ppat_variant (_, {txt = args}) -> List.iter f args | Ppat_tuple lst -> List.iter f lst | Ppat_exception p | Ppat_alias (p, _) @@ -2764,9 +2768,9 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp exp_attributes = sexp.pexp_attributes; exp_env = env; } - | Pexp_construct (lid, sargs) -> + | Pexp_construct (lid, {txt = sargs}) -> type_construct ~context env loc lid sargs ty_expected sexp.pexp_attributes - | Pexp_variant (l, sargs) -> ( + | Pexp_variant (l, {txt = sargs}) -> ( check_polyvar_name env loc l; let sarg = match sargs with @@ -3583,8 +3587,12 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp payload ) -> ( match payload with | PStr - [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_construct (lid, []); _}, _)}] - -> + [ + { + pstr_desc = + Pstr_eval ({pexp_desc = Pexp_construct (lid, {txt = []}); _}, _); + }; + ] -> let path = match (Typetexp.find_constructor env lid.loc lid.txt).cstr_kind with | Extension_constructor path -> path @@ -4369,7 +4377,9 @@ and type_application ~context total_app env funct (sargs : sargs) : (* Leftover syntactic arguments *) (match !remaining with | [] -> () - | [(Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, [])})] + | [ + (Nolabel, {pexp_desc = Pexp_construct ({txt = Lident "()"}, {txt = []})}); + ] when total_app && !omitted = [] && !rev_args <> [] && List.length !rev_args = List.length !ignored -> (* foo() treated as empty application if all args are optional diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index 01ee36b1a33..c2b3f4c986d 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -633,14 +633,14 @@ module Sexp_ast = struct | Pexp_tuple exprs -> Sexp.list [Sexp.atom "Pexp_tuple"; Sexp.list (map_empty ~f:expression exprs)] - | Pexp_construct (longident_loc, exprs) -> + | Pexp_construct (longident_loc, {txt = exprs}) -> Sexp.list [ Sexp.atom "Pexp_construct"; longident longident_loc.Asttypes.txt; Sexp.list (map_empty ~f:expression exprs); ] - | Pexp_variant (lbl, exprs) -> + | Pexp_variant (lbl, {txt = exprs}) -> Sexp.list [ Sexp.atom "Pexp_variant"; @@ -842,14 +842,14 @@ module Sexp_ast = struct | Ppat_tuple patterns -> Sexp.list [Sexp.atom "Ppat_tuple"; Sexp.list (map_empty ~f:pattern patterns)] - | Ppat_construct (longident_loc, patterns) -> + | Ppat_construct (longident_loc, {txt = patterns}) -> Sexp.list [ Sexp.atom "Ppat_construct"; longident longident_loc.Location.txt; Sexp.list (map_empty ~f:pattern patterns); ] - | Ppat_variant (lbl, patterns) -> + | Ppat_variant (lbl, {txt = patterns}) -> Sexp.list [ Sexp.atom "Ppat_variant"; diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index a43c76ef8f4..5c1b7d69c3a 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -296,15 +296,15 @@ let partition_between_lines start_line end_line comments = let rec collect_list_patterns acc pattern = let open Parsetree in match pattern.ppat_desc with - | Ppat_construct ({txt = Longident.Lident "::"}, [pat; rest]) -> + | Ppat_construct ({txt = Longident.Lident "::"}, {txt = [pat; rest]}) -> collect_list_patterns (pat :: acc) rest - | Ppat_construct ({txt = Longident.Lident "[]"}, []) -> List.rev acc + | Ppat_construct ({txt = Longident.Lident "[]"}, {txt = []}) -> List.rev acc | _ -> List.rev (pattern :: acc) let rec collect_list_exprs acc expr = let open Parsetree in match expr.pexp_desc with - | Pexp_construct ({txt = Longident.Lident "::"}, [expr; rest]) -> + | Pexp_construct ({txt = Longident.Lident "::"}, {txt = [expr; rest]}) -> collect_list_exprs (expr :: acc) rest | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> List.rev acc | _ -> List.rev (expr :: acc) @@ -1003,7 +1003,8 @@ and walk_expression expr t comments = | Pexp_let ( _recFlag, value_bindings, - {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, [])} ) -> + {pexp_desc = Pexp_construct ({txt = Longident.Lident "()"}, {txt = []})} + ) -> walk_value_bindings value_bindings t comments | Pexp_let (_recFlag, value_bindings, expr2) -> let comments = @@ -1155,7 +1156,7 @@ and walk_expression expr t comments = walk_list (collect_list_exprs [] expr |> List.map (fun e -> Expression e)) t comments - | Pexp_construct (longident, args) -> ( + | Pexp_construct (longident, {txt = args}) -> ( let leading, trailing = partition_leading_trailing comments longident.loc in attach t.leading longident.loc leading; match args with @@ -1166,7 +1167,7 @@ and walk_expression expr t comments = attach t.trailing longident.loc after_longident; walk_list (List.map (fun expr -> Expression expr) exprs) t rest | [] -> attach t.trailing longident.loc trailing) - | Pexp_variant (_label, args) -> + | Pexp_variant (_label, {txt = args}) -> walk_list (List.map (fun expr -> Expression expr) args) t comments | Pexp_array exprs | Pexp_tuple exprs -> walk_list (exprs |> List.map (fun e -> Expression e)) t comments @@ -2053,13 +2054,13 @@ and walk_pattern pat t comments = walk_list (collect_list_patterns [] pat |> List.map (fun p -> Pattern p)) t comments - | Ppat_construct (constr, []) -> + | Ppat_construct (constr, {txt = []}) -> let before_constr, after_constr = partition_leading_trailing comments constr.loc in attach t.leading constr.loc before_constr; attach t.trailing constr.loc after_constr - | Ppat_construct (constr, [pat]) -> + | Ppat_construct (constr, {txt = [pat]}) -> let leading, trailing = partition_leading_trailing comments constr.loc in attach t.leading constr.loc leading; let after_constructor, rest = @@ -2070,7 +2071,7 @@ and walk_pattern pat t comments = attach t.leading pat.ppat_loc leading; walk_pattern pat t inside; attach t.trailing pat.ppat_loc trailing - | Ppat_construct (constr, pats) -> + | Ppat_construct (constr, {txt = pats}) -> let leading, trailing = partition_leading_trailing comments constr.loc in attach t.leading constr.loc leading; let after_constructor, rest = @@ -2078,7 +2079,7 @@ and walk_pattern pat t comments = in attach t.trailing constr.loc after_constructor; walk_list (List.map (fun pat -> Pattern pat) pats) t rest - | Ppat_variant (_label, args) -> + | Ppat_variant (_label, {txt = args}) -> walk_list (List.map (fun pat -> Pattern pat) args) t comments | Ppat_type _ -> () | Ppat_record (record_rows, _, rest) -> diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index cbce6703e0f..537b9561f1c 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -600,7 +600,8 @@ let make_list_pattern loc seq ext_opt = in Ast_helper.Pat.mk ~loc (Ppat_construct - (Location.mkloc (Longident.Lident "::") loc, [p1; pat_pl])) + ( Location.mkloc (Longident.Lident "::") loc, + {txt = [p1; pat_pl]; loc} )) in handle_seq seq @@ -1757,24 +1758,19 @@ and parse_pattern_args (p : Parser.t) = | patterns -> patterns and parse_constructor_pattern_args p constr start_pos attrs = + let args_start = p.Parser.start_pos in let args = parse_pattern_args p in Ast_helper.Pat.construct ~loc:(mk_loc start_pos p.prev_end_pos) + ~args_loc:(mk_loc args_start p.prev_end_pos) ~attrs constr args and parse_variant_pattern_args p ident start_pos attrs = let args_start = p.Parser.start_pos in let args = parse_pattern_args p in - let attrs = - match args with - | _ :: _ :: _ -> - ( Location.mkloc "res.variantArgs" (mk_loc args_start p.prev_end_pos), - Parsetree.PStr [] ) - :: attrs - | _ -> attrs - in Ast_helper.Pat.variant ~loc:(mk_loc start_pos p.prev_end_pos) + ~args_loc:(mk_loc args_start p.prev_end_pos) ~attrs ident args and parse_expr ?(context = OrdinaryExpr) p = @@ -2579,7 +2575,7 @@ and over_parse_constrained_or_coerced_or_arrow_expression p expr = (Longident.flatten longident.txt |> String.concat ".") longident.loc), false ) - | Pexp_construct (({txt = Longident.Lident "()"} as lid), []) -> + | Pexp_construct (({txt = Longident.Lident "()"} as lid), {txt = []}) -> (Ast_helper.Pat.construct ~loc:expr.pexp_loc lid [], true) (* TODO: can we convert more expressions to patterns?*) | _ -> @@ -4193,11 +4189,15 @@ and parse_value_or_constructor p = Parser.next p; aux p (ident :: acc) | Lparen when p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> + let args_start = p.start_pos in let args = parse_constructor_args p in let lident = build_longident (ident :: acc) in let loc = mk_loc start_pos p.prev_end_pos in let ident_loc = mk_loc start_pos end_pos_lident in - Ast_helper.Exp.construct ~loc (Location.mkloc lident ident_loc) args + Ast_helper.Exp.construct ~loc + ~args_loc:(mk_loc args_start p.prev_end_pos) + (Location.mkloc lident ident_loc) + args | _ -> let loc = mk_loc start_pos p.prev_end_pos in let lident = build_longident (ident :: acc) in @@ -4228,16 +4228,9 @@ and parse_poly_variant_expr p = let args_start = p.start_pos in let args = parse_constructor_args p in let loc = mk_loc start_pos p.prev_end_pos in - let attrs = - match args with - | _ :: _ :: _ -> - [ - ( Location.mkloc "res.variantArgs" (mk_loc args_start p.prev_end_pos), - Parsetree.PStr [] ); - ] - | _ -> [] - in - Ast_helper.Exp.variant ~loc ~attrs ident args + Ast_helper.Exp.variant ~loc + ~args_loc:(mk_loc args_start p.prev_end_pos) + ident args | _ -> let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.variant ~loc ident [] diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index 86b27db5ffe..3d753f0f66e 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -70,7 +70,7 @@ let collect_list_expressions expr = let rec collect acc expr = match expr.pexp_desc with | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> (List.rev acc, None) - | Pexp_construct ({txt = Longident.Lident "::"}, hd :: [tail]) -> + | Pexp_construct ({txt = Longident.Lident "::"}, {txt = hd :: [tail]}) -> collect (hd :: acc) tail | _ -> (List.rev acc, Some expr) in @@ -227,8 +227,7 @@ let filter_parsing_attrs attrs = Location.txt = ( "res.braces" | "ns.braces" | "res.iflet" | "res.ternary" | "res.await" | "res.patVariantSpread" | "res.dictPattern" - | "res.dictSpread" | "res.inlineRecordDefinition" - | "res.variantArgs" ); + | "res.dictSpread" | "res.inlineRecordDefinition" ); }, _ ) -> false @@ -387,7 +386,7 @@ let has_attributes attrs = | ( { Location.txt = ( "res.braces" | "ns.braces" | "res.iflet" | "res.ternary" - | "res.await" | "res.inlineRecordDefinition" | "res.variantArgs" ); + | "res.await" | "res.inlineRecordDefinition" ); }, _ ) -> false @@ -563,8 +562,7 @@ let is_printable_attribute attr = | ( { Location.txt = ( "res.iflet" | "res.braces" | "ns.braces" | "JSX" | "res.await" - | "res.ternary" | "res.inlineRecordDefinition" | "res.dictSpread" - | "res.variantArgs" ); + | "res.ternary" | "res.inlineRecordDefinition" | "res.dictSpread" ); }, _ ) -> false @@ -644,7 +642,7 @@ let mod_expr_functor mod_expr = let rec collect_patterns_from_list_construct acc pattern = let open Parsetree in match pattern.ppat_desc with - | Ppat_construct ({txt = Longident.Lident "::"}, [pat; rest]) -> + | Ppat_construct ({txt = Longident.Lident "::"}, {txt = [pat; rest]}) -> collect_patterns_from_list_construct (pat :: acc) rest | _ -> (List.rev acc, pattern) diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 40c6f5b196b..0b9c4b143b2 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -2760,11 +2760,11 @@ and print_pattern ~state (p : Parsetree.pattern) cmt_tbl = ]); Doc.rbrace; ]) - | Ppat_construct (constr_name, constructor_args) -> + | Ppat_construct (constr_name, {txt = constructor_args}) -> let constr_name = print_longident_location constr_name cmt_tbl in let args_doc = print_pattern_args ~state constructor_args cmt_tbl in Doc.group (Doc.concat [constr_name; args_doc]) - | Ppat_variant (label, variant_args) -> + | Ppat_variant (label, {txt = variant_args}) -> let variant_name = Doc.concat [Doc.text "#"; print_poly_var_ident label] in @@ -3276,7 +3276,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = Doc.soft_line; Doc.rbrace; ]) - | Pexp_construct (longident_loc, args) -> + | Pexp_construct (longident_loc, {txt = args}) -> let constr = print_longident_location longident_loc cmt_tbl in let args = print_expression_args ~state args cmt_tbl in Doc.group (Doc.concat [constr; args]) @@ -3336,7 +3336,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = Doc.soft_line; Doc.rbracket; ]) - | Pexp_variant (label, args) -> + | Pexp_variant (label, {txt = args}) -> let variant_name = Doc.concat [Doc.text "#"; print_poly_var_ident label] in @@ -3790,7 +3790,7 @@ and print_pexp_fun ~state ~in_callback e cmt_tbl = match (return_expr.pexp_desc, opt_braces) with | _, Some _ -> true | ( ( Pexp_array _ | Pexp_tuple _ - | Pexp_construct (_, _ :: _) + | Pexp_construct (_, {txt = _ :: _}) | Pexp_record _ ), _ ) -> true @@ -5364,7 +5364,10 @@ and print_expr_fun_parameters ~state ~in_callback ~async ~has_constraint lbl = Nolabel; default_expr = None; pat = - {ppat_desc = Ppat_construct ({txt = Longident.Lident "()"; loc}, [])}; + { + ppat_desc = + Ppat_construct ({txt = Longident.Lident "()"; loc}, {txt = []}); + }; }; ] -> let doc = diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index a166ac75689..648bf9fa69a 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -314,7 +314,7 @@ let test_constructor_args_roundtrip_through_ast0 _ = | _ -> assert_failure "Expected a tuple-encoded v0 constructor payload"); let expr = map_expr0 expr0 in (match expr.pexp_desc with - | Parsetree.Pexp_construct (_, [_; _]) -> + | Parsetree.Pexp_construct (_, {txt = [_; _]}) -> OUnit.assert_bool "bridge metadata is removed" (not (has_attr "_res.constructor_args" expr.pexp_attributes)) | _ -> assert_failure "Expected two constructor arguments after roundtrip"); @@ -328,7 +328,8 @@ let test_constructor_args_roundtrip_through_ast0 _ = OUnit.assert_equal ~msg:"tuple roundtrip preserves empty attributes" [] expr.pexp_attributes; (match expr.pexp_desc with - | Parsetree.Pexp_construct (_, [{pexp_desc = Pexp_tuple [_; _]}]) -> () + | Parsetree.Pexp_construct (_, {txt = [{pexp_desc = Pexp_tuple [_; _]}]}) -> + () | _ -> assert_failure "Expected one tuple argument after roundtrip"); let pat = Ast_helper.Pat.construct ~loc lid [int_pat "1"; int_pat "2"] in let pat0 = map_pat_to0 pat in @@ -338,42 +339,10 @@ let test_constructor_args_roundtrip_through_ast0 _ = (has_attr "_res.constructor_args" pat0.ppat_attributes) | _ -> assert_failure "Expected a tuple-encoded v0 constructor pattern"); match (map_pat0 pat0).ppat_desc with - | Parsetree.Ppat_construct (_, [_; _]) -> () + | Parsetree.Ppat_construct (_, {txt = [_; _]}) -> () | _ -> assert_failure "Expected two pattern arguments after roundtrip" -let test_constructor_args_keep_parentheses_location_in_ast0 _ = - let source = "let Pair(a, b) = Pair(1, 2)" in - let parsed = - Res_driver.parse_implementation_from_source - ~display_filename:"ConstructorArgsLocation.res" ~source - in - let pat, expr = - match parsed.parsetree with - | [{pstr_desc = Pstr_value (_, [{pvb_pat; pvb_expr}])}] -> - (pvb_pat, pvb_expr) - | _ -> assert_failure "Expected one constructor value binding" - in - let assert_payload_loc ~expected_start ~expected_end - {Location.loc_start; loc_end} = - OUnit.assert_equal expected_start loc_start.pos_cnum; - OUnit.assert_equal expected_end loc_end.pos_cnum - in - let pattern_lparen = String.index source '(' in - let pattern_rparen = String.index_from source pattern_lparen ')' in - let expression_lparen = String.index_from source (pattern_rparen + 1) '(' in - let expression_rparen = String.index_from source expression_lparen ')' in - (match (map_pat_to0 pat).ppat_desc with - | Ppat_construct (_, Some {ppat_desc = Ppat_tuple _; ppat_loc}) -> - assert_payload_loc ~expected_start:pattern_lparen - ~expected_end:(pattern_rparen + 1) ppat_loc - | _ -> assert_failure "Expected a tuple-encoded constructor pattern"); - match (map_expr_to0 expr).pexp_desc with - | Pexp_construct (_, Some {pexp_desc = Pexp_tuple _; pexp_loc}) -> - assert_payload_loc ~expected_start:expression_lparen - ~expected_end:(expression_rparen + 1) pexp_loc - | _ -> assert_failure "Expected a tuple-encoded constructor expression" - -let test_polyvariant_args_keep_parentheses_location_in_ast0 _ = +let check_args_keep_parentheses_location_in_ast0 sources = List.iter (fun source -> let parsed = @@ -384,39 +353,170 @@ let test_polyvariant_args_keep_parentheses_location_in_ast0 _ = match parsed.parsetree with | [{pstr_desc = Pstr_value (_, [{pvb_pat; pvb_expr}])}] -> (pvb_pat, pvb_expr) - | _ -> assert_failure "Expected one polymorphic variant binding" + | _ -> assert_failure "Expected one constructor binding" in let pattern_start = String.index source '(' in let pattern_end = 1 + String.index_from source pattern_start ')' in let expression_start = String.index_from source pattern_end '(' in let expression_end = 1 + String.index_from source expression_start ')' in - let assert_loc start finish {Location.loc_start; loc_end} = - OUnit.assert_equal start loc_start.pos_cnum; - OUnit.assert_equal finish loc_end.pos_cnum - in - let check pat expr = - OUnit.assert_bool "parser location metadata stays out of v0" - ((not (has_attr "res.variantArgs" pat.Parsetree0.ppat_attributes)) - && not (has_attr "res.variantArgs" expr.Parsetree0.pexp_attributes)); + OUnit.assert_equal [] pat.ppat_attributes; + OUnit.assert_equal [] expr.pexp_attributes; + let check ?(offset = 0) (pat : Parsetree0.pattern) + (expr : Parsetree0.expression) = + let assert_loc start finish {Location.loc_start; loc_end} = + OUnit.assert_equal (start + offset) loc_start.pos_cnum; + OUnit.assert_equal (finish + offset) loc_end.pos_cnum + in (match pat.ppat_desc with + | Ppat_construct (_, Some {ppat_desc = Ppat_tuple _; ppat_loc}) | Ppat_variant (_, Some {ppat_desc = Ppat_tuple _; ppat_loc}) -> assert_loc pattern_start pattern_end ppat_loc - | _ -> assert_failure "Expected v0 polymorphic variant pattern tuple"); + | _ -> assert_failure "Expected v0 constructor pattern tuple"); match expr.pexp_desc with + | Pexp_construct (_, Some {pexp_desc = Pexp_tuple _; pexp_loc}) | Pexp_variant (_, Some {pexp_desc = Pexp_tuple _; pexp_loc}) -> assert_loc expression_start expression_end pexp_loc - | _ -> assert_failure "Expected v0 polymorphic variant expression tuple" + | _ -> assert_failure "Expected v0 constructor expression tuple" in let pat0 = map_pat_to0 pat in let expr0 = map_expr_to0 expr in check pat0 expr0; - check (map_pat_to0 (map_pat0 pat0)) (map_expr_to0 (map_expr0 expr0))) + check (map_pat_to0 (map_pat0 pat0)) (map_expr_to0 (map_expr0 expr0)); + let shift_loc _ (loc : Location.t) = + { + loc with + loc_start = + {loc.loc_start with pos_cnum = loc.loc_start.pos_cnum + 100}; + loc_end = {loc.loc_end with pos_cnum = loc.loc_end.pos_cnum + 100}; + } + in + let to0 = {Ast_mapper_to0.default_mapper with location = shift_loc} in + check ~offset:100 (to0.pat to0 pat) (to0.expr to0 expr); + let from0 = {Ast_mapper_from0.default_mapper with location = shift_loc} in + check ~offset:100 + (map_pat_to0 (from0.pat from0 pat0)) + (map_expr_to0 (from0.expr from0 expr0))) + sources + +let test_constructor_args_keep_parentheses_location_in_ast0 _ = + check_args_keep_parentheses_location_in_ast0 + [ + "let Pair(a, b) = Pair(1, 2)"; + "let Pair (a, b) = Pair (1, 2)"; + "let Pair /* pattern */ (a, b) = Pair /* expression */ (1, 2)"; + "let Module.Pair(a,\n b) = Module.Pair(1,\n 2)"; + ] + +let test_polyvariant_args_keep_parentheses_location_in_ast0 _ = + check_args_keep_parentheses_location_in_ast0 [ "let #Pair(a, b) = #Pair(1, 2)"; "let #Pair /* pattern */ (a, b) = #Pair /* expression */ (1, 2)"; "let #\"quoted label\"(a,\n b) = #\"quoted label\"(1,\n 2)"; ] +let test_constructor_argument_locations _ = + let pattern_args_loc (pat : Parsetree.pattern) = + match pat.ppat_desc with + | Ppat_construct (_, {loc}) | Ppat_variant (_, {loc}) -> loc + | _ -> assert_failure "Expected a constructor pattern" + in + let expression_args_loc (expr : Parsetree.expression) = + match expr.pexp_desc with + | Pexp_construct (_, {loc}) | Pexp_variant (_, {loc}) -> loc + | _ -> assert_failure "Expected a constructor expression" + in + let shift_loc _ (loc : Location.t) = + { + loc with + loc_start = {loc.loc_start with pos_cnum = loc.loc_start.pos_cnum + 100}; + loc_end = {loc.loc_end with pos_cnum = loc.loc_end.pos_cnum + 100}; + } + in + List.iter + (fun source -> + let parsed = + Res_driver.parse_implementation_from_source + ~display_filename:"ArgumentLocations.res" ~source + in + OUnit.assert_bool "source parses" (not parsed.invalid); + let pat, expr = + match parsed.parsetree with + | [{pstr_desc = Pstr_value (_, [{pvb_pat; pvb_expr}])}] -> + (pvb_pat, pvb_expr) + | _ -> assert_failure "Expected a constructor binding" + in + let pat_loc = pattern_args_loc pat in + let expr_loc = expression_args_loc expr in + let expected_pat_bridge_loc = + match pat.ppat_desc with + | Ppat_construct (_, {txt = [arg]}) | Ppat_variant (_, {txt = [arg]}) -> + arg.ppat_loc + | _ -> pat_loc + in + let expected_expr_bridge_loc = + match expr.pexp_desc with + | Pexp_construct (_, {txt = [arg]}) | Pexp_variant (_, {txt = [arg]}) -> + arg.pexp_loc + | _ -> expr_loc + in + OUnit.assert_equal ~msg:"v0 uses the payload span for a single argument" + expected_pat_bridge_loc + (pattern_args_loc (map_pat0 (map_pat_to0 pat))); + OUnit.assert_equal ~msg:"v0 uses the payload span for a single argument" + expected_expr_bridge_loc + (expression_args_loc (map_expr0 (map_expr_to0 expr))); + let equals = String.index source '=' in + let assert_span start finish (loc : Location.t) = + OUnit.assert_equal start loc.loc_start.pos_cnum; + OUnit.assert_equal finish loc.loc_end.pos_cnum + in + if String.contains source '(' then ( + assert_span (String.index source '(') + (1 + String.rindex_from source equals ')') + pat_loc; + assert_span + (String.index_from source equals '(') + (1 + String.rindex source ')') + expr_loc) + else ( + OUnit.assert_equal pat.ppat_loc pat_loc; + OUnit.assert_equal expr.pexp_loc expr_loc); + let mapper = Ast_mapper.default_mapper in + OUnit.assert_equal pat (mapper.pat mapper pat); + OUnit.assert_equal expr (mapper.expr mapper expr); + let mapper = {mapper with location = shift_loc} in + OUnit.assert_equal (shift_loc () pat_loc) + (pattern_args_loc (mapper.pat mapper pat)); + OUnit.assert_equal (shift_loc () expr_loc) + (expression_args_loc (mapper.expr mapper expr)); + let visited = ref [] in + let iterator = + { + Ast_iterator.default_iterator with + location = (fun _ loc -> visited := loc :: !visited); + } + in + iterator.pat iterator pat; + OUnit.assert_bool "iterator visits pattern argument span" + (List.mem pat_loc !visited); + visited := []; + iterator.expr iterator expr; + OUnit.assert_bool "iterator visits expression argument span" + (List.mem expr_loc !visited)) + [ + "let Pair /* pattern */ (a, b) = Pair /* expression */ (1, 2)"; + "let Pair((a, b)) = Pair((1, 2))"; + "let Single(a) = Single(1)"; + "let Unit() = Unit()"; + "let Empty = Empty"; + "let #Pair /* pattern */ (a, b) = #Pair /* expression */ (1, 2)"; + "let #Pair((a, b)) = #Pair((1, 2))"; + "let #Single(a) = #Single(1)"; + "let #Unit() = #Unit()"; + "let #Empty = #Empty"; + ] + let test_fresh_ast0_constructor_tuple_reprints_without_internal_metadata _ = let int_expr value = Ast_helper0.Exp.constant ~loc (Parsetree0.Pconst_integer (value, None)) @@ -467,12 +567,14 @@ let test_fresh_ast0_constructor_tuple_reprints_without_internal_metadata _ = pvb_pat = { ppat_desc = - Ppat_construct (_, [{ppat_desc = Ppat_tuple [_; _]}]); + Ppat_construct + (_, {txt = [{ppat_desc = Ppat_tuple [_; _]}]}); }; pvb_expr = { pexp_desc = - Pexp_construct (_, [{pexp_desc = Pexp_tuple [_; _]}]); + Pexp_construct + (_, {txt = [{pexp_desc = Pexp_tuple [_; _]}]}); }; }; ] ); @@ -493,7 +595,7 @@ let test_ast0_explicit_arity_becomes_constructor_args _ = (Some (Ast_helper0.Exp.tuple ~loc [arg "1"; arg "2"])) in match (map_expr0 expr0).pexp_desc with - | Parsetree.Pexp_construct (_, [_; _]) -> () + | Parsetree.Pexp_construct (_, {txt = [_; _]}) -> () | _ -> assert_failure "Expected explicit-arity v0 payload to become arguments" let test_fresh_ast0_constructor_tuple_defers_arity_to_typechecker _ = @@ -571,7 +673,7 @@ let test_polyvariant_args_roundtrip_through_ast0 _ = (has_attr "_res.constructor_args" expr0.pexp_attributes) | _ -> assert_failure "Expected tuple-encoded v0 polymorphic variant payload"); (match (map_expr0 expr0).pexp_desc with - | Parsetree.Pexp_variant ("Pair", [_; _]) -> () + | Parsetree.Pexp_variant ("Pair", {txt = [_; _]}) -> () | _ -> assert_failure "Expected two polymorphic variant arguments"); let pat = Ast_helper.Pat.variant ~loc "Pair" [int_pat "1"; int_pat "2"] in let pat0 = map_pat_to0 pat in @@ -581,7 +683,7 @@ let test_polyvariant_args_roundtrip_through_ast0 _ = (has_attr "_res.constructor_args" pat0.ppat_attributes) | _ -> assert_failure "Expected tuple-encoded v0 polymorphic variant pattern"); (match (map_pat0 pat0).ppat_desc with - | Parsetree.Ppat_variant ("Pair", [_; _]) -> () + | Parsetree.Ppat_variant ("Pair", {txt = [_; _]}) -> () | _ -> assert_failure "Expected two polymorphic variant pattern arguments"); let int_type = Ast_helper.Typ.constr ~loc (Location.mknoloc (Longident.Lident "int")) [] @@ -1134,6 +1236,8 @@ let suites = >:: test_constructor_args_roundtrip_through_ast0; "constructor_args_keep_parentheses_location_in_ast0" >:: test_constructor_args_keep_parentheses_location_in_ast0; + "constructor_argument_locations" + >:: test_constructor_argument_locations; "fresh_ast0_constructor_tuple_reprints_without_internal_metadata" >:: test_fresh_ast0_constructor_tuple_reprints_without_internal_metadata; "ast0_explicit_arity_becomes_constructor_args" diff --git a/tests/syntax_tests/data/ast-mapping/ConstructorPayloadLocation.res b/tests/syntax_tests/data/ast-mapping/ConstructorPayloadLocation.res new file mode 100644 index 00000000000..f90d324272b --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/ConstructorPayloadLocation.res @@ -0,0 +1,5 @@ +let pair = Pair /* payload */ (1, 2) + +let read = value => switch value { +| Module.Pair /* payload */ (a, b) => (a, b) +} diff --git a/tests/syntax_tests/data/ast-mapping/expected/ConstructorPayloadLocation.res.txt b/tests/syntax_tests/data/ast-mapping/expected/ConstructorPayloadLocation.res.txt new file mode 100644 index 00000000000..c7e17f78924 --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/expected/ConstructorPayloadLocation.res.txt @@ -0,0 +1,6 @@ +let pair = Pair /* payload */(1, 2) + +let read = value => + switch value { + | Module.Pair /* payload */(a, b) => (a, b) + } diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/arrow.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/arrow.res.txt index bae88bd32b2..dc435527365 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/arrow.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/arrow.res.txt @@ -65,10 +65,9 @@ let x = ((fun [arity:1]_ -> copyChecklistItemCB ()), (fun [arity:1]_ -> copyChecklistItemCB ())) let y = - ((`Constructore - ((fun [arity:1]_ -> copyChecklistItemCB ()), - (fun [arity:1]_ -> copyChecklistItemCB ()))) - [@res.variantArgs ]) + `Constructore + ((fun [arity:1]_ -> copyChecklistItemCB ()), + (fun [arity:1]_ -> copyChecklistItemCB ())) let f [arity:1]list = list + 1 let foo = (() : unit) type nonrec u = unit diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/binary.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/binary.res.txt index 6eed76554cb..eb4809b8cb8 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/binary.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/binary.res.txt @@ -23,8 +23,7 @@ let x = (a >>> a) == 0 let x = a - b let x = a -. b ;;Constructor (a, b) -;;((`Constructor (a, b))[@res.variantArgs ]) -let _ = ((Constructor (a, b); ((`Constructor (a, b))[@res.variantArgs ])) - [@res.braces ]) +;;`Constructor (a, b) +let _ = ((Constructor (a, b); `Constructor (a, b))[@res.braces ]) ;;(library.getBalance account) -> (Promise.catch (fun [arity:1]_ -> ((Promise.resolve None)[@res.braces ]))) \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/polyvariant.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/polyvariant.res.txt index 95ca9d1f7a1..5de14a9eaa7 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/polyvariant.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/polyvariant.res.txt @@ -1,9 +1,9 @@ let x = `Red let z = `Rgb () -let v = ((`Vertex (1., 2., 3., 4.))[@res.variantArgs ]) +let v = `Vertex (1., 2., 3., 4.) let animation = `ease-in let one = `1 let fortyTwo = `42 let long = `42444 let oneString = `1 {js|payload|js} -let twoIntString = ((`2 (3, {js|payload|js}))[@res.variantArgs ]) \ No newline at end of file +let twoIntString = `2 (3, {js|payload|js}) \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/pattern/expected/constant.res.txt b/tests/syntax_tests/data/parsing/grammar/pattern/expected/constant.res.txt index 7ec98156b33..ee5896002b0 100644 --- a/tests/syntax_tests/data/parsing/grammar/pattern/expected/constant.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/pattern/expected/constant.res.txt @@ -62,7 +62,7 @@ let (-1)..(-1.) = x | 1.12::(-3.13)::[] -> true | { x = 1.12; y = (-3.13) } -> true | Constructor (1.12, (-2.45)) -> true - | ((`Constuctor (1.12, (-2.45)))[@res.variantArgs ]) -> true + | `Constuctor (1.12, (-2.45)) -> true | (-4.15) as x -> true | (-4.15)|4.15 -> true | ((-3.14) : float) -> true @@ -75,8 +75,7 @@ let (-1)..(-1.) = x | {js|literal1|js}::{js|literal2|js}::[] -> true | { x = {js|literal1|js}; y = {js|literal2|js} } -> true | Constructor ({js|literal1|js}, {js|literal2|js}) -> true - | ((`Constuctor ({js|literal1|js}, {js|literal2|js}))[@res.variantArgs ]) - -> true + | `Constuctor ({js|literal1|js}, {js|literal2|js}) -> true | {js|literal|js} as x -> true | {js|literal|js}|{js|literal|js} -> true | ({js|literal|js} : string) -> true diff --git a/tests/syntax_tests/data/parsing/grammar/pattern/expected/polyvariants.res.txt b/tests/syntax_tests/data/parsing/grammar/pattern/expected/polyvariants.res.txt index 13990b7a567..9f2268f07f2 100644 --- a/tests/syntax_tests/data/parsing/grammar/pattern/expected/polyvariants.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/pattern/expected/polyvariants.res.txt @@ -6,15 +6,15 @@ let `Instance component = i let `Instance { render; subtree } = i let `Instance { render; subtree } as x = i let `Instance ({ render; subtree } as inst) = i -let ((`Instance ({ render; subtree }, inst))[@res.variantArgs ]) = i +let `Instance ({ render; subtree }, inst) = i let `Instance ({ render; subtree } : Instance.t) = i let `Instance ({ render; subtree } : Instance.t) as inst = i let `Instance ({ render; subtree } : Instance.t) = i -let ((`Instance (component, tree))[@res.variantArgs ]) = i -let ((`Instance (component, tree))[@res.variantArgs ]) as x = i -let ((`Instance ((component as x), (tree as y)))[@res.variantArgs ]) = i -let ((`Instance (component, tree))[@res.variantArgs ]) as inst = i -let ((`Instance (component, tree))[@res.variantArgs ]) = i +let `Instance (component, tree) = i +let `Instance (component, tree) as x = i +let `Instance ((component as x), (tree as y)) = i +let `Instance (component, tree) as inst = i +let `Instance (component, tree) = i let (`Instance : React.t) = i let (`Instance : React.t) as t = i let (`Instance : React.t) as x = i @@ -26,22 +26,21 @@ let ((`Instance (component : comp)) : React.t) = i | `Instance comp -> () | `Instance comp as inst -> () | `Instance { render; subtree } -> () - | ((`Instance ({ render; subtree }, inst))[@res.variantArgs ]) -> () + | `Instance ({ render; subtree }, inst) -> () | `Instance ({ render; subtree } : Instance.t) -> () | `Instance ({ render; subtree } : Instance.t) -> () - | ((`Instance (comp, tree))[@res.variantArgs ]) -> () + | `Instance (comp, tree) -> () | (`Instance (comp : Component.t) : React.t) -> () let f [arity:1]`Instance = i let f [arity:1](`Instance as i) = i let f [arity:1](`Instance component) = i let f [arity:1](`Instance component) = i let f [arity:1](`Instance { render; subtree }) = i -let f [arity:1]((`Instance ({ render; subtree }, inst))[@res.variantArgs ]) = - i +let f [arity:1](`Instance ({ render; subtree }, inst)) = i let f [arity:1](`Instance ({ render; subtree } : Instance.t)) = i let f [arity:1](`Instance ({ render; subtree } : Instance.t)) = i -let f [arity:1]((`Instance (component, tree))[@res.variantArgs ]) = i -let f [arity:1]((`Instance (component, tree))[@res.variantArgs ]) = i +let f [arity:1](`Instance (component, tree)) = i +let f [arity:1](`Instance (component, tree)) = i let f [arity:1](`Instance : React.t) = i let f [arity:1](`Instance : React.t) = i let f [arity:1](`Instance (comp : Component.t) : React.t) = () @@ -52,19 +51,13 @@ let f [arity:1](`Instance (comp : Component.t) : React.t) = () ;;for (`Blue : Color.t) = x to y do () done ;;for (`Blue : Color.t) as c = x to y do () done ;;for (`Blue : Color.t) as c = x to y do () done -;;for ((`Rgba (r, g, b))[@res.variantArgs ]) = x to y do () done -;;for ((`Rgba (r, g, b))[@res.variantArgs ]) as c = x to y do () done +;;for `Rgba (r, g, b) = x to y do () done +;;for `Rgba (r, g, b) as c = x to y do () done ;;for Rgba ((r : float), (g : float), (b : float)) = x to y do () done -;;for ((`Rgba ((r : float), (g : float), (b : float)))[@res.variantArgs ]) as - c = - x to y do - () - done -;;for (((`Rgba (r, g, b))[@res.variantArgs ]) : Rgb.t) = x to y do () done -;;for (((`Rgba (r, g, b))[@res.variantArgs ]) : Rgb.t) as c = x to y do () - done -;;for (((`Rgba (r, g, b))[@res.variantArgs ]) : Rgb.t) as c = x to y do () - done +;;for `Rgba ((r : float), (g : float), (b : float)) as c = x to y do () done +;;for (`Rgba (r, g, b) : Rgb.t) = x to y do () done +;;for (`Rgba (r, g, b) : Rgb.t) as c = x to y do () done +;;for (`Rgba (r, g, b) : Rgb.t) as c = x to y do () done ;;for `Point { x; y; z } = x to y do () done ;;for `Point { x; y; z } = x to y do () done ;;for `Point { x; y; z } as p = x to y do () done @@ -76,7 +69,7 @@ let cmp [arity:2]selectedChoice value = | #b::#b::[] -> true | { x = #c; y = #c } -> true | Constructor (#a, #a) -> true - | ((`Constuctor (#a, #a))[@res.variantArgs ]) -> true + | `Constuctor (#a, #a) -> true | #a as x -> true | #a|#b -> true | (#a : typ) -> true @@ -85,5 +78,5 @@ let cmp [arity:2]selectedChoice value = ;;match polyVar with | `ease-in -> () | `ease-out⛰ -> () - | ((`ease+++ (`1Blue, `r+))[@res.variantArgs ]) -> () + | `ease+++ (`1Blue, `r+) -> () | _ -> () \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/pattern/expected/variants.res.txt b/tests/syntax_tests/data/parsing/grammar/pattern/expected/variants.res.txt index e71c03416ae..3f0c4fe83a6 100644 --- a/tests/syntax_tests/data/parsing/grammar/pattern/expected/variants.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/pattern/expected/variants.res.txt @@ -6,15 +6,15 @@ let `Instance component = i let `Instance { render; subtree } = i let `Instance { render; subtree } as x = i let `Instance ({ render; subtree } as inst) = i -let ((`Instance ({ render; subtree }, inst))[@res.variantArgs ]) = i +let `Instance ({ render; subtree }, inst) = i let `Instance ({ render; subtree } : Instance.t) = i let `Instance ({ render; subtree } : Instance.t) as inst = i let `Instance ({ render; subtree } : Instance.t) = i -let ((`Instance (component, tree))[@res.variantArgs ]) = i -let ((`Instance (component, tree))[@res.variantArgs ]) as x = i -let ((`Instance ((component as x), (tree as y)))[@res.variantArgs ]) = i -let ((`Instance (component, tree))[@res.variantArgs ]) as inst = i -let ((`Instance (component, tree))[@res.variantArgs ]) = i +let `Instance (component, tree) = i +let `Instance (component, tree) as x = i +let `Instance ((component as x), (tree as y)) = i +let `Instance (component, tree) as inst = i +let `Instance (component, tree) = i let (`Instance : React.t) = i let (`Instance : React.t) as t = i let (`Instance : React.t) as x = i @@ -26,22 +26,21 @@ let ((`Instance (component : comp)) : React.t) = i | `Instance comp -> () | `Instance comp as inst -> () | `Instance { render; subtree } -> () - | ((`Instance ({ render; subtree }, inst))[@res.variantArgs ]) -> () + | `Instance ({ render; subtree }, inst) -> () | `Instance ({ render; subtree } : Instance.t) -> () | `Instance ({ render; subtree } : Instance.t) -> () - | ((`Instance (comp, tree))[@res.variantArgs ]) -> () + | `Instance (comp, tree) -> () | (`Instance (comp : Component.t) : React.t) -> () let f [arity:1]`Instance = i let f [arity:1](`Instance as i) = i let f [arity:1](`Instance component) = i let f [arity:1](`Instance component) = i let f [arity:1](`Instance { render; subtree }) = i -let f [arity:1]((`Instance ({ render; subtree }, inst))[@res.variantArgs ]) = - i +let f [arity:1](`Instance ({ render; subtree }, inst)) = i let f [arity:1](`Instance ({ render; subtree } : Instance.t)) = i let f [arity:1](`Instance ({ render; subtree } : Instance.t)) = i -let f [arity:1]((`Instance (component, tree))[@res.variantArgs ]) = i -let f [arity:1]((`Instance (component, tree))[@res.variantArgs ]) = i +let f [arity:1](`Instance (component, tree)) = i +let f [arity:1](`Instance (component, tree)) = i let f [arity:1](`Instance : React.t) = i let f [arity:1](`Instance : React.t) = i let f [arity:1](`Instance (comp : Component.t) : React.t) = () @@ -52,19 +51,13 @@ let f [arity:1](`Instance (comp : Component.t) : React.t) = () ;;for (`Blue : Color.t) = x to y do () done ;;for (`Blue : Color.t) as c = x to y do () done ;;for (`Blue : Color.t) as c = x to y do () done -;;for ((`Rgba (r, g, b))[@res.variantArgs ]) = x to y do () done -;;for ((`Rgba (r, g, b))[@res.variantArgs ]) as c = x to y do () done +;;for `Rgba (r, g, b) = x to y do () done +;;for `Rgba (r, g, b) as c = x to y do () done ;;for Rgba ((r : float), (g : float), (b : float)) = x to y do () done -;;for ((`Rgba ((r : float), (g : float), (b : float)))[@res.variantArgs ]) as - c = - x to y do - () - done -;;for (((`Rgba (r, g, b))[@res.variantArgs ]) : Rgb.t) = x to y do () done -;;for (((`Rgba (r, g, b))[@res.variantArgs ]) : Rgb.t) as c = x to y do () - done -;;for (((`Rgba (r, g, b))[@res.variantArgs ]) : Rgb.t) as c = x to y do () - done +;;for `Rgba ((r : float), (g : float), (b : float)) as c = x to y do () done +;;for (`Rgba (r, g, b) : Rgb.t) = x to y do () done +;;for (`Rgba (r, g, b) : Rgb.t) as c = x to y do () done +;;for (`Rgba (r, g, b) : Rgb.t) as c = x to y do () done ;;for `Point { x; y; z } = x to y do () done ;;for `Point { x; y; z } = x to y do () done ;;for `Point { x; y; z } as p = x to y do () done @@ -73,4 +66,4 @@ let f [arity:1](`Instance (comp : Component.t) : React.t) = () | `1 -> () | `42 -> () | `42444 -> () - | ((`3 (x, y, z))[@res.variantArgs ]) -> Console.log3 x y z \ No newline at end of file + | `3 (x, y, z) -> Console.log3 x y z \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/recovery/pattern/expected/polyvariant.res.txt b/tests/syntax_tests/data/parsing/recovery/pattern/expected/polyvariant.res.txt index 4ea4a77783e..c35d2a874a3 100644 --- a/tests/syntax_tests/data/parsing/recovery/pattern/expected/polyvariant.res.txt +++ b/tests/syntax_tests/data/parsing/recovery/pattern/expected/polyvariant.res.txt @@ -34,7 +34,7 @@ Did you forget a `}` here? ;;match x with - | ((`Rgb (r, g, b))[@res.variantArgs ]) -> () - | ((`Rgb (r, g, Color (a, b)))[@res.variantArgs ]) -> () - | ((`Rgb (r, g, 1::2::[]))[@res.variantArgs ]) -> () + | `Rgb (r, g, b) -> () + | `Rgb (r, g, Color (a, b)) -> () + | `Rgb (r, g, 1::2::[]) -> () ;;match x with | `a () -> () | `a () -> () \ No newline at end of file diff --git a/tools/src/migrate.ml b/tools/src/migrate.ml index f58ddc47c4d..8aea503f085 100644 --- a/tools/src/migrate.ml +++ b/tools/src/migrate.ml @@ -8,7 +8,7 @@ module Int_set = Set.Make (Int) let is_unit_expr (e : Parsetree.expression) = match e.pexp_desc with - | Pexp_construct ({txt = Lident "()"}, []) -> true + | Pexp_construct ({txt = Lident "()"}, {txt = []}) -> true | _ -> false module Insert_ext = struct @@ -54,7 +54,7 @@ module Expr_utils = struct match e.pexp_desc with | Pexp_apply {funct = {pexp_desc = Pexp_ident {txt = Lident "->"}}; _} -> true - | Pexp_construct (_, [e]) + | Pexp_construct (_, {txt = [e]}) | Pexp_constraint (e, _) | Pexp_coerce (e, _, _) | Pexp_let (_, _, e) @@ -677,7 +677,12 @@ let make_mapper (deprecated_used : Cmt_utils.deprecated_used list) = | {pexp_desc = Pexp_construct (lid, arg); pexp_loc} -> ( match find_constructor_target ~loc:pexp_loc ~lid_loc:lid.loc with | Some {Constructor_replace.lid; attrs} -> - let arg = List.map (mapper.expr mapper) arg in + let arg = + { + Location.txt = List.map (mapper.expr mapper) arg.txt; + loc = mapper.location mapper arg.loc; + } + in let replaced = {exp with pexp_desc = Pexp_construct (lid, arg)} in Mapper_utils.Apply_transforms.attach_to_replacement ~attrs replaced @@ -723,7 +728,12 @@ let make_mapper (deprecated_used : Cmt_utils.deprecated_used list) = | {ppat_desc = Ppat_construct (lid, arg); ppat_loc} -> ( match find_constructor_target ~loc:ppat_loc ~lid_loc:lid.loc with | Some {Constructor_replace.lid; attrs} -> - let arg = List.map (mapper.pat mapper) arg in + let arg = + { + Location.txt = List.map (mapper.pat mapper) arg.txt; + loc = mapper.location mapper arg.loc; + } + in let replaced = {pat with ppat_desc = Ppat_construct (lid, arg)} in Mapper_utils.Apply_transforms.attach_attrs_to_pat ~attrs replaced | None -> Ast_mapper.default_mapper.pat mapper pat) diff --git a/tools/src/transforms.ml b/tools/src/transforms.ml index 924b61eb436..087927500f5 100644 --- a/tools/src/transforms.ml +++ b/tools/src/transforms.ml @@ -42,7 +42,7 @@ let drop_unit_arguments_in_apply (e : Parsetree.expression) : (* Drop only unlabelled unit arguments from an application expression. *) let is_unit_expr (e : Parsetree.expression) = match e.pexp_desc with - | Pexp_construct ({txt = Lident "()"}, []) -> true + | Pexp_construct ({txt = Lident "()"}, {txt = []}) -> true | _ -> false in match e.pexp_desc with From 3b74c814108b95d16e1eb274b44199c523c2959e Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 17:43:51 +0200 Subject: [PATCH 23/40] Reuse argument-list locations in parsing and type checking Signed-off-by: Christoph Knittel --- compiler/ml/typecore.ml | 26 ++--- compiler/syntax/src/res_core.ml | 67 +++++------ tests/ounit_tests/ounit_ast_mapper0_tests.ml | 116 +++++++++++++++++++ 3 files changed, 158 insertions(+), 51 deletions(-) diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index e09db3b62a5..3c77009d7c8 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1222,22 +1222,16 @@ exception Need_backtrack (* The parser preserves syntactic arguments for printing. Resolve their semantic grouping only after constructor disambiguation, retaining the historical equivalence of C(a, b) and C((a, b)), including for legacy PPX output. *) -let normalize_constructor_expr_args ~arity sargs = +let normalize_constructor_expr_args ~arity {Location.txt = sargs; loc} = match sargs with | [{pexp_desc = Pexp_tuple args}] when arity > 1 -> args - | {pexp_loc = first_loc} :: (_ :: _ as rest) when arity = 1 -> - let last = Ext_list.last rest in - let loc = Location.{first_loc with loc_end = last.pexp_loc.loc_end} in - [Ast_helper.Exp.tuple ~loc sargs] + | _ :: _ :: _ when arity = 1 -> [Ast_helper.Exp.tuple ~loc sargs] | sargs -> sargs -let normalize_constructor_pat_args ~arity sargs = +let normalize_constructor_pat_args ~arity {Location.txt = sargs; loc} = match sargs with | [{ppat_desc = Ppat_tuple args}] when arity > 1 -> args - | {ppat_loc = first_loc} :: (_ :: _ as rest) when arity = 1 -> - let last = Ext_list.last rest in - let loc = Location.{first_loc with loc_end = last.ppat_loc.loc_end} in - [Ast_helper.Pat.tuple ~loc sargs] + | _ :: _ :: _ when arity = 1 -> [Ast_helper.Pat.tuple ~loc sargs] | sargs -> sargs (* type_pat propagates the expected type as well as maps for @@ -1417,7 +1411,7 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp pat_attributes = sp.ppat_attributes; pat_env = !env; }) - | Ppat_construct (lid, {txt = sargs}) -> + | Ppat_construct (lid, sargs) -> let opath = try let p0, p, _ = extract_concrete_variant !env expected_ty in @@ -1510,13 +1504,13 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp pat_attributes = sp.ppat_attributes; pat_env = !env; }) - | Ppat_variant (l, {txt = sargs}) -> ( + | Ppat_variant (l, {txt = sargs; loc = args_loc}) -> ( check_polyvar_name !env loc l; let sarg = match sargs with | [] -> None | [sarg] -> Some sarg - | sargs -> Some (Ast_helper.Pat.tuple ~loc sargs) + | sargs -> Some (Ast_helper.Pat.tuple ~loc:args_loc sargs) in let arg_type = match sarg with @@ -2768,15 +2762,15 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp exp_attributes = sexp.pexp_attributes; exp_env = env; } - | Pexp_construct (lid, {txt = sargs}) -> + | Pexp_construct (lid, sargs) -> type_construct ~context env loc lid sargs ty_expected sexp.pexp_attributes - | Pexp_variant (l, {txt = sargs}) -> ( + | Pexp_variant (l, {txt = sargs; loc = args_loc}) -> ( check_polyvar_name env loc l; let sarg = match sargs with | [] -> None | [sarg] -> Some sarg - | sargs -> Some (Ast_helper.Exp.tuple ~loc sargs) + | sargs -> Some (Ast_helper.Exp.tuple ~loc:args_loc sargs) in (* Keep sharing *) let ty_expected0 = instance env ty_expected in diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 537b9561f1c..f177df1d519 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -1747,31 +1747,30 @@ and parse_pattern_args (p : Parser.t) = ~f:parse_constrained_pattern_region in Parser.expect Rparen p; - match args with - | [] -> - let loc = mk_loc lparen p.prev_end_pos in - [ - Ast_helper.Pat.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - []; - ] - | patterns -> patterns + let loc = mk_loc lparen p.prev_end_pos in + let args = + match args with + | [] -> + [ + Ast_helper.Pat.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + []; + ] + | patterns -> patterns + in + Location.mkloc args loc and parse_constructor_pattern_args p constr start_pos attrs = - let args_start = p.Parser.start_pos in - let args = parse_pattern_args p in + let {Location.txt = args; loc = args_loc} = parse_pattern_args p in Ast_helper.Pat.construct ~loc:(mk_loc start_pos p.prev_end_pos) - ~args_loc:(mk_loc args_start p.prev_end_pos) - ~attrs constr args + ~args_loc ~attrs constr args and parse_variant_pattern_args p ident start_pos attrs = - let args_start = p.Parser.start_pos in - let args = parse_pattern_args p in + let {Location.txt = args; loc = args_loc} = parse_pattern_args p in Ast_helper.Pat.variant ~loc:(mk_loc start_pos p.prev_end_pos) - ~args_loc:(mk_loc args_start p.prev_end_pos) - ~attrs ident args + ~args_loc ~attrs ident args and parse_expr ?(context = OrdinaryExpr) p = let expr = parse_operand_expr ~context p in @@ -4189,13 +4188,11 @@ and parse_value_or_constructor p = Parser.next p; aux p (ident :: acc) | Lparen when p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> - let args_start = p.start_pos in - let args = parse_constructor_args p in + let {Location.txt = args; loc = args_loc} = parse_constructor_args p in let lident = build_longident (ident :: acc) in let loc = mk_loc start_pos p.prev_end_pos in let ident_loc = mk_loc start_pos end_pos_lident in - Ast_helper.Exp.construct ~loc - ~args_loc:(mk_loc args_start p.prev_end_pos) + Ast_helper.Exp.construct ~loc ~args_loc (Location.mkloc lident ident_loc) args | _ -> @@ -4225,12 +4222,9 @@ and parse_poly_variant_expr p = let ident, _loc = parse_hash_ident ~start_pos p in match p.Parser.token with | Lparen when p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> - let args_start = p.start_pos in - let args = parse_constructor_args p in + let {Location.txt = args; loc = args_loc} = parse_constructor_args p in let loc = mk_loc start_pos p.prev_end_pos in - Ast_helper.Exp.variant ~loc - ~args_loc:(mk_loc args_start p.prev_end_pos) - ident args + Ast_helper.Exp.variant ~loc ~args_loc ident args | _ -> let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.variant ~loc ident [] @@ -4243,15 +4237,18 @@ and parse_constructor_args p = ~f:parse_constrained_expr_region ~closing:Rparen p in Parser.expect Rparen p; - match args with - | [] -> - let loc = mk_loc lparen p.prev_end_pos in - [ - Ast_helper.Exp.construct ~loc - (Location.mkloc (Longident.Lident "()") loc) - []; - ] - | args -> args + let loc = mk_loc lparen p.prev_end_pos in + let args = + match args with + | [] -> + [ + Ast_helper.Exp.construct ~loc + (Location.mkloc (Longident.Lident "()") loc) + []; + ] + | args -> args + in + Location.mkloc args loc and parse_tuple_expr ~first ~start_pos p = let exprs = diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index 648bf9fa69a..bb1bb6aeb3d 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -517,6 +517,118 @@ let test_constructor_argument_locations _ = "let #Empty = #Empty"; ] +let test_incomplete_constructor_argument_locations _ = + List.iter + (fun source -> + let parsed = + Res_driver.parse_implementation_from_source + ~display_filename:"IncompleteConstructor.res" ~source + in + let args_loc = + match parsed.parsetree with + | [ + { + pstr_desc = + Pstr_value + (_, [{pvb_expr = {pexp_desc = Pexp_construct (_, {loc})}}]); + }; + ] -> + loc + | [ + { + pstr_desc = + Pstr_value + ( _, + [ + { + pvb_expr = + { + pexp_desc = + Pexp_fun + { + body = + { + pexp_desc = + Pexp_match + ( _, + [ + { + pc_lhs = + { + ppat_desc = + Ppat_construct (_, {loc}); + }; + }; + ] ); + }; + }; + }; + }; + ] ); + }; + ] -> + loc + | _ -> assert_failure "Expected an incomplete constructor argument list" + in + let cursor = String.length source - 1 in + OUnit.assert_equal (String.index source '(') args_loc.loc_start.pos_cnum; + OUnit.assert_bool "recovery span includes the character before the cursor" + (args_loc.loc_start.pos_cnum <= cursor + && cursor < args_loc.loc_end.pos_cnum)) + [ + "let value = Pair("; + "let value = Pair(1,"; + "let read = value => switch value { | Pair("; + "let read = value => switch value { | Pair(a,"; + ] + +let test_constructor_normalization_keeps_argument_locations _ = + List.iter + (fun source -> + let parsed = + Res_driver.parse_implementation_from_source + ~display_filename:"NormalizedArgumentLocations.res" ~source + in + OUnit.assert_bool "source parses" (not parsed.invalid); + let pat, expr = + match (Ext_list.last parsed.parsetree).pstr_desc with + | Pstr_value (_, [{pvb_pat; pvb_expr}]) -> (pvb_pat, pvb_expr) + | _ -> assert_failure "Expected a constructor binding" + in + let expected_pat_loc = + match pat.ppat_desc with + | Ppat_construct (_, {loc}) | Ppat_variant (_, {loc}) -> loc + | _ -> assert_failure "Expected a constructor pattern" + in + let expected_expr_loc = + match expr.pexp_desc with + | Pexp_construct (_, {loc}) | Pexp_variant (_, {loc}) -> loc + | _ -> assert_failure "Expected a constructor expression" + in + let typed, _, _ = + Typemod.type_structure Env.initial_safe_string parsed.parsetree loc + in + let pat, expr = + match (Ext_list.last typed.str_items).str_desc with + | Tstr_value (_, [{vb_pat; vb_expr}]) -> (vb_pat, vb_expr) + | _ -> assert_failure "Expected a typed constructor binding" + in + (match pat.pat_desc with + | Tpat_construct (_, _, [{pat_desc = Tpat_tuple [_; _]; pat_loc}]) + | Tpat_variant (_, Some {pat_desc = Tpat_tuple [_; _]; pat_loc}, _) -> + OUnit.assert_equal expected_pat_loc pat_loc + | _ -> assert_failure "Expected a typed tuple payload pattern"); + match expr.exp_desc with + | Texp_construct (_, _, [{exp_desc = Texp_tuple [_; _]; exp_loc}]) + | Texp_variant (_, Some {exp_desc = Texp_tuple [_; _]; exp_loc}) -> + OUnit.assert_equal expected_expr_loc exp_loc + | _ -> assert_failure "Expected a typed tuple payload expression") + [ + "type t = Pair((int, int))\n\ + let Pair /* pattern */ (a, b) = Pair /* expression */ (1, 2)"; + "let #Pair /* pattern */ (a, b) = #Pair /* expression */ (1, 2)"; + ] + let test_fresh_ast0_constructor_tuple_reprints_without_internal_metadata _ = let int_expr value = Ast_helper0.Exp.constant ~loc (Parsetree0.Pconst_integer (value, None)) @@ -1238,6 +1350,10 @@ let suites = >:: test_constructor_args_keep_parentheses_location_in_ast0; "constructor_argument_locations" >:: test_constructor_argument_locations; + "constructor_normalization_keeps_argument_locations" + >:: test_constructor_normalization_keeps_argument_locations; + "incomplete_constructor_argument_locations" + >:: test_incomplete_constructor_argument_locations; "fresh_ast0_constructor_tuple_reprints_without_internal_metadata" >:: test_fresh_ast0_constructor_tuple_reprints_without_internal_metadata; "ast0_explicit_arity_becomes_constructor_args" From b226130d6c39e76a06b30f95581f5f0d4adb28f8 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 17:43:51 +0200 Subject: [PATCH 24/40] Use argument-list boundaries for constructor signature help Signed-off-by: Christoph Knittel --- CHANGELOG.md | 1 + analysis/src/signature_help.ml | 15 +- .../SignatureHelpConstructorBoundaries.res | 49 +++++++ ...SignatureHelpConstructorBoundaries.res.txt | 131 ++++++++++++++++++ 4 files changed, 189 insertions(+), 7 deletions(-) create mode 100644 tests/analysis_tests/tests/src/SignatureHelpConstructorBoundaries.res create mode 100644 tests/analysis_tests/tests/src/expected/SignatureHelpConstructorBoundaries.res.txt diff --git a/CHANGELOG.md b/CHANGELOG.md index 94537860f15..c48630cc2ec 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -38,6 +38,7 @@ - Fix the side-effect analysis treating bigint exponentiation and bounds-checked array and string reads as pure, which let dead-code elimination drop an unused one that throws: `let _ = 2n ** -1n` no longer raised. https://github.com/rescript-lang/rescript/pull/8617 - Preserve record field `@as` annotations when formatting object types containing spreads. https://github.com/rescript-lang/rescript/pull/8619 +- Limit constructor signature help to the argument parentheses, excluding whitespace and comments between the constructor name and its arguments. https://github.com/rescript-lang/rescript/pull/8610 - Fix excessive parentheses and indentation in function assignments to refs, align record and array assignment formatting across refs and fields, and preserve function return-type parentheses and consistent JSX fragment layout in callbacks. https://github.com/rescript-lang/rescript/pull/8611 - Report an error instead of crashing when an integer in a variant constructor's `@as` annotation exceeds the compiler's integer range. https://github.com/rescript-lang/rescript/pull/8619 - Warn about an `@as` on a record field whose payload does not name the field, such as `@as(42)`. It renamed nothing and was silently accepted. https://github.com/rescript-lang/rescript/pull/8619 diff --git a/analysis/src/signature_help.ml b/analysis/src/signature_help.ml index 3b54033e5a7..ce554524db7 100644 --- a/analysis/src/signature_help.ml +++ b/analysis/src/signature_help.ml @@ -257,9 +257,6 @@ let signature_help ~debug ~source ~kind_file ~pos let loc_has_cursor loc = loc |> Cursor_position.loc_has_cursor ~pos:pos_before_cursor in - let constructor_has_cursor lid_loc loc = - loc_has_cursor loc && pos_before_cursor >= Loc.end_ lid_loc - in let constructor_arg_index locations = let rec loop index = function | [] -> -1 @@ -416,8 +413,10 @@ let signature_help ~debug ~source ~kind_file ~pos in set_result (exp.pexp_loc, `FunctionCall (arg_at_cursor, exp, extracted_args)) - | {pexp_desc = Pexp_construct (lid, {txt = payload_exps}); pexp_loc} - when payload_exps <> [] && constructor_has_cursor lid.loc pexp_loc -> + | { + pexp_desc = Pexp_construct (lid, {txt = payload_exps; loc = args_loc}); + } + when payload_exps <> [] && loc_has_cursor args_loc -> (* Constructor payloads *) set_result (lid.loc, `ConstructorExpr (lid, payload_exps)) | _ -> ()); @@ -425,8 +424,10 @@ let signature_help ~debug ~source ~kind_file ~pos in let pat (iterator : Ast_iterator.iterator) (pat : Parsetree.pattern) = (match pat with - | {ppat_desc = Ppat_construct (lid, {txt = payload_pats}); ppat_loc} - when payload_pats <> [] && constructor_has_cursor lid.loc ppat_loc -> + | { + ppat_desc = Ppat_construct (lid, {txt = payload_pats; loc = args_loc}); + } + when payload_pats <> [] && loc_has_cursor args_loc -> (* Constructor payloads *) set_result (lid.loc, `ConstructorPat (lid, payload_pats)) | _ -> ()); diff --git a/tests/analysis_tests/tests/src/SignatureHelpConstructorBoundaries.res b/tests/analysis_tests/tests/src/SignatureHelpConstructorBoundaries.res new file mode 100644 index 00000000000..a30a5dc9ce0 --- /dev/null +++ b/tests/analysis_tests/tests/src/SignatureHelpConstructorBoundaries.res @@ -0,0 +1,49 @@ +type t = Pair(int, int) + +// Before the opening parenthesis +let _ = Pair (1, 2) +// ^she + +// Whitespace after the constructor +let _ = Pair (1, 2) +// ^she + +// Comment before arguments +let _ = Pair /* gap */ (1, 2) +// ^she + +// Just inside the opening parenthesis +let _ = Pair /* gap */ (1, 2) +// ^she + +// Between arguments +let _ = Pair(1, 2) +// ^she + +// Just after the closing parenthesis +let _ = Pair(1, 2) +// ^she + +// After the argument list +let _ = Pair(1, 2) // after +// ^she + +// Pattern whitespace before arguments +let read = value => switch value { | Pair (a, b) => a } +// ^she + +// Pattern comment before arguments +let read = value => switch value { | Pair /* gap */ (a, b) => a } +// ^she + +// Pattern opening parenthesis +let read = value => switch value { | Pair /* gap */ (a, b) => a } +// ^she + +// Pattern between arguments +let read = value => switch value { | Pair(a, b) => a } +// ^she + +// After the pattern argument list +let read = value => switch value { | Pair(a, b) => a } +// ^she diff --git a/tests/analysis_tests/tests/src/expected/SignatureHelpConstructorBoundaries.res.txt b/tests/analysis_tests/tests/src/expected/SignatureHelpConstructorBoundaries.res.txt new file mode 100644 index 00000000000..65e66f73bbc --- /dev/null +++ b/tests/analysis_tests/tests/src/expected/SignatureHelpConstructorBoundaries.res.txt @@ -0,0 +1,131 @@ +Signature help src/SignatureHelpConstructorBoundaries.res 3:14 +null + +Signature help src/SignatureHelpConstructorBoundaries.res 7:13 +null + +Signature help src/SignatureHelpConstructorBoundaries.res 11:18 +null + +Signature help src/SignatureHelpConstructorBoundaries.res 15:24 +{ + "activeParameter": 0, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 0, + "label": "Pair(int, int)", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 5, 8 ] + }, + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 10, 13 ] + } + ] + } + ] +} + +Signature help src/SignatureHelpConstructorBoundaries.res 19:15 +{ + "activeParameter": 1, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 1, + "label": "Pair(int, int)", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 5, 8 ] + }, + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 10, 13 ] + } + ] + } + ] +} + +Signature help src/SignatureHelpConstructorBoundaries.res 23:18 +{ + "activeParameter": 1, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 1, + "label": "Pair(int, int)", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 5, 8 ] + }, + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 10, 13 ] + } + ] + } + ] +} + +Signature help src/SignatureHelpConstructorBoundaries.res 27:19 +null + +Signature help src/SignatureHelpConstructorBoundaries.res 31:43 +null + +Signature help src/SignatureHelpConstructorBoundaries.res 35:47 +null + +Signature help src/SignatureHelpConstructorBoundaries.res 39:53 +{ + "activeParameter": 0, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 0, + "label": "Pair(int, int)", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 5, 8 ] + }, + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 10, 13 ] + } + ] + } + ] +} + +Signature help src/SignatureHelpConstructorBoundaries.res 43:44 +{ + "activeParameter": 1, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 1, + "label": "Pair(int, int)", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 5, 8 ] + }, + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 10, 13 ] + } + ] + } + ] +} + +Signature help src/SignatureHelpConstructorBoundaries.res 47:48 +null + From 976c63220c801c15b59fcd8aa23d15786a271bd0 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 17:49:55 +0200 Subject: [PATCH 25/40] Accept located constructor arguments in AST helpers Signed-off-by: Christoph Knittel --- analysis/src/type_utils.ml | 16 +++-- compiler/frontend/ast_derive_projector.ml | 8 ++- compiler/frontend/ast_literal.ml | 15 +++-- compiler/frontend/bs_builtin_ppx.ml | 9 +-- compiler/ml/ast_helper.ml | 18 +++--- compiler/ml/ast_helper.mli | 19 ++---- compiler/ml/ast_mapper.ml | 34 +++++----- compiler/ml/ast_mapper_from0.ml | 8 +-- compiler/ml/typecore.ml | 14 +++-- compiler/syntax/src/jsx_v4.ml | 11 +++- compiler/syntax/src/res_core.ml | 66 +++++++++++--------- tests/ounit_tests/ounit_ast_mapper0_tests.ml | 24 +++++-- 12 files changed, 138 insertions(+), 104 deletions(-) diff --git a/analysis/src/type_utils.ml b/analysis/src/type_utils.ml index 0fb50cd9e03..2a449d49f21 100644 --- a/analysis/src/type_utils.ml +++ b/analysis/src/type_utils.ml @@ -1014,15 +1014,19 @@ module Codegen = struct let mk_construct_pat ?payload name = Ast_helper.Pat.construct {Asttypes.txt = Longident.Lident name; loc = Location.none} - (match payload with - | None -> [] - | Some payload -> [payload]) + (Location.mkloc + (match payload with + | None -> [] + | Some payload -> [payload]) + !Ast_helper.default_loc) let mk_tag_pat ?payload name = Ast_helper.Pat.variant name - (match payload with - | None -> [] - | Some payload -> [payload]) + (Location.mkloc + (match payload with + | None -> [] + | Some payload -> [payload]) + !Ast_helper.default_loc) let any () = Ast_helper.Pat.any () diff --git a/compiler/frontend/ast_derive_projector.ml b/compiler/frontend/ast_derive_projector.ml index 9b3cdb7afa1..212b03528f7 100644 --- a/compiler/frontend/ast_derive_projector.ml +++ b/compiler/frontend/ast_derive_projector.ml @@ -83,7 +83,7 @@ let init () = Exp.constraint_ (Exp.construct {loc; txt = Longident.Lident con_name} - []) + (Location.mkloc [] !Ast_helper.default_loc)) annotate_type else let vars = @@ -94,8 +94,10 @@ let init () = Exp.constraint_ (Exp.construct {loc; txt = Longident.Lident con_name} - @@ Ext_list.map vars (fun x -> - Exp.ident {loc; txt = Lident x})) + (Location.mkloc + (Ext_list.map vars (fun x -> + Exp.ident {loc; txt = Lident x})) + !Ast_helper.default_loc)) annotate_type in Ast_helper.Exp.fun_ diff --git a/compiler/frontend/ast_literal.ml b/compiler/frontend/ast_literal.ml index a351c5359ea..7ef3caba9af 100644 --- a/compiler/frontend/ast_literal.ml +++ b/compiler/frontend/ast_literal.ml @@ -65,7 +65,9 @@ end module No_loc = struct let loc = Location.none - let val_unit = Ast_helper.Exp.construct {txt = Lid.val_unit; loc} [] + let val_unit = + Ast_helper.Exp.construct {txt = Lid.val_unit; loc} + (Location.mkloc [] !Ast_helper.default_loc) let type_unit = Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_unit; loc}, [])) @@ -86,7 +88,9 @@ module No_loc = struct let type_any = Ast_helper.Typ.any () - let pat_unit = Pat.construct {txt = Lid.val_unit; loc} [] + let pat_unit = + Pat.construct {txt = Lid.val_unit; loc} + (Location.mkloc [] !Ast_helper.default_loc) end type 'a lit = ?loc:Location.t -> unit -> 'a @@ -100,7 +104,9 @@ type pattern_lit = Parsetree.pattern lit let val_unit ?loc () = match loc with | None -> No_loc.val_unit - | Some loc -> Ast_helper.Exp.construct {txt = Lid.val_unit; loc} [] + | Some loc -> + Ast_helper.Exp.construct {txt = Lid.val_unit; loc} + (Location.mkloc [] !Ast_helper.default_loc) let type_unit ?loc () = match loc with @@ -150,4 +156,5 @@ let type_any ?loc () = let pat_unit ?loc () = match loc with | None -> No_loc.pat_unit - | Some loc -> Pat.construct ~loc {txt = Lid.val_unit; loc} [] + | Some loc -> + Pat.construct ~loc {txt = Lid.val_unit; loc} (Location.mkloc [] loc) diff --git a/compiler/frontend/bs_builtin_ppx.ml b/compiler/frontend/bs_builtin_ppx.ml index b28e8de53cb..8886205d148 100644 --- a/compiler/frontend/bs_builtin_ppx.ml +++ b/compiler/frontend/bs_builtin_ppx.ml @@ -265,7 +265,7 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) Ast_helper.Pat.alias (Ast_helper.Pat.construct ~loc {txt = Lident "Error"; loc} - [Ast_helper.Pat.any ~loc ()]) + (Location.mkloc [Ast_helper.Pat.any ~loc ()] loc)) {txt = var_name; loc}; pc_guard = None; pc_rhs = Ast_helper.Exp.ident ~loc {txt = Lident var_name; loc}; @@ -277,7 +277,7 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) pc_lhs = Ast_helper.Pat.alias (Ast_helper.Pat.construct ~loc {txt = Lident "Ok"; loc} - [Ast_helper.Pat.any ~loc ()]) + (Location.mkloc [Ast_helper.Pat.any ~loc ()] loc)) {txt = var_name; loc}; pc_guard = None; pc_rhs = Ast_helper.Exp.ident ~loc {txt = Lident var_name; loc}; @@ -288,7 +288,8 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) Parsetree.pc_bar = None; pc_lhs = Ast_helper.Pat.alias - (Ast_helper.Pat.construct ~loc {txt = Lident "None"; loc} []) + (Ast_helper.Pat.construct ~loc {txt = Lident "None"; loc} + (Location.mkloc [] loc)) {txt = var_name; loc}; pc_guard = None; pc_rhs = Ast_helper.Exp.ident ~loc {txt = Lident var_name; loc}; @@ -300,7 +301,7 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) pc_lhs = Ast_helper.Pat.alias (Ast_helper.Pat.construct ~loc {txt = Lident "Some"; loc} - [Ast_helper.Pat.any ~loc ()]) + (Location.mkloc [Ast_helper.Pat.any ~loc ()] loc)) {txt = var_name; loc}; pc_guard = None; pc_rhs = Ast_helper.Exp.ident ~loc {txt = Lident var_name; loc}; diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index 1b7d54ae57f..b4bc9d37dd2 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -146,10 +146,8 @@ module Pat = struct let constant ?loc ?attrs a = mk ?loc ?attrs (Ppat_constant a) let interval ?loc ?attrs a b = mk ?loc ?attrs (Ppat_interval (a, b)) let tuple ?loc ?attrs a = mk ?loc ?attrs (Ppat_tuple a) - let construct ?(loc = !default_loc) ?attrs ?(args_loc = loc) a b = - mk ~loc ?attrs (Ppat_construct (a, {txt = b; loc = args_loc})) - let variant ?(loc = !default_loc) ?attrs ?(args_loc = loc) a b = - mk ~loc ?attrs (Ppat_variant (a, {txt = b; loc = args_loc})) + let construct ?loc ?attrs a b = mk ?loc ?attrs (Ppat_construct (a, b)) + let variant ?loc ?attrs a b = mk ?loc ?attrs (Ppat_variant (a, b)) let record ?loc ?attrs ?rest a b = mk ?loc ?attrs (Ppat_record (a, b, rest)) let array ?loc ?attrs a = mk ?loc ?attrs (Ppat_array a) let or_ ?loc ?attrs a b = mk ?loc ?attrs (Ppat_or (a, b)) @@ -181,10 +179,8 @@ module Exp = struct let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) - let construct ?(loc = !default_loc) ?attrs ?(args_loc = loc) a b = - mk ~loc ?attrs (Pexp_construct (a, {txt = b; loc = args_loc})) - let variant ?(loc = !default_loc) ?attrs ?(args_loc = loc) a b = - mk ~loc ?attrs (Pexp_variant (a, {txt = b; loc = args_loc})) + let construct ?loc ?attrs a b = mk ?loc ?attrs (Pexp_construct (a, b)) + let variant ?loc ?attrs a b = mk ?loc ?attrs (Pexp_variant (a, b)) let record ?loc ?attrs a b = mk ?loc ?attrs (Pexp_record (a, b)) let field ?loc ?attrs a b = mk ?loc ?attrs (Pexp_field (a, b)) let setfield ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_setfield (a, b, c)) @@ -252,7 +248,7 @@ module Exp = struct | None -> let loc = {loc with Location.loc_ghost = true} in let nil = Location.mkloc (Longident.Lident "[]") loc in - construct ~loc nil []) + construct ~loc nil (Location.mkloc [] loc)) | e1 :: el -> let exp_el = handle_seq el in let loc = @@ -263,7 +259,9 @@ module Exp = struct loc_ghost = false; } in - construct ~loc (Location.mkloc (Longident.Lident "::") loc) [e1; exp_el] + construct ~loc + (Location.mkloc (Longident.Lident "::") loc) + (Location.mkloc [e1; exp_el] loc) in let expr = handle_seq seq in {expr with pexp_loc = loc} diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index c55904a839d..3ba39f44407 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -98,17 +98,12 @@ module Pat : sig val interval : ?loc:loc -> ?attrs:attrs -> constant -> constant -> pattern val tuple : ?loc:loc -> ?attrs:attrs -> pattern list -> pattern - (* [args_loc] spans the argument parentheses. It defaults to [loc] for - generated nodes or constructors without an argument list. *) + (* Argument lists carry their own locations. Generated nodes must supply + an explicit fallback location; see the parsetree location contract. *) val construct : - ?loc:loc -> ?attrs:attrs -> ?args_loc:loc -> lid -> pattern list -> pattern + ?loc:loc -> ?attrs:attrs -> lid -> pattern list Location.loc -> pattern val variant : - ?loc:loc -> - ?attrs:attrs -> - ?args_loc:loc -> - label -> - pattern list -> - pattern + ?loc:loc -> ?attrs:attrs -> label -> pattern list Location.loc -> pattern val record : ?loc:loc -> ?attrs:attrs -> @@ -165,16 +160,14 @@ module Exp : sig val construct : ?loc:loc -> ?attrs:attrs -> - ?args_loc:loc -> lid -> - expression list -> + expression list Location.loc -> expression val variant : ?loc:loc -> ?attrs:attrs -> - ?args_loc:loc -> label -> - expression list -> + expression list Location.loc -> expression val record : ?loc:loc -> diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 324cac02c9a..64038cc65e4 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -317,15 +317,11 @@ module E = struct | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) | Pexp_construct (lid, {txt = args; loc = args_loc}) -> - construct ~loc ~attrs - ~args_loc:(sub.location sub args_loc) - (map_loc sub lid) - (List.map (sub.expr sub) args) + construct ~loc ~attrs (map_loc sub lid) + {txt = List.map (sub.expr sub) args; loc = sub.location sub args_loc} | Pexp_variant (lab, {txt = args; loc = args_loc}) -> - variant ~loc ~attrs - ~args_loc:(sub.location sub args_loc) - lab - (List.map (sub.expr sub) args) + variant ~loc ~attrs lab + {txt = List.map (sub.expr sub) args; loc = sub.location sub args_loc} | Pexp_record (l, eo) -> record ~loc ~attrs (List.map @@ -431,15 +427,11 @@ module P = struct | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) | Ppat_construct (l, {txt = args; loc = args_loc}) -> - construct ~loc ~attrs - ~args_loc:(sub.location sub args_loc) - (map_loc sub l) - (List.map (sub.pat sub) args) + construct ~loc ~attrs (map_loc sub l) + {txt = List.map (sub.pat sub) args; loc = sub.location sub args_loc} | Ppat_variant (l, {txt = args; loc = args_loc}) -> - variant ~loc ~attrs - ~args_loc:(sub.location sub args_loc) - l - (List.map (sub.pat sub) args) + variant ~loc ~attrs l + {txt = List.map (sub.pat sub) args; loc = sub.location sub args_loc} | Ppat_record (lpl, cf, rest) -> record ~loc ~attrs ?rest: @@ -616,12 +608,16 @@ module Ppx_context = struct (Const.string x) let make_bool x = - if x then Exp.construct (lid "true") [] else Exp.construct (lid "false") [] + if x then + Exp.construct (lid "true") (Location.mkloc [] !Ast_helper.default_loc) + else Exp.construct (lid "false") (Location.mkloc [] !Ast_helper.default_loc) let rec make_list f lst = match lst with - | x :: rest -> Exp.construct (lid "::") [f x; make_list f rest] - | [] -> Exp.construct (lid "[]") [] + | x :: rest -> + Exp.construct (lid "::") + (Location.mkloc [f x; make_list f rest] !Ast_helper.default_loc) + | [] -> Exp.construct (lid "[]") (Location.mkloc [] !Ast_helper.default_loc) let make_pair f1 f2 (x1, x2) = Exp.tuple [f1 x1; f2 x2] diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 1c357c466e2..6b2666b241d 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -894,7 +894,7 @@ module E = struct || lid.txt = Longident.Lident "::") arg in - let exp1 = construct ~loc ~attrs ~args_loc lid1 args in + let exp1 = construct ~loc ~attrs lid1 {txt = args; loc = args_loc} in match lid.txt with | Lident "Function$" -> ( let rec attributes_to_arity (attrs : Parsetree.attributes) = @@ -966,7 +966,7 @@ module E = struct | _ -> None) ~split_tuple:has_constructor_args arg in - variant ~loc ~attrs ~args_loc lab args + variant ~loc ~attrs lab {txt = args; loc = args_loc} | Pexp_record (l, eo) -> record ~loc ~attrs (Ext_list.map l (fun (lid, e) -> @@ -1152,7 +1152,7 @@ module P = struct || l.txt = Longident.Lident "::") arg in - construct ~loc ~attrs ~args_loc (map_loc sub l) args + construct ~loc ~attrs (map_loc sub l) {txt = args; loc = args_loc} | Ppat_variant (l, arg) -> let has_constructor_args, attrs = remove_constructor_args_attr attrs in let args_loc = @@ -1168,7 +1168,7 @@ module P = struct | _ -> None) ~split_tuple:has_constructor_args arg in - variant ~loc ~attrs ~args_loc l args + variant ~loc ~attrs l {txt = args; loc = args_loc} | Ppat_record (lpl, cf) -> let rest, attrs = get_record_rest_attr attrs in record ~loc ~attrs ?rest diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 3c77009d7c8..de614b6ee8b 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1577,7 +1577,8 @@ and type_pat_aux ~constrs ~labels ~no_existentials ~mode ~explode ~env sp if label_is_optional ld && (not exp_optional_attr) && not is_from_pamatch then let lid = mknoloc Longident.(Ldot (Lident "*predef*", "Some")) in - Ast_helper.Pat.construct ~loc:pat.ppat_loc lid [pat] + Ast_helper.Pat.construct ~loc:pat.ppat_loc lid + (Location.mkloc [pat] pat.ppat_loc) else pat in let type_label_pat (label_lid, label, sarg, opt) k = @@ -2451,7 +2452,10 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp 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 [e] in + let e = + Ast_helper.Exp.construct ~loc:e.pexp_loc lid + (Location.mkloc [e] e.pexp_loc) + in (id, ld, e, opt) else (id, ld, e, opt) in @@ -3693,13 +3697,15 @@ and type_function ~async loc attrs env ty_expected_ Exp.case (Pat.construct ~loc:default_loc (mknoloc Longident.(Ldot (Lident "*predef*", "Some"))) - [Pat.var ~loc:default_loc (mknoloc "*sth*")]) + (Location.mkloc + [Pat.var ~loc:default_loc (mknoloc "*sth*")] + default_loc)) (Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*"))); Exp.case (Pat.construct ~loc:default_loc (mknoloc Longident.(Ldot (Lident "*predef*", "None"))) - []) + (Location.mkloc [] default_loc)) default; ] in diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index c744fe96664..0e0909414c8 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -32,7 +32,8 @@ let get_label str = let constant_string ~loc str = Ast_helper.Exp.constant ~loc (Ast_helper.Const.string str) -let unit_expr ~loc = Exp.construct ~loc (Location.mkloc (Lident "()") loc) [] +let unit_expr ~loc = + Exp.construct ~loc (Location.mkloc (Lident "()") loc) (Location.mkloc [] loc) let safe_type_from_value value_str = let value_str = get_label value_str in @@ -513,10 +514,14 @@ let vb_match ~expr (name, default, pattern, _alias, loc, _) = Exp.case (Pat.construct (Location.mknoloc @@ Lident "Some") - [Pat.var (Location.mknoloc label)]) + (Location.mkloc + [Pat.var (Location.mknoloc label)] + !Ast_helper.default_loc)) (Exp.ident (Location.mknoloc @@ Lident label)); Exp.case - (Pat.construct (Location.mknoloc @@ Lident "None") []) + (Pat.construct + (Location.mknoloc @@ Lident "None") + (Location.mkloc [] !Ast_helper.default_loc)) default; ]) in diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index f177df1d519..e7f43ce6c87 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -590,7 +590,7 @@ let make_list_pattern loc seq ext_opt = | None -> let loc = {loc with Location.loc_ghost = true} in let nil = {Location.txt = Longident.Lident "[]"; loc} in - Ast_helper.Pat.construct ~loc nil [] + Ast_helper.Pat.construct ~loc nil (Location.mkloc [] loc) in base_case | p1 :: pl -> @@ -1247,7 +1247,7 @@ let rec parse_pattern ?(alias = true) ?(or_ = true) p = let loc = mk_loc start_pos end_pos in Ast_helper.Pat.construct ~loc (Location.mkloc (Longident.Lident (Token.to_string token)) loc) - [] + (Location.mkloc [] loc) | Int _ | String _ | Float _ | Codepoint _ | Minus | Plus -> ( let c = parse_constant p in match p.token with @@ -1266,7 +1266,7 @@ let rec parse_pattern ?(alias = true) ?(or_ = true) p = Parser.next p; let loc = mk_loc start_pos p.prev_end_pos in let lid = Location.mkloc (Longident.Lident "()") loc in - Ast_helper.Pat.construct ~loc lid [] + Ast_helper.Pat.construct ~loc lid (Location.mkloc [] loc) | _ -> ( let pat = parse_constrained_pattern p in match p.token with @@ -1303,7 +1303,9 @@ let rec parse_pattern ?(alias = true) ?(or_ = true) p = let constr = parse_module_long_ident ~lowercase:false p in match p.Parser.token with | Lparen -> parse_constructor_pattern_args p constr start_pos attrs - | _ -> Ast_helper.Pat.construct ~loc:constr.loc ~attrs constr []) + | _ -> + Ast_helper.Pat.construct ~loc:constr.loc ~attrs constr + (Location.mkloc [] constr.loc)) | DotDotDot -> Parser.next p; let ident = parse_value_path p in @@ -1343,7 +1345,7 @@ let rec parse_pattern ?(alias = true) ?(or_ = true) p = in match p.Parser.token with | Lparen -> parse_variant_pattern_args p ident start_pos attrs - | _ -> Ast_helper.Pat.variant ~loc ~attrs ident []) + | _ -> Ast_helper.Pat.variant ~loc ~attrs ident (Location.mkloc [] loc)) | Exception -> Parser.next p; let pat = parse_pattern ~alias:false ~or_:false p in @@ -1754,23 +1756,23 @@ and parse_pattern_args (p : Parser.t) = [ Ast_helper.Pat.construct ~loc (Location.mkloc (Longident.Lident "()") loc) - []; + (Location.mkloc [] loc); ] | patterns -> patterns in Location.mkloc args loc and parse_constructor_pattern_args p constr start_pos attrs = - let {Location.txt = args; loc = args_loc} = parse_pattern_args p in + let args = parse_pattern_args p in Ast_helper.Pat.construct ~loc:(mk_loc start_pos p.prev_end_pos) - ~args_loc ~attrs constr args + ~attrs constr args and parse_variant_pattern_args p ident start_pos attrs = - let {Location.txt = args; loc = args_loc} = parse_pattern_args p in + let args = parse_pattern_args p in Ast_helper.Pat.variant ~loc:(mk_loc start_pos p.prev_end_pos) - ~args_loc ~attrs ident args + ~attrs ident args and parse_expr ?(context = OrdinaryExpr) p = let expr = parse_operand_expr ~context p in @@ -1992,7 +1994,7 @@ and parse_parameters p : fundef_type_param list * fundef_term_param list = let unit_pattern = Ast_helper.Pat.construct ~loc (Location.mkloc (Longident.Lident "()") loc) - [] + (Location.mkloc [] loc) in {p_label = Asttypes.Nolabel; expr = None; pat = unit_pattern} in @@ -2096,7 +2098,7 @@ and parse_atomic_expr p = let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident (Token.to_string token)) loc) - [] + (Location.mkloc [] loc) | Int _ | String _ | Float _ | Codepoint _ -> let c = parse_constant p in let loc = mk_loc start_pos p.prev_end_pos in @@ -2114,7 +2116,7 @@ and parse_atomic_expr p = let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) - [] + (Location.mkloc [] loc) | _t -> ( let expr = parse_constrained_or_coerced_expr p in match p.token with @@ -2575,7 +2577,9 @@ and over_parse_constrained_or_coerced_or_arrow_expression p expr = longident.loc), false ) | Pexp_construct (({txt = Longident.Lident "()"} as lid), {txt = []}) -> - (Ast_helper.Pat.construct ~loc:expr.pexp_loc lid [], true) + ( Ast_helper.Pat.construct ~loc:expr.pexp_loc lid + (Location.mkloc [] expr.pexp_loc), + true ) (* TODO: can we convert more expressions to patterns?*) | _ -> ( Ast_helper.Pat.var ~loc:expr.pexp_loc @@ -3599,7 +3603,7 @@ and parse_expr_block_item p = let loc = mk_loc p.start_pos p.end_pos in Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) - [] + (Location.mkloc [] loc) in let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.let_ ~loc rec_flag let_bindings next @@ -3752,7 +3756,7 @@ and parse_if_let_expr start_pos p = let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) - [] + (Location.mkloc [] loc) in let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Exp.match_ @@ -3858,7 +3862,8 @@ and parse_for_expression p = let unit_pattern = let loc = mk_loc lparen p.prev_end_pos in let lid = Location.mkloc (Longident.Lident "()") loc in - Ast_helper.Pat.construct lid [] + Ast_helper.Pat.construct lid + (Location.mkloc [] !Ast_helper.default_loc) in parse_for_rest false ~await:false (parse_alias_pattern ~attrs:[] unit_pattern p) @@ -3888,7 +3893,8 @@ and parse_for_expression p = let unit_pattern = let loc = mk_loc lparen p.prev_end_pos in let lid = Location.mkloc (Longident.Lident "()") loc in - Ast_helper.Pat.construct lid [] + Ast_helper.Pat.construct lid + (Location.mkloc [] !Ast_helper.default_loc) in parse_for_rest false ~await:true (parse_alias_pattern ~attrs:[] unit_pattern p) @@ -4020,7 +4026,9 @@ and parse_argument p : argument option = (* apply(.) — legacy uncurried unit call *) | Rparen -> let unit_expr = - Ast_helper.Exp.construct (Location.mknoloc (Longident.Lident "()")) [] + Ast_helper.Exp.construct + (Location.mknoloc (Longident.Lident "()")) + (Location.mkloc [] !Ast_helper.default_loc) in Some {label = Asttypes.Nolabel; expr = unit_expr} | _ -> parse_argument2 p) @@ -4152,7 +4160,7 @@ and parse_call_expr p fun_expr = expr = Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) - []; + (Location.mkloc [] loc); }; ] | args -> args @@ -4188,17 +4196,17 @@ and parse_value_or_constructor p = Parser.next p; aux p (ident :: acc) | Lparen when p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> - let {Location.txt = args; loc = args_loc} = parse_constructor_args p in + let args = parse_constructor_args p in let lident = build_longident (ident :: acc) in let loc = mk_loc start_pos p.prev_end_pos in let ident_loc = mk_loc start_pos end_pos_lident in - Ast_helper.Exp.construct ~loc ~args_loc - (Location.mkloc lident ident_loc) - args + Ast_helper.Exp.construct ~loc (Location.mkloc lident ident_loc) args | _ -> let loc = mk_loc start_pos p.prev_end_pos in let lident = build_longident (ident :: acc) in - Ast_helper.Exp.construct ~loc (Location.mkloc lident loc) []) + Ast_helper.Exp.construct ~loc + (Location.mkloc lident loc) + (Location.mkloc [] loc)) | Lident ident -> Parser.next p; let loc = mk_loc start_pos p.prev_end_pos in @@ -4222,12 +4230,12 @@ and parse_poly_variant_expr p = let ident, _loc = parse_hash_ident ~start_pos p in match p.Parser.token with | Lparen when p.prev_end_pos.pos_lnum == p.start_pos.pos_lnum -> - let {Location.txt = args; loc = args_loc} = parse_constructor_args p in + let args = parse_constructor_args p in let loc = mk_loc start_pos p.prev_end_pos in - Ast_helper.Exp.variant ~loc ~args_loc ident args + Ast_helper.Exp.variant ~loc ident args | _ -> let loc = mk_loc start_pos p.prev_end_pos in - Ast_helper.Exp.variant ~loc ident [] + Ast_helper.Exp.variant ~loc ident (Location.mkloc [] loc) and parse_constructor_args p = let lparen = p.Parser.start_pos in @@ -4244,7 +4252,7 @@ and parse_constructor_args p = [ Ast_helper.Exp.construct ~loc (Location.mkloc (Longident.Lident "()") loc) - []; + (Location.mkloc [] loc); ] | args -> args in diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index bb1bb6aeb3d..82216790c91 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -305,7 +305,10 @@ let test_constructor_args_roundtrip_through_ast0 _ = Ast_helper.Pat.constant ~loc (Parsetree.Pconst_integer (value, None)) in let lid = Location.mknoloc (Longident.Lident "Pair") in - let expr = Ast_helper.Exp.construct ~loc lid [int_expr "1"; int_expr "2"] in + let expr = + Ast_helper.Exp.construct ~loc lid + (Location.mkloc [int_expr "1"; int_expr "2"] loc) + in let expr0 = map_expr_to0 expr in (match expr0.pexp_desc with | Parsetree0.Pexp_construct (_, Some {pexp_desc = Pexp_tuple [_; _]}) -> @@ -319,7 +322,9 @@ let test_constructor_args_roundtrip_through_ast0 _ = (not (has_attr "_res.constructor_args" expr.pexp_attributes)) | _ -> assert_failure "Expected two constructor arguments after roundtrip"); let tuple_expr = Ast_helper.Exp.tuple ~loc [int_expr "1"; int_expr "2"] in - let expr = Ast_helper.Exp.construct ~loc lid [tuple_expr] in + let expr = + Ast_helper.Exp.construct ~loc lid (Location.mkloc [tuple_expr] loc) + in let expr0 = map_expr_to0 expr in OUnit.assert_equal ~msg:"a single tuple argument does not carry bridge metadata" [] @@ -331,7 +336,10 @@ let test_constructor_args_roundtrip_through_ast0 _ = | Parsetree.Pexp_construct (_, {txt = [{pexp_desc = Pexp_tuple [_; _]}]}) -> () | _ -> assert_failure "Expected one tuple argument after roundtrip"); - let pat = Ast_helper.Pat.construct ~loc lid [int_pat "1"; int_pat "2"] in + let pat = + Ast_helper.Pat.construct ~loc lid + (Location.mkloc [int_pat "1"; int_pat "2"] loc) + in let pat0 = map_pat_to0 pat in (match pat0.ppat_desc with | Parsetree0.Ppat_construct (_, Some {ppat_desc = Ppat_tuple [_; _]}) -> @@ -777,7 +785,10 @@ let test_polyvariant_args_roundtrip_through_ast0 _ = let int_pat value = Ast_helper.Pat.constant ~loc (Parsetree.Pconst_integer (value, None)) in - let expr = Ast_helper.Exp.variant ~loc "Pair" [int_expr "1"; int_expr "2"] in + let expr = + Ast_helper.Exp.variant ~loc "Pair" + (Location.mkloc [int_expr "1"; int_expr "2"] loc) + in let expr0 = map_expr_to0 expr in (match expr0.pexp_desc with | Parsetree0.Pexp_variant ("Pair", Some {pexp_desc = Pexp_tuple [_; _]}) -> @@ -787,7 +798,10 @@ let test_polyvariant_args_roundtrip_through_ast0 _ = (match (map_expr0 expr0).pexp_desc with | Parsetree.Pexp_variant ("Pair", {txt = [_; _]}) -> () | _ -> assert_failure "Expected two polymorphic variant arguments"); - let pat = Ast_helper.Pat.variant ~loc "Pair" [int_pat "1"; int_pat "2"] in + let pat = + Ast_helper.Pat.variant ~loc "Pair" + (Location.mkloc [int_pat "1"; int_pat "2"] loc) + in let pat0 = map_pat_to0 pat in (match pat0.ppat_desc with | Parsetree0.Ppat_variant ("Pair", Some {ppat_desc = Ppat_tuple [_; _]}) -> From 0fb03550b6445c24fc2a741325e9f27ed1be7ad0 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 17:50:37 +0200 Subject: [PATCH 26/40] Separate constructor argument tests from AST0 bridge coverage Signed-off-by: Christoph Knittel --- tests/ounit_tests/ounit_ast_mapper0_tests.ml | 169 +------------- .../ounit_constructor_arguments_tests.ml | 209 ++++++++++++++++++ tests/ounit_tests/ounit_tests_main.ml | 1 + 3 files changed, 214 insertions(+), 165 deletions(-) create mode 100644 tests/ounit_tests/ounit_constructor_arguments_tests.ml diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index 82216790c91..45d88f80c78 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -423,7 +423,7 @@ let test_polyvariant_args_keep_parentheses_location_in_ast0 _ = "let #\"quoted label\"(a,\n b) = #\"quoted label\"(1,\n 2)"; ] -let test_constructor_argument_locations _ = +let test_constructor_argument_locations_through_ast0 _ = let pattern_args_loc (pat : Parsetree.pattern) = match pat.ppat_desc with | Ppat_construct (_, {loc}) | Ppat_variant (_, {loc}) -> loc @@ -434,13 +434,6 @@ let test_constructor_argument_locations _ = | Pexp_construct (_, {loc}) | Pexp_variant (_, {loc}) -> loc | _ -> assert_failure "Expected a constructor expression" in - let shift_loc _ (loc : Location.t) = - { - loc with - loc_start = {loc.loc_start with pos_cnum = loc.loc_start.pos_cnum + 100}; - loc_end = {loc.loc_end with pos_cnum = loc.loc_end.pos_cnum + 100}; - } - in List.iter (fun source -> let parsed = @@ -473,45 +466,7 @@ let test_constructor_argument_locations _ = (pattern_args_loc (map_pat0 (map_pat_to0 pat))); OUnit.assert_equal ~msg:"v0 uses the payload span for a single argument" expected_expr_bridge_loc - (expression_args_loc (map_expr0 (map_expr_to0 expr))); - let equals = String.index source '=' in - let assert_span start finish (loc : Location.t) = - OUnit.assert_equal start loc.loc_start.pos_cnum; - OUnit.assert_equal finish loc.loc_end.pos_cnum - in - if String.contains source '(' then ( - assert_span (String.index source '(') - (1 + String.rindex_from source equals ')') - pat_loc; - assert_span - (String.index_from source equals '(') - (1 + String.rindex source ')') - expr_loc) - else ( - OUnit.assert_equal pat.ppat_loc pat_loc; - OUnit.assert_equal expr.pexp_loc expr_loc); - let mapper = Ast_mapper.default_mapper in - OUnit.assert_equal pat (mapper.pat mapper pat); - OUnit.assert_equal expr (mapper.expr mapper expr); - let mapper = {mapper with location = shift_loc} in - OUnit.assert_equal (shift_loc () pat_loc) - (pattern_args_loc (mapper.pat mapper pat)); - OUnit.assert_equal (shift_loc () expr_loc) - (expression_args_loc (mapper.expr mapper expr)); - let visited = ref [] in - let iterator = - { - Ast_iterator.default_iterator with - location = (fun _ loc -> visited := loc :: !visited); - } - in - iterator.pat iterator pat; - OUnit.assert_bool "iterator visits pattern argument span" - (List.mem pat_loc !visited); - visited := []; - iterator.expr iterator expr; - OUnit.assert_bool "iterator visits expression argument span" - (List.mem expr_loc !visited)) + (expression_args_loc (map_expr0 (map_expr_to0 expr)))) [ "let Pair /* pattern */ (a, b) = Pair /* expression */ (1, 2)"; "let Pair((a, b)) = Pair((1, 2))"; @@ -525,118 +480,6 @@ let test_constructor_argument_locations _ = "let #Empty = #Empty"; ] -let test_incomplete_constructor_argument_locations _ = - List.iter - (fun source -> - let parsed = - Res_driver.parse_implementation_from_source - ~display_filename:"IncompleteConstructor.res" ~source - in - let args_loc = - match parsed.parsetree with - | [ - { - pstr_desc = - Pstr_value - (_, [{pvb_expr = {pexp_desc = Pexp_construct (_, {loc})}}]); - }; - ] -> - loc - | [ - { - pstr_desc = - Pstr_value - ( _, - [ - { - pvb_expr = - { - pexp_desc = - Pexp_fun - { - body = - { - pexp_desc = - Pexp_match - ( _, - [ - { - pc_lhs = - { - ppat_desc = - Ppat_construct (_, {loc}); - }; - }; - ] ); - }; - }; - }; - }; - ] ); - }; - ] -> - loc - | _ -> assert_failure "Expected an incomplete constructor argument list" - in - let cursor = String.length source - 1 in - OUnit.assert_equal (String.index source '(') args_loc.loc_start.pos_cnum; - OUnit.assert_bool "recovery span includes the character before the cursor" - (args_loc.loc_start.pos_cnum <= cursor - && cursor < args_loc.loc_end.pos_cnum)) - [ - "let value = Pair("; - "let value = Pair(1,"; - "let read = value => switch value { | Pair("; - "let read = value => switch value { | Pair(a,"; - ] - -let test_constructor_normalization_keeps_argument_locations _ = - List.iter - (fun source -> - let parsed = - Res_driver.parse_implementation_from_source - ~display_filename:"NormalizedArgumentLocations.res" ~source - in - OUnit.assert_bool "source parses" (not parsed.invalid); - let pat, expr = - match (Ext_list.last parsed.parsetree).pstr_desc with - | Pstr_value (_, [{pvb_pat; pvb_expr}]) -> (pvb_pat, pvb_expr) - | _ -> assert_failure "Expected a constructor binding" - in - let expected_pat_loc = - match pat.ppat_desc with - | Ppat_construct (_, {loc}) | Ppat_variant (_, {loc}) -> loc - | _ -> assert_failure "Expected a constructor pattern" - in - let expected_expr_loc = - match expr.pexp_desc with - | Pexp_construct (_, {loc}) | Pexp_variant (_, {loc}) -> loc - | _ -> assert_failure "Expected a constructor expression" - in - let typed, _, _ = - Typemod.type_structure Env.initial_safe_string parsed.parsetree loc - in - let pat, expr = - match (Ext_list.last typed.str_items).str_desc with - | Tstr_value (_, [{vb_pat; vb_expr}]) -> (vb_pat, vb_expr) - | _ -> assert_failure "Expected a typed constructor binding" - in - (match pat.pat_desc with - | Tpat_construct (_, _, [{pat_desc = Tpat_tuple [_; _]; pat_loc}]) - | Tpat_variant (_, Some {pat_desc = Tpat_tuple [_; _]; pat_loc}, _) -> - OUnit.assert_equal expected_pat_loc pat_loc - | _ -> assert_failure "Expected a typed tuple payload pattern"); - match expr.exp_desc with - | Texp_construct (_, _, [{exp_desc = Texp_tuple [_; _]; exp_loc}]) - | Texp_variant (_, Some {exp_desc = Texp_tuple [_; _]; exp_loc}) -> - OUnit.assert_equal expected_expr_loc exp_loc - | _ -> assert_failure "Expected a typed tuple payload expression") - [ - "type t = Pair((int, int))\n\ - let Pair /* pattern */ (a, b) = Pair /* expression */ (1, 2)"; - "let #Pair /* pattern */ (a, b) = #Pair /* expression */ (1, 2)"; - ] - let test_fresh_ast0_constructor_tuple_reprints_without_internal_metadata _ = let int_expr value = Ast_helper0.Exp.constant ~loc (Parsetree0.Pconst_integer (value, None)) @@ -1362,12 +1205,8 @@ let suites = >:: test_constructor_args_roundtrip_through_ast0; "constructor_args_keep_parentheses_location_in_ast0" >:: test_constructor_args_keep_parentheses_location_in_ast0; - "constructor_argument_locations" - >:: test_constructor_argument_locations; - "constructor_normalization_keeps_argument_locations" - >:: test_constructor_normalization_keeps_argument_locations; - "incomplete_constructor_argument_locations" - >:: test_incomplete_constructor_argument_locations; + "constructor_argument_locations_through_ast0" + >:: test_constructor_argument_locations_through_ast0; "fresh_ast0_constructor_tuple_reprints_without_internal_metadata" >:: test_fresh_ast0_constructor_tuple_reprints_without_internal_metadata; "ast0_explicit_arity_becomes_constructor_args" diff --git a/tests/ounit_tests/ounit_constructor_arguments_tests.ml b/tests/ounit_tests/ounit_constructor_arguments_tests.ml new file mode 100644 index 00000000000..e770846c1f1 --- /dev/null +++ b/tests/ounit_tests/ounit_constructor_arguments_tests.ml @@ -0,0 +1,209 @@ +let ( >:: ), ( >::: ) = OUnit.(( >:: ), ( >::: )) +let assert_failure = OUnit.assert_failure + +let test_constructor_argument_locations _ = + let pattern_args_loc (pat : Parsetree.pattern) = + match pat.ppat_desc with + | Ppat_construct (_, {loc}) | Ppat_variant (_, {loc}) -> loc + | _ -> assert_failure "Expected a constructor pattern" + in + let expression_args_loc (expr : Parsetree.expression) = + match expr.pexp_desc with + | Pexp_construct (_, {loc}) | Pexp_variant (_, {loc}) -> loc + | _ -> assert_failure "Expected a constructor expression" + in + let shift_loc _ (loc : Location.t) = + { + loc with + loc_start = {loc.loc_start with pos_cnum = loc.loc_start.pos_cnum + 100}; + loc_end = {loc.loc_end with pos_cnum = loc.loc_end.pos_cnum + 100}; + } + in + List.iter + (fun source -> + let parsed = + Res_driver.parse_implementation_from_source + ~display_filename:"ArgumentLocations.res" ~source + in + OUnit.assert_bool "source parses" (not parsed.invalid); + let pat, expr = + match parsed.parsetree with + | [{pstr_desc = Pstr_value (_, [{pvb_pat; pvb_expr}])}] -> + (pvb_pat, pvb_expr) + | _ -> assert_failure "Expected a constructor binding" + in + let pat_loc = pattern_args_loc pat in + let expr_loc = expression_args_loc expr in + let equals = String.index source '=' in + let assert_span start finish (loc : Location.t) = + OUnit.assert_equal start loc.loc_start.pos_cnum; + OUnit.assert_equal finish loc.loc_end.pos_cnum + in + if String.contains source '(' then ( + assert_span (String.index source '(') + (1 + String.rindex_from source equals ')') + pat_loc; + assert_span + (String.index_from source equals '(') + (1 + String.rindex source ')') + expr_loc) + else ( + OUnit.assert_equal pat.ppat_loc pat_loc; + OUnit.assert_equal expr.pexp_loc expr_loc); + let mapper = Ast_mapper.default_mapper in + OUnit.assert_equal pat (mapper.pat mapper pat); + OUnit.assert_equal expr (mapper.expr mapper expr); + let mapper = {mapper with location = shift_loc} in + OUnit.assert_equal (shift_loc () pat_loc) + (pattern_args_loc (mapper.pat mapper pat)); + OUnit.assert_equal (shift_loc () expr_loc) + (expression_args_loc (mapper.expr mapper expr)); + let visited = ref [] in + let iterator = + { + Ast_iterator.default_iterator with + location = (fun _ loc -> visited := loc :: !visited); + } + in + iterator.pat iterator pat; + OUnit.assert_bool "iterator visits pattern argument span" + (List.mem pat_loc !visited); + visited := []; + iterator.expr iterator expr; + OUnit.assert_bool "iterator visits expression argument span" + (List.mem expr_loc !visited)) + [ + "let Pair /* pattern */ (a, b) = Pair /* expression */ (1, 2)"; + "let Pair((a, b)) = Pair((1, 2))"; + "let Single(a) = Single(1)"; + "let Unit() = Unit()"; + "let Empty = Empty"; + "let #Pair /* pattern */ (a, b) = #Pair /* expression */ (1, 2)"; + "let #Pair((a, b)) = #Pair((1, 2))"; + "let #Single(a) = #Single(1)"; + "let #Unit() = #Unit()"; + "let #Empty = #Empty"; + ] + +let test_incomplete_constructor_argument_locations _ = + List.iter + (fun source -> + let parsed = + Res_driver.parse_implementation_from_source + ~display_filename:"IncompleteConstructor.res" ~source + in + let args_loc = + match parsed.parsetree with + | [ + { + pstr_desc = + Pstr_value + (_, [{pvb_expr = {pexp_desc = Pexp_construct (_, {loc})}}]); + }; + ] -> + loc + | [ + { + pstr_desc = + Pstr_value + ( _, + [ + { + pvb_expr = + { + pexp_desc = + Pexp_fun + { + body = + { + pexp_desc = + Pexp_match + ( _, + [ + { + pc_lhs = + { + ppat_desc = + Ppat_construct (_, {loc}); + }; + }; + ] ); + }; + }; + }; + }; + ] ); + }; + ] -> + loc + | _ -> assert_failure "Expected an incomplete constructor argument list" + in + let cursor = String.length source - 1 in + OUnit.assert_equal (String.index source '(') args_loc.loc_start.pos_cnum; + OUnit.assert_bool "recovery span includes the character before the cursor" + (args_loc.loc_start.pos_cnum <= cursor + && cursor < args_loc.loc_end.pos_cnum)) + [ + "let value = Pair("; + "let value = Pair(1,"; + "let read = value => switch value { | Pair("; + "let read = value => switch value { | Pair(a,"; + ] + +let test_constructor_normalization_keeps_argument_locations _ = + List.iter + (fun source -> + let parsed = + Res_driver.parse_implementation_from_source + ~display_filename:"NormalizedArgumentLocations.res" ~source + in + OUnit.assert_bool "source parses" (not parsed.invalid); + let pat, expr = + match (Ext_list.last parsed.parsetree).pstr_desc with + | Pstr_value (_, [{pvb_pat; pvb_expr}]) -> (pvb_pat, pvb_expr) + | _ -> assert_failure "Expected a constructor binding" + in + let expected_pat_loc = + match pat.ppat_desc with + | Ppat_construct (_, {loc}) | Ppat_variant (_, {loc}) -> loc + | _ -> assert_failure "Expected a constructor pattern" + in + let expected_expr_loc = + match expr.pexp_desc with + | Pexp_construct (_, {loc}) | Pexp_variant (_, {loc}) -> loc + | _ -> assert_failure "Expected a constructor expression" + in + let typed, _, _ = + Typemod.type_structure Env.initial_safe_string parsed.parsetree + Location.none + in + let pat, expr = + match (Ext_list.last typed.str_items).str_desc with + | Tstr_value (_, [{vb_pat; vb_expr}]) -> (vb_pat, vb_expr) + | _ -> assert_failure "Expected a typed constructor binding" + in + (match pat.pat_desc with + | Tpat_construct (_, _, [{pat_desc = Tpat_tuple [_; _]; pat_loc}]) + | Tpat_variant (_, Some {pat_desc = Tpat_tuple [_; _]; pat_loc}, _) -> + OUnit.assert_equal expected_pat_loc pat_loc + | _ -> assert_failure "Expected a typed tuple payload pattern"); + match expr.exp_desc with + | Texp_construct (_, _, [{exp_desc = Texp_tuple [_; _]; exp_loc}]) + | Texp_variant (_, Some {exp_desc = Texp_tuple [_; _]; exp_loc}) -> + OUnit.assert_equal expected_expr_loc exp_loc + | _ -> assert_failure "Expected a typed tuple payload expression") + [ + "type t = Pair((int, int))\n\ + let Pair /* pattern */ (a, b) = Pair /* expression */ (1, 2)"; + "let #Pair /* pattern */ (a, b) = #Pair /* expression */ (1, 2)"; + ] + +let suites = + __FILE__ + >::: [ + "constructor_argument_locations" >:: test_constructor_argument_locations; + "constructor_normalization_keeps_argument_locations" + >:: test_constructor_normalization_keeps_argument_locations; + "incomplete_constructor_argument_locations" + >:: test_incomplete_constructor_argument_locations; + ] diff --git a/tests/ounit_tests/ounit_tests_main.ml b/tests/ounit_tests/ounit_tests_main.ml index 453aa778156..c0114346a47 100644 --- a/tests/ounit_tests/ounit_tests_main.ml +++ b/tests/ounit_tests/ounit_tests_main.ml @@ -25,6 +25,7 @@ let suites = Ounit_exits_tests.suites; Ounit_sroa_tests.suites; Ounit_ast_mapper0_tests.suites; + Ounit_constructor_arguments_tests.suites; Ounit_object_mutability_tests.suites; Ounit_pattern_printer_tests.suites; Ounit_js_analyzer_tests.suites; From b8368e9b4c8b960e2a29c6eec6a4cfcc20706637 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 17:51:11 +0200 Subject: [PATCH 27/40] Document the constructor argument AST0 bridge contract Signed-off-by: Christoph Knittel --- compiler/ml/ast_mapper_from0.ml | 21 +++++++++++++++++++-- compiler/ml/ast_mapper_to0.ml | 1 + 2 files changed, 20 insertions(+), 2 deletions(-) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 6b2666b241d..a735def6cdf 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -183,8 +183,25 @@ let remove_constructor_args_attr (attrs : Pt.attributes) = in loop [] attrs -(* Unmarked v0 tuples remain a single syntactic payload. Typecore resolves - semantic argument grouping after it knows the constructor declaration. *) +(* Constructor argument bridge contract (shared with Ast_mapper_to0): + + The current parsetree records source argument lists, not declaration arity. + Frozen v0 has only an optional payload, so encoding multiple arguments + packs them into a tuple and adds [_res.constructor_args] to the constructor. + A single tuple argument needs no marker. Polymorphic variant type payload + groups use the same encoding, with the marker on the tuple type itself. + + Decoding consumes the internal marker and restores the source list. + Ordinary constructors also accept PPX-produced [explicit_arity] and + [ocaml.explicit_arity] attributes, and always split the list constructor + [::]. Other unmarked v0 tuples remain a single syntactic payload; Typecore + resolves semantic grouping once it knows the constructor declaration. + + The tuple used to encode multiple arguments carries the argument-list + location, preserving its parentheses span. For a single argument, v0 + cannot store both the payload and outer argument-list locations: decoding + falls back to the payload location. Nullary constructors use the enclosing + node location. No location-only attributes are needed. *) let decode_args ~map ~tuple_args ~split_tuple = function | None -> [] | Some arg -> ( diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 8855aebdb1d..9ccf5ca4ea0 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -112,6 +112,7 @@ let constructor_args_attr_name = "_res.constructor_args" let add_constructor_args_attr attrs = (Location.mknoloc constructor_args_attr_name, Pt.PStr []) :: attrs +(* See the constructor argument bridge contract at Ast_mapper_from0.decode_args. *) let encode_args ~map ~tuple ~loc ~attrs args = match List.map map args with | [] -> (None, attrs) From a6352c80403e027f9d9188bd5c9a48af9c3fe86a Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 17:59:40 +0200 Subject: [PATCH 28/40] Use explicit locations at constructor helper call sites Signed-off-by: Christoph Knittel --- analysis/src/type_utils.ml | 10 ++++------ compiler/frontend/ast_derive_projector.ml | 12 +++++++----- compiler/frontend/ast_literal.ml | 10 +++------- compiler/ml/ast_mapper.ml | 10 ++++------ compiler/syntax/src/jsx_v4.ml | 6 ++---- compiler/syntax/src/res_core.ml | 8 +++----- 6 files changed, 23 insertions(+), 33 deletions(-) diff --git a/analysis/src/type_utils.ml b/analysis/src/type_utils.ml index 2a449d49f21..90ad157e12d 100644 --- a/analysis/src/type_utils.ml +++ b/analysis/src/type_utils.ml @@ -1014,19 +1014,17 @@ module Codegen = struct let mk_construct_pat ?payload name = Ast_helper.Pat.construct {Asttypes.txt = Longident.Lident name; loc = Location.none} - (Location.mkloc + (Location.mknoloc (match payload with | None -> [] - | Some payload -> [payload]) - !Ast_helper.default_loc) + | Some payload -> [payload])) let mk_tag_pat ?payload name = Ast_helper.Pat.variant name - (Location.mkloc + (Location.mknoloc (match payload with | None -> [] - | Some payload -> [payload]) - !Ast_helper.default_loc) + | Some payload -> [payload])) let any () = Ast_helper.Pat.any () diff --git a/compiler/frontend/ast_derive_projector.ml b/compiler/frontend/ast_derive_projector.ml index 212b03528f7..edec70be4bf 100644 --- a/compiler/frontend/ast_derive_projector.ml +++ b/compiler/frontend/ast_derive_projector.ml @@ -83,7 +83,7 @@ let init () = Exp.constraint_ (Exp.construct {loc; txt = Longident.Lident con_name} - (Location.mkloc [] !Ast_helper.default_loc)) + {txt = []; loc}) annotate_type else let vars = @@ -94,10 +94,12 @@ let init () = Exp.constraint_ (Exp.construct {loc; txt = Longident.Lident con_name} - (Location.mkloc - (Ext_list.map vars (fun x -> - Exp.ident {loc; txt = Lident x})) - !Ast_helper.default_loc)) + { + txt = + Ext_list.map vars (fun x -> + Exp.ident {loc; txt = Lident x}); + loc; + }) annotate_type in Ast_helper.Exp.fun_ diff --git a/compiler/frontend/ast_literal.ml b/compiler/frontend/ast_literal.ml index 7ef3caba9af..03fd5a29789 100644 --- a/compiler/frontend/ast_literal.ml +++ b/compiler/frontend/ast_literal.ml @@ -66,8 +66,7 @@ module No_loc = struct let loc = Location.none let val_unit = - Ast_helper.Exp.construct {txt = Lid.val_unit; loc} - (Location.mkloc [] !Ast_helper.default_loc) + Ast_helper.Exp.construct {txt = Lid.val_unit; loc} {txt = []; loc} let type_unit = Ast_helper.Typ.mk (Ptyp_constr ({txt = Lid.type_unit; loc}, [])) @@ -88,9 +87,7 @@ module No_loc = struct let type_any = Ast_helper.Typ.any () - let pat_unit = - Pat.construct {txt = Lid.val_unit; loc} - (Location.mkloc [] !Ast_helper.default_loc) + let pat_unit = Pat.construct {txt = Lid.val_unit; loc} {txt = []; loc} end type 'a lit = ?loc:Location.t -> unit -> 'a @@ -105,8 +102,7 @@ let val_unit ?loc () = match loc with | None -> No_loc.val_unit | Some loc -> - Ast_helper.Exp.construct {txt = Lid.val_unit; loc} - (Location.mkloc [] !Ast_helper.default_loc) + Ast_helper.Exp.construct {txt = Lid.val_unit; loc} {txt = []; loc} let type_unit ?loc () = match loc with diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 64038cc65e4..207d2880cbc 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -608,16 +608,14 @@ module Ppx_context = struct (Const.string x) let make_bool x = - if x then - Exp.construct (lid "true") (Location.mkloc [] !Ast_helper.default_loc) - else Exp.construct (lid "false") (Location.mkloc [] !Ast_helper.default_loc) + if x then Exp.construct (lid "true") (Location.mknoloc []) + else Exp.construct (lid "false") (Location.mknoloc []) let rec make_list f lst = match lst with | x :: rest -> - Exp.construct (lid "::") - (Location.mkloc [f x; make_list f rest] !Ast_helper.default_loc) - | [] -> Exp.construct (lid "[]") (Location.mkloc [] !Ast_helper.default_loc) + Exp.construct (lid "::") (Location.mknoloc [f x; make_list f rest]) + | [] -> Exp.construct (lid "[]") (Location.mknoloc []) let make_pair f1 f2 (x1, x2) = Exp.tuple [f1 x1; f2 x2] diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index 0e0909414c8..4a7775fdb60 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -514,14 +514,12 @@ let vb_match ~expr (name, default, pattern, _alias, loc, _) = Exp.case (Pat.construct (Location.mknoloc @@ Lident "Some") - (Location.mkloc - [Pat.var (Location.mknoloc label)] - !Ast_helper.default_loc)) + (Location.mknoloc [Pat.var (Location.mknoloc label)])) (Exp.ident (Location.mknoloc @@ Lident label)); Exp.case (Pat.construct (Location.mknoloc @@ Lident "None") - (Location.mkloc [] !Ast_helper.default_loc)) + (Location.mknoloc [])) default; ]) in diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index e7f43ce6c87..cf1ee2593b7 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -3862,8 +3862,7 @@ and parse_for_expression p = let unit_pattern = let loc = mk_loc lparen p.prev_end_pos in let lid = Location.mkloc (Longident.Lident "()") loc in - Ast_helper.Pat.construct lid - (Location.mkloc [] !Ast_helper.default_loc) + Ast_helper.Pat.construct lid {txt = []; loc} in parse_for_rest false ~await:false (parse_alias_pattern ~attrs:[] unit_pattern p) @@ -3893,8 +3892,7 @@ and parse_for_expression p = let unit_pattern = let loc = mk_loc lparen p.prev_end_pos in let lid = Location.mkloc (Longident.Lident "()") loc in - Ast_helper.Pat.construct lid - (Location.mkloc [] !Ast_helper.default_loc) + Ast_helper.Pat.construct lid {txt = []; loc} in parse_for_rest false ~await:true (parse_alias_pattern ~attrs:[] unit_pattern p) @@ -4028,7 +4026,7 @@ and parse_argument p : argument option = let unit_expr = Ast_helper.Exp.construct (Location.mknoloc (Longident.Lident "()")) - (Location.mkloc [] !Ast_helper.default_loc) + (Location.mknoloc []) in Some {label = Asttypes.Nolabel; expr = unit_expr} | _ -> parse_argument2 p) From fb1e677b335b7ca404e24fbb60b366ef18f605bd Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 21:33:09 +0200 Subject: [PATCH 29/40] Normalize constructor tuple paths in completion Signed-off-by: Christoph Knittel --- analysis/src/type_utils.ml | 36 ++++++++-- .../tests/src/CompletionConstructorTuple.res | 16 +++++ .../CompletionConstructorTuple.res.txt | 65 +++++++++++++++++++ 3 files changed, 113 insertions(+), 4 deletions(-) create mode 100644 tests/analysis_tests/tests/src/CompletionConstructorTuple.res create mode 100644 tests/analysis_tests/tests/src/expected/CompletionConstructorTuple.res.txt diff --git a/analysis/src/type_utils.ml b/analysis/src/type_utils.ml index 90ad157e12d..0bc5488be53 100644 --- a/analysis/src/type_utils.ml +++ b/analysis/src/type_utils.ml @@ -603,6 +603,13 @@ let extract_type_from_resolved_type (typ : Type.t) ~env ~full ~state = (** The context we just came from as we resolve the nested structure. *) type ctx = Rfield of string (** A record field of name *) +let normalize_constructor_payload_path ~argument_count ~item_num ~nested = + match nested with + | Completable.NTupleItem {item_num = tuple_item_num} :: nested + when item_num = 0 && argument_count > 1 -> + (tuple_item_num, nested) + | _ -> (item_num, nested) + let rec resolve_nested ?type_arg_context ~env ~full ~state ~nested ?ctx (typ : completion_type) = let extract_type = extract_type ?type_arg_context in @@ -736,6 +743,10 @@ let rec resolve_nested ?type_arg_context ~env ~full ~state ~nested ?ctx | Some {args = Args args} -> ( if Debug.verbose () then print_endline "[nested]--> found constructor (Args type)"; + let item_num, nested = + normalize_constructor_payload_path ~argument_count:(List.length args) + ~item_num ~nested + in match List.nth_opt args item_num with | None -> if Debug.verbose () then @@ -908,11 +919,28 @@ let rec resolve_nested_pattern_path (typ : inner_type) ~env ~full ~state ~nested Tvariant {env; constructors} ) -> ( match constructors - |> find_type_of_constructor_arg ~constructor_name - ~payload_num:item_num ~env + |> List.find_opt (fun (constructor : Constructor.t) -> + constructor.cname.txt = constructor_name) with - | Some typ -> - typ |> resolve_nested_pattern_path ~env ~state ~full ~nested + | Some {args = Args args} -> ( + let item_num, nested = + normalize_constructor_payload_path + ~argument_count:(List.length args) ~item_num ~nested + in + match List.nth_opt args item_num with + | Some (typ, _) -> + TypeExpr typ + |> resolve_nested_pattern_path ~env ~state ~full ~nested + | None -> None) + | Some {args = InlineRecord _} -> ( + match + constructors + |> find_type_of_constructor_arg ~constructor_name + ~payload_num:item_num ~env + with + | Some typ -> + typ |> resolve_nested_pattern_path ~env ~state ~full ~nested + | None -> None) | None -> None) | ( NPolyvariantPayload {constructor_name; item_num}, Tpolyvariant {env; constructors} ) -> ( diff --git a/tests/analysis_tests/tests/src/CompletionConstructorTuple.res b/tests/analysis_tests/tests/src/CompletionConstructorTuple.res new file mode 100644 index 00000000000..b777f6ec07f --- /dev/null +++ b/tests/analysis_tests/tests/src/CompletionConstructorTuple.res @@ -0,0 +1,16 @@ +type payload = { + name: string, + enabled: bool, +} + +type t = Pair(int, payload) + +let consume = (value: t) => ignore(value) + +// consume(Pair((1, {}))) +// ^com + +let value = Pair(1, {name: "test", enabled: true}) + +// switch value { | Pair((_, {}))} +// ^com diff --git a/tests/analysis_tests/tests/src/expected/CompletionConstructorTuple.res.txt b/tests/analysis_tests/tests/src/expected/CompletionConstructorTuple.res.txt new file mode 100644 index 00000000000..d839dfdfcef --- /dev/null +++ b/tests/analysis_tests/tests/src/expected/CompletionConstructorTuple.res.txt @@ -0,0 +1,65 @@ +Complete src/CompletionConstructorTuple.res 9:22 +posCursor:[9:22] posNoWhite:[9:21] Found expr:[9:3->9:25] +Pexp_apply ...[9:3->9:10] (...[9:11->9:24]) +Completable: Cexpression CArgument Value[consume]($0)->variantPayload::Pair($0), tuple($1), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath CArgument Value[consume]($0) +ContextPath Value[consume] +Path consume +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionConstructorTuple.res 14:30 +posCursor:[14:30] posNoWhite:[14:29] Found pattern:[14:20->14:33] +Ppat_construct Pair:[14:20->14:24] +posCursor:[14:30] posNoWhite:[14:29] Found pattern:[14:25->14:32] +posCursor:[14:30] posNoWhite:[14:29] Found pattern:[14:29->14:31] +Completable: Cpattern Value[value]->variantPayload::Pair($0), tuple($1), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[value] +Path value +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + From f537d776b92717ada2612c4c375037a961e359f3 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 21:39:41 +0200 Subject: [PATCH 30/40] Select constructor tuple parameters in signature help Signed-off-by: Christoph Knittel --- analysis/src/signature_help.ml | 17 +++++++ .../src/SignatureHelpConstructorTuple.res | 9 ++++ .../SignatureHelpConstructorTuple.res.txt | 44 +++++++++++++++++++ 3 files changed, 70 insertions(+) create mode 100644 tests/analysis_tests/tests/src/SignatureHelpConstructorTuple.res create mode 100644 tests/analysis_tests/tests/src/expected/SignatureHelpConstructorTuple.res.txt diff --git a/analysis/src/signature_help.ml b/analysis/src/signature_help.ml index ce554524db7..09dd23b531f 100644 --- a/analysis/src/signature_help.ml +++ b/analysis/src/signature_help.ml @@ -633,8 +633,19 @@ let signature_help ~debug ~source ~kind_file ~pos |> String.concat ", ") ^ ")" in + let constructor_has_multiple_args = + match arg_parts with + | Some (`TupleArg (_ :: _ :: _)) -> true + | _ -> false + in let active_parameter = match cs with + | `ConstructorExpr (_, [{pexp_desc = Pexp_tuple tuple_items}]) + when constructor_has_multiple_args -> + constructor_arg_index + (List.map + (fun (item : Parsetree.expression) -> item.pexp_loc) + tuple_items) | `ConstructorExpr (_, items) when List.length items > 1 -> constructor_arg_index (List.map @@ -670,6 +681,12 @@ let signature_help ~debug ~source ~kind_file ~pos !field_index | _ -> -1) | `ConstructorExpr (_, [_]) -> 0 + | `ConstructorPat (_, [{ppat_desc = Ppat_tuple tuple_items}]) + when constructor_has_multiple_args -> + constructor_arg_index + (List.map + (fun (item : Parsetree.pattern) -> item.ppat_loc) + tuple_items) | `ConstructorPat (_, items) when List.length items > 1 -> constructor_arg_index (List.map diff --git a/tests/analysis_tests/tests/src/SignatureHelpConstructorTuple.res b/tests/analysis_tests/tests/src/SignatureHelpConstructorTuple.res new file mode 100644 index 00000000000..d0f8be98814 --- /dev/null +++ b/tests/analysis_tests/tests/src/SignatureHelpConstructorTuple.res @@ -0,0 +1,9 @@ +type t = Pair(int, string) + +let value = Pair((1, "test")) +// ^she + +let read = value => switch value { +| Pair((first, second)) => second +// ^she +} diff --git a/tests/analysis_tests/tests/src/expected/SignatureHelpConstructorTuple.res.txt b/tests/analysis_tests/tests/src/expected/SignatureHelpConstructorTuple.res.txt new file mode 100644 index 00000000000..cf1d5b53e06 --- /dev/null +++ b/tests/analysis_tests/tests/src/expected/SignatureHelpConstructorTuple.res.txt @@ -0,0 +1,44 @@ +Signature help src/SignatureHelpConstructorTuple.res 2:23 +{ + "activeParameter": 1, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 1, + "label": "Pair(int, string)", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 5, 8 ] + }, + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 10, 16 ] + } + ] + } + ] +} + +Signature help src/SignatureHelpConstructorTuple.res 6:15 +{ + "activeParameter": 1, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 1, + "label": "Pair(int, string)", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 5, 8 ] + }, + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 10, 16 ] + } + ] + } + ] +} + From 6ff0d42226e14942e27393f859d98e5aa6c9949d Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 21:46:20 +0200 Subject: [PATCH 31/40] Preserve constructor source arity in completion paths Signed-off-by: Christoph Knittel --- CHANGELOG.md | 1 + analysis/src/completion_expressions.ml | 22 ++- analysis/src/completion_front_end.ml | 3 +- analysis/src/completion_patterns.ml | 14 +- analysis/src/shared_types.ml | 6 +- analysis/src/type_utils.ml | 17 ++- .../tests/src/CompletionConstructorTuple.res | 14 +- .../CompletionConstructorTuple.res.txt | 131 ++++++++++++++++++ 8 files changed, 192 insertions(+), 16 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index c48630cc2ec..8e5188d1e86 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -38,6 +38,7 @@ - Fix the side-effect analysis treating bigint exponentiation and bounds-checked array and string reads as pure, which let dead-code elimination drop an unused one that throws: `let _ = 2n ** -1n` no longer raised. https://github.com/rescript-lang/rescript/pull/8617 - Preserve record field `@as` annotations when formatting object types containing spreads. https://github.com/rescript-lang/rescript/pull/8619 +- Fix record-field completion inside tuple arguments of constructors with multiple arguments, in expressions and patterns. https://github.com/rescript-lang/rescript/pull/8610 - Limit constructor signature help to the argument parentheses, excluding whitespace and comments between the constructor name and its arguments. https://github.com/rescript-lang/rescript/pull/8610 - Fix excessive parentheses and indentation in function assignments to refs, align record and array assignment formatting across refs and fields, and preserve function return-type parentheses and consistent JSX fragment layout in callbacks. https://github.com/rescript-lang/rescript/pull/8611 - Report an error instead of crashing when an integer in a variant constructor's `@as` annotation exceeds the compiler's integer range. https://github.com/rescript-lang/rescript/pull/8619 diff --git a/analysis/src/completion_expressions.ml b/analysis/src/completion_expressions.ml index 43f59884003..c5eb448ea7f 100644 --- a/analysis/src/completion_expressions.ml +++ b/analysis/src/completion_expressions.ml @@ -132,7 +132,11 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos ( "", [ Completable.NVariantPayload - {constructor_name = Utils.get_unqualified_name txt; item_num = 0}; + { + constructor_name = Utils.get_unqualified_name txt; + item_num = 0; + source_arity = 1; + }; ] @ expr_path ) | Pexp_construct ({txt}, {txt = args}) @@ -148,6 +152,7 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos { constructor_name = Utils.get_unqualified_name txt; item_num = List.length args; + source_arity = List.length args; }; ] @ expr_path ) @@ -157,7 +162,11 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos ~next_expr_path:(fun item_num -> [ Completable.NVariantPayload - {constructor_name = Utils.get_unqualified_name txt; item_num}; + { + constructor_name = Utils.get_unqualified_name txt; + item_num; + source_arity = List.length args; + }; ] @ expr_path) ~result_from_found_item_num:(fun item_num -> @@ -166,6 +175,7 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos { constructor_name = Utils.get_unqualified_name txt; item_num = item_num + 1; + source_arity = List.length args; }; ] @ expr_path) @@ -258,7 +268,7 @@ let pretty_print_fn_template_arg_name ?current_index ~env ~state ~full | _ -> default_var_name) let complete_constructor_payload ~pos_before_cursor - ~first_char_before_cursor_no_white ~item_num + ~first_char_before_cursor_no_white ~item_num ~source_arity (constructor_lid : Longident.t Location.loc) expr = match traverse_expr expr ~expr_path:[] ~pos:pos_before_cursor @@ -268,7 +278,11 @@ let complete_constructor_payload ~pos_before_cursor | Some (prefix, nested) -> let nested = Completable.NVariantPayload - {constructor_name = Longident.last constructor_lid.txt; item_num} + { + constructor_name = Longident.last constructor_lid.txt; + item_num; + source_arity; + } :: List.rev nested in let variant_ctx_path = diff --git a/analysis/src/completion_front_end.ml b/analysis/src/completion_front_end.ml index 992074d6e4b..4b2c037986f 100644 --- a/analysis/src/completion_front_end.ml +++ b/analysis/src/completion_front_end.ml @@ -502,6 +502,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file (NVariantPayload { item_num = index; + source_arity = List.length patterns; constructor_name = Utils.get_unqualified_name txt; } :: pattern_path) @@ -1305,7 +1306,7 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file match Completion_expressions.complete_constructor_payload ~pos_before_cursor ~first_char_before_cursor_no_white - ~item_num lid e + ~item_num ~source_arity:(List.length args) lid e with | Some result -> (* Check if anything else more important completes before setting this completion. *) diff --git a/analysis/src/completion_patterns.ml b/analysis/src/completion_patterns.ml index 99149a3b728..a080223193a 100644 --- a/analysis/src/completion_patterns.ml +++ b/analysis/src/completion_patterns.ml @@ -189,7 +189,11 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor ( "", [ Completable.NVariantPayload - {constructor_name = Utils.get_unqualified_name txt; item_num = 0}; + { + constructor_name = Utils.get_unqualified_name txt; + item_num = 0; + source_arity = 1; + }; ] @ pattern_path ) | Ppat_construct ({txt}, {txt = patterns}) @@ -205,6 +209,7 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor { constructor_name = Utils.get_unqualified_name txt; item_num = List.length patterns; + source_arity = List.length patterns; }; ] @ pattern_path ) @@ -215,7 +220,11 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor ~next_pattern_path:(fun item_num -> [ Completable.NVariantPayload - {constructor_name = Utils.get_unqualified_name txt; item_num}; + { + constructor_name = Utils.get_unqualified_name txt; + item_num; + source_arity = List.length patterns; + }; ] @ pattern_path) ~result_from_found_item_num:(fun item_num -> @@ -224,6 +233,7 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor { constructor_name = Utils.get_unqualified_name txt; item_num = item_num + 1; + source_arity = List.length patterns; }; ] @ pattern_path) diff --git a/analysis/src/shared_types.ml b/analysis/src/shared_types.ml index b2b9819d6e8..5c2e20e1333 100644 --- a/analysis/src/shared_types.ml +++ b/analysis/src/shared_types.ml @@ -605,7 +605,11 @@ module Completable = struct | NTupleItem of {item_num: int} | NFollowRecordField of {field_name: string} | NRecordBody of {seen_fields: string list} - | NVariantPayload of {constructor_name: string; item_num: int} + | NVariantPayload of { + constructor_name: string; + item_num: int; + source_arity: int; + } | NPolyvariantPayload of {constructor_name: string; item_num: int} | NArray diff --git a/analysis/src/type_utils.ml b/analysis/src/type_utils.ml index 0bc5488be53..5b6926d8867 100644 --- a/analysis/src/type_utils.ml +++ b/analysis/src/type_utils.ml @@ -603,10 +603,13 @@ let extract_type_from_resolved_type (typ : Type.t) ~env ~full ~state = (** The context we just came from as we resolve the nested structure. *) type ctx = Rfield of string (** A record field of name *) -let normalize_constructor_payload_path ~argument_count ~item_num ~nested = +(* Only a sole syntactic argument can be a tuple wrapping all constructor + arguments. A tuple within a multi-argument application is a real payload. *) +let normalize_constructor_payload_path ~argument_count ~source_arity ~item_num + ~nested = match nested with | Completable.NTupleItem {item_num = tuple_item_num} :: nested - when item_num = 0 && argument_count > 1 -> + when source_arity = 1 && item_num = 0 && argument_count > 1 -> (tuple_item_num, nested) | _ -> (item_num, nested) @@ -728,8 +731,8 @@ let rec resolve_nested ?type_arg_context ~env ~full ~state ~nested ?ctx |> extract_type ~env ~state ~package:full.package |> Utils.Option.flat_map (fun (t, type_arg_context) -> t |> resolve_nested ?type_arg_context ~env ~state ~full ~nested) - | NVariantPayload {constructor_name; item_num}, Tvariant {env; constructors} - -> ( + | ( NVariantPayload {constructor_name; item_num; source_arity}, + Tvariant {env; constructors} ) -> ( if Debug.verbose () then Printf.printf "[nested]--> trying to move into variant payload $%i of constructor \ @@ -745,7 +748,7 @@ let rec resolve_nested ?type_arg_context ~env ~full ~state ~nested ?ctx print_endline "[nested]--> found constructor (Args type)"; let item_num, nested = normalize_constructor_payload_path ~argument_count:(List.length args) - ~item_num ~nested + ~source_arity ~item_num ~nested in match List.nth_opt args item_num with | None -> @@ -915,7 +918,7 @@ let rec resolve_nested_pattern_path (typ : inner_type) ~env ~full ~state ~nested |> Utils.Option.flat_map (fun typ -> ExtractedType typ |> resolve_nested_pattern_path ~env ~state ~full ~nested)) - | ( NVariantPayload {constructor_name; item_num}, + | ( NVariantPayload {constructor_name; item_num; source_arity}, Tvariant {env; constructors} ) -> ( match constructors @@ -925,7 +928,7 @@ let rec resolve_nested_pattern_path (typ : inner_type) ~env ~full ~state ~nested | Some {args = Args args} -> ( let item_num, nested = normalize_constructor_payload_path - ~argument_count:(List.length args) ~item_num ~nested + ~argument_count:(List.length args) ~source_arity ~item_num ~nested in match List.nth_opt args item_num with | Some (typ, _) -> diff --git a/tests/analysis_tests/tests/src/CompletionConstructorTuple.res b/tests/analysis_tests/tests/src/CompletionConstructorTuple.res index b777f6ec07f..c28140d62ea 100644 --- a/tests/analysis_tests/tests/src/CompletionConstructorTuple.res +++ b/tests/analysis_tests/tests/src/CompletionConstructorTuple.res @@ -3,7 +3,7 @@ type payload = { enabled: bool, } -type t = Pair(int, payload) +type t = Pair(int, payload) | Nested((int, payload), string) let consume = (value: t) => ignore(value) @@ -14,3 +14,15 @@ let value = Pair(1, {name: "test", enabled: true}) // switch value { | Pair((_, {}))} // ^com + +// consume(Nested((1, {}), "")) +// ^com + +// switch value { | Nested((_, {}), _) => ()} +// ^com + +// consume(Nested(((1, {}), ""))) +// ^com + +// switch value { | Nested(((_, {}), _)) => ()} +// ^com diff --git a/tests/analysis_tests/tests/src/expected/CompletionConstructorTuple.res.txt b/tests/analysis_tests/tests/src/expected/CompletionConstructorTuple.res.txt index d839dfdfcef..503e4702f24 100644 --- a/tests/analysis_tests/tests/src/expected/CompletionConstructorTuple.res.txt +++ b/tests/analysis_tests/tests/src/expected/CompletionConstructorTuple.res.txt @@ -63,3 +63,134 @@ Path value } ] +Complete src/CompletionConstructorTuple.res 17:23 +posCursor:[17:23] posNoWhite:[17:22] Found expr:[17:3->17:31] +Pexp_apply ...[17:3->17:10] (...[17:11->17:30]) +Completable: Cexpression CArgument Value[consume]($0)->variantPayload::Nested($0), tuple($1), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath CArgument Value[consume]($0) +ContextPath Value[consume] +Path consume +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionConstructorTuple.res 20:32 +posCursor:[20:32] posNoWhite:[20:31] Found pattern:[20:20->20:38] +Ppat_construct Nested:[20:20->20:26] +posCursor:[20:32] posNoWhite:[20:31] Found pattern:[20:27->20:34] +posCursor:[20:32] posNoWhite:[20:31] Found pattern:[20:31->20:33] +Completable: Cpattern Value[value]->variantPayload::Nested($0), tuple($1), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[value] +Path value +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionConstructorTuple.res 23:24 +posCursor:[23:24] posNoWhite:[23:23] Found expr:[23:3->23:33] +Pexp_apply ...[23:3->23:10] (...[23:11->23:32]) +Completable: Cexpression CArgument Value[consume]($0)->variantPayload::Nested($0), tuple($0), tuple($1), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath CArgument Value[consume]($0) +ContextPath Value[consume] +Path consume +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionConstructorTuple.res 26:33 +posCursor:[26:33] posNoWhite:[26:32] Found pattern:[26:20->26:40] +Ppat_construct Nested:[26:20->26:26] +posCursor:[26:33] posNoWhite:[26:32] Found pattern:[26:27->26:39] +posCursor:[26:33] posNoWhite:[26:32] Found pattern:[26:28->26:35] +posCursor:[26:33] posNoWhite:[26:32] Found pattern:[26:32->26:34] +Completable: Cpattern Value[value]->variantPayload::Nested($0), tuple($0), tuple($1), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[value] +Path value +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + From 37dda636d91dd4cc7432e0a1ebef0bd94ce7af1f Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 21:47:10 +0200 Subject: [PATCH 32/40] Use shared argument traversal for constructor completion gaps Signed-off-by: Christoph Knittel --- analysis/src/completion_expressions.ml | 22 ---- analysis/src/completion_patterns.ml | 22 ---- .../tests/src/CompletionConstructorTuple.res | 28 +++++ .../CompletionConstructorTuple.res.txt | 109 ++++++++++++++++++ 4 files changed, 137 insertions(+), 44 deletions(-) diff --git a/analysis/src/completion_expressions.ml b/analysis/src/completion_expressions.ml index c5eb448ea7f..a47019b3bd0 100644 --- a/analysis/src/completion_expressions.ml +++ b/analysis/src/completion_expressions.ml @@ -5,11 +5,6 @@ let is_expr_hole exp = | Pexp_extension ({txt = "rescript.exprhole"}, _) -> true | _ -> false -let is_expr_tuple expr = - match expr.Parsetree.pexp_desc with - | Pexp_tuple _ -> true - | _ -> false - let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos ~first_char_before_cursor_no_white = let loc_has_cursor loc = loc |> Cursor_position.loc_has_cursor ~pos in @@ -139,23 +134,6 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos }; ] @ expr_path ) - | Pexp_construct ({txt}, {txt = args}) - when args <> [] - && pos >= ((Ext_list.last args).pexp_loc |> Loc.end_) - && first_char_before_cursor_no_white = Some ',' - && is_expr_tuple (Ext_list.last args) = false -> - (* Empty payload with trailing ',', like: Test(true, ) *) - Some - ( "", - [ - Completable.NVariantPayload - { - constructor_name = Utils.get_unqualified_name txt; - item_num = List.length args; - source_arity = List.length args; - }; - ] - @ expr_path ) | Pexp_construct ({txt}, {txt = args}) when loc_has_cursor exp.pexp_loc -> args |> traverse_expr_tuple_items ~first_char_before_cursor_no_white ~pos diff --git a/analysis/src/completion_patterns.ml b/analysis/src/completion_patterns.ml index a080223193a..880b08e53ea 100644 --- a/analysis/src/completion_patterns.ml +++ b/analysis/src/completion_patterns.ml @@ -5,11 +5,6 @@ let is_pattern_hole pat = | Ppat_extension ({txt = "rescript.patternhole"}, _) -> true | _ -> false -let is_pattern_tuple pat = - match pat.Parsetree.ppat_desc with - | Ppat_tuple _ -> true - | _ -> false - let rec traverse_tuple_items tuple_items ~next_pattern_path ~result_from_found_item_num ~loc_has_cursor ~first_char_before_cursor_no_white ~pos_before_cursor = @@ -196,23 +191,6 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor }; ] @ pattern_path ) - | Ppat_construct ({txt}, {txt = patterns}) - when patterns <> [] - && pos_before_cursor >= ((Ext_list.last patterns).ppat_loc |> Loc.end_) - && first_char_before_cursor_no_white = Some ',' - && is_pattern_tuple (Ext_list.last patterns) = false -> - (* Empty payload with trailing ',', like: Test(true, ) *) - Some - ( "", - [ - Completable.NVariantPayload - { - constructor_name = Utils.get_unqualified_name txt; - item_num = List.length patterns; - source_arity = List.length patterns; - }; - ] - @ pattern_path ) | Ppat_construct ({txt}, {txt = patterns}) when loc_has_cursor pat.ppat_loc -> patterns |> traverse_tuple_items ~loc_has_cursor ~first_char_before_cursor_no_white diff --git a/tests/analysis_tests/tests/src/CompletionConstructorTuple.res b/tests/analysis_tests/tests/src/CompletionConstructorTuple.res index c28140d62ea..e84982917da 100644 --- a/tests/analysis_tests/tests/src/CompletionConstructorTuple.res +++ b/tests/analysis_tests/tests/src/CompletionConstructorTuple.res @@ -26,3 +26,31 @@ let value = Pair(1, {name: "test", enabled: true}) // switch value { | Nested(((_, {}), _)) => ()} // ^com + +type gap = Gap(bool, bool, bool) | TupleGap((bool, bool), bool) +let consumeGap = (value: gap) => ignore(value) +let gap = Gap(true, false, true) + +// consumeGap(Gap(true, , false)) +// ^com + +// consumeGap(Gap(true, false, )) +// ^com + +// consumeGap(TupleGap((true, false), )) +// ^com + +// consumeGap(TupleGap((true, ), false)) +// ^com + +// switch gap { | Gap(true, , false) => ()} +// ^com + +// switch gap { | Gap(true, false, ) => ()} +// ^com + +// switch gap { | TupleGap((true, false), ) => ()} +// ^com + +// switch gap { | TupleGap((true, ), _) => ()} +// ^com diff --git a/tests/analysis_tests/tests/src/expected/CompletionConstructorTuple.res.txt b/tests/analysis_tests/tests/src/expected/CompletionConstructorTuple.res.txt index 503e4702f24..18d2d1870df 100644 --- a/tests/analysis_tests/tests/src/expected/CompletionConstructorTuple.res.txt +++ b/tests/analysis_tests/tests/src/expected/CompletionConstructorTuple.res.txt @@ -194,3 +194,112 @@ Path value } ] +Complete src/CompletionConstructorTuple.res 33:24 +posCursor:[33:24] posNoWhite:[33:22] Found expr:[33:3->33:33] +Pexp_apply ...[33:3->33:13] (...[33:14->33:32]) +Completable: Cexpression CArgument Value[consumeGap]($0)->variantPayload::Gap($1) +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath CArgument Value[consumeGap]($0) +ContextPath Value[consumeGap] +Path consumeGap +[ + { "detail": "bool", "kind": 4, "label": "true", "tags": [] }, + { "detail": "bool", "kind": 4, "label": "false", "tags": [] } +] + +Complete src/CompletionConstructorTuple.res 36:31 +posCursor:[36:31] posNoWhite:[36:29] Found expr:[36:3->36:33] +Pexp_apply ...[36:3->36:13] (...[36:14->36:32]) +Completable: Cexpression CArgument Value[consumeGap]($0)->variantPayload::Gap($2) +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath CArgument Value[consumeGap]($0) +ContextPath Value[consumeGap] +Path consumeGap +[ + { "detail": "bool", "kind": 4, "label": "true", "tags": [] }, + { "detail": "bool", "kind": 4, "label": "false", "tags": [] } +] + +Complete src/CompletionConstructorTuple.res 39:38 +posCursor:[39:38] posNoWhite:[39:36] Found expr:[39:3->39:40] +Pexp_apply ...[39:3->39:13] (...[39:14->39:39]) +Completable: Cexpression CArgument Value[consumeGap]($0)->variantPayload::TupleGap($1) +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath CArgument Value[consumeGap]($0) +ContextPath Value[consumeGap] +Path consumeGap +[ + { "detail": "bool", "kind": 4, "label": "true", "tags": [] }, + { "detail": "bool", "kind": 4, "label": "false", "tags": [] } +] + +Complete src/CompletionConstructorTuple.res 42:30 +posCursor:[42:30] posNoWhite:[42:28] Found expr:[42:3->42:40] +Pexp_apply ...[42:3->42:13] (...[42:14->42:39]) +Completable: Cexpression CArgument Value[consumeGap]($0)->variantPayload::TupleGap($0), tuple($1) +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath CArgument Value[consumeGap]($0) +ContextPath Value[consumeGap] +Path consumeGap +[ + { "detail": "bool", "kind": 4, "label": "true", "tags": [] }, + { "detail": "bool", "kind": 4, "label": "false", "tags": [] } +] + +Complete src/CompletionConstructorTuple.res 45:28 +posCursor:[45:28] posNoWhite:[45:26] Found pattern:[45:18->45:36] +Ppat_construct Gap:[45:18->45:21] +Completable: Cpattern Value[gap]->variantPayload::Gap($1) +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[gap] +Path gap +[ + { "detail": "bool", "kind": 4, "label": "true", "tags": [] }, + { "detail": "bool", "kind": 4, "label": "false", "tags": [] } +] + +Complete src/CompletionConstructorTuple.res 48:35 +posCursor:[48:35] posNoWhite:[48:33] Found pattern:[48:18->48:36] +Ppat_construct Gap:[48:18->48:21] +Completable: Cpattern Value[gap]->variantPayload::Gap($2) +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[gap] +Path gap +[ + { "detail": "bool", "kind": 4, "label": "true", "tags": [] }, + { "detail": "bool", "kind": 4, "label": "false", "tags": [] } +] + +Complete src/CompletionConstructorTuple.res 51:42 +posCursor:[51:42] posNoWhite:[51:40] Found pattern:[51:18->51:43] +Ppat_construct TupleGap:[51:18->51:26] +Completable: Cpattern Value[gap]->variantPayload::TupleGap($1) +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[gap] +Path gap +[ + { "detail": "bool", "kind": 4, "label": "true", "tags": [] }, + { "detail": "bool", "kind": 4, "label": "false", "tags": [] } +] + +Complete src/CompletionConstructorTuple.res 54:34 +posCursor:[54:34] posNoWhite:[54:32] Found pattern:[54:18->54:39] +Ppat_construct TupleGap:[54:18->54:26] +posCursor:[54:34] posNoWhite:[54:32] Found pattern:[54:27->54:35] +Completable: Cpattern Value[gap]->variantPayload::TupleGap($0), tuple($1) +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[gap] +Path gap +[ + { "detail": "bool", "kind": 4, "label": "true", "tags": [] }, + { "detail": "bool", "kind": 4, "label": "false", "tags": [] } +] + From 68d6884c39dc08c3fcca3893e42f49de630e8253 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Fri, 4 Sep 2026 21:48:09 +0200 Subject: [PATCH 33/40] Reuse resolved inline-record constructor fields in completion Signed-off-by: Christoph Knittel --- analysis/src/type_utils.ml | 14 ++--- .../tests/src/CompletionPattern.res | 9 +++ .../src/expected/CompletionPattern.res.txt | 55 +++++++++++++++++++ 3 files changed, 68 insertions(+), 10 deletions(-) diff --git a/analysis/src/type_utils.ml b/analysis/src/type_utils.ml index 5b6926d8867..9e0c2793e91 100644 --- a/analysis/src/type_utils.ml +++ b/analysis/src/type_utils.ml @@ -935,16 +935,10 @@ let rec resolve_nested_pattern_path (typ : inner_type) ~env ~full ~state ~nested TypeExpr typ |> resolve_nested_pattern_path ~env ~state ~full ~nested | None -> None) - | Some {args = InlineRecord _} -> ( - match - constructors - |> find_type_of_constructor_arg ~constructor_name - ~payload_num:item_num ~env - with - | Some typ -> - typ |> resolve_nested_pattern_path ~env ~state ~full ~nested - | None -> None) - | None -> None) + | Some {args = InlineRecord fields} when item_num = 0 -> + ExtractedType (TinlineRecord {env; fields}) + |> resolve_nested_pattern_path ~env ~state ~full ~nested + | Some {args = InlineRecord _} | None -> None) | ( NPolyvariantPayload {constructor_name; item_num}, Tpolyvariant {env; constructors} ) -> ( match diff --git a/tests/analysis_tests/tests/src/CompletionPattern.res b/tests/analysis_tests/tests/src/CompletionPattern.res index 5299aa887cd..c52747a422a 100644 --- a/tests/analysis_tests/tests/src/CompletionPattern.res +++ b/tests/analysis_tests/tests/src/CompletionPattern.res @@ -254,3 +254,12 @@ let callWithTwoParams = (fn: (firstParamVariant, secondParamVariant) => bool) => // must be completed; the first parameter's comma recovery must not shadow it. // callWithTwoParams((One(x), Blah(a, )) => true) // ^com + +type inlineRecord = Inline({enabled: bool, nested: nestedRecord}) +let inlineRecord = Inline({enabled: true, nested: {nested: false}}) + +// switch inlineRecord { | Inline({}) => ()} +// ^com + +// switch inlineRecord { | Inline({nested: {}}) => ()} +// ^com diff --git a/tests/analysis_tests/tests/src/expected/CompletionPattern.res.txt b/tests/analysis_tests/tests/src/expected/CompletionPattern.res.txt index 2dc4d2f8968..60be7aaf820 100644 --- a/tests/analysis_tests/tests/src/expected/CompletionPattern.res.txt +++ b/tests/analysis_tests/tests/src/expected/CompletionPattern.res.txt @@ -1173,3 +1173,58 @@ Path callWithTwoParams { "detail": "bool", "kind": 4, "label": "false", "tags": [] } ] +Complete src/CompletionPattern.res 260:35 +posCursor:[260:35] posNoWhite:[260:34] Found pattern:[260:27->260:37] +Ppat_construct Inline:[260:27->260:33] +posCursor:[260:35] posNoWhite:[260:34] Found pattern:[260:34->260:36] +Completable: Cpattern Value[inlineRecord]->variantPayload::Inline($0), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[inlineRecord] +Path inlineRecord +[ + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\n{enabled: bool, nested: nestedRecord}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + }, + { + "detail": "nestedRecord", + "documentation": { + "kind": "markdown", + "value": "```rescript\nnested: nestedRecord\n```\n\n```rescript\n{enabled: bool, nested: nestedRecord}\n```" + }, + "kind": 5, + "label": "nested", + "tags": [] + } +] + +Complete src/CompletionPattern.res 263:44 +posCursor:[263:44] posNoWhite:[263:43] Found pattern:[263:27->263:47] +Ppat_construct Inline:[263:27->263:33] +posCursor:[263:44] posNoWhite:[263:43] Found pattern:[263:34->263:46] +posCursor:[263:44] posNoWhite:[263:43] Found pattern:[263:43->263:45] +Completable: Cpattern Value[inlineRecord]->variantPayload::Inline($0), recordField(nested), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[inlineRecord] +Path inlineRecord +[ + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nnested: bool\n```\n\n```rescript\ntype nestedRecord = {nested: bool}\n```" + }, + "kind": 5, + "label": "nested", + "tags": [] + } +] + From 741133443354babafeaf1b5f3dc42a15e94948cb Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 5 Sep 2026 06:56:00 +0200 Subject: [PATCH 34/40] Preserve list constructor attributes on the AST0 wire Signed-off-by: Christoph Knittel --- compiler/ml/ast_mapper_from0.ml | 6 ++- compiler/ml/ast_mapper_to0.ml | 18 +++++--- tests/ounit_tests/ounit_ast_mapper0_tests.ml | 43 ++++++++++++++++++++ 3 files changed, 59 insertions(+), 8 deletions(-) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index a735def6cdf..c14b886385e 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -188,8 +188,10 @@ let remove_constructor_args_attr (attrs : Pt.attributes) = The current parsetree records source argument lists, not declaration arity. Frozen v0 has only an optional payload, so encoding multiple arguments packs them into a tuple and adds [_res.constructor_args] to the constructor. - A single tuple argument needs no marker. Polymorphic variant type payload - groups use the same encoding, with the marker on the tuple type itself. + A single tuple argument needs no marker. List cons nodes also need none: + their tuple payload always means head and tail, preserving the v0 wire shape. + Polymorphic variant type payload groups use the same encoding, with the + marker on the tuple type itself. Decoding consumes the internal marker and restores the source list. Ordinary constructors also accept PPX-produced [explicit_arity] and diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 9ccf5ca4ea0..03cb7e989a1 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -113,11 +113,13 @@ let add_constructor_args_attr attrs = (Location.mknoloc constructor_args_attr_name, Pt.PStr []) :: attrs (* See the constructor argument bridge contract at Ast_mapper_from0.decode_args. *) -let encode_args ~map ~tuple ~loc ~attrs args = +let encode_args ~map ~tuple ~loc ~attrs ~mark_args args = match List.map map args with | [] -> (None, attrs) | [arg] -> (Some arg, attrs) - | args -> (Some (tuple ~loc args), add_constructor_args_attr attrs) + | args -> + let attrs = if mark_args then add_constructor_args_attr attrs else attrs in + (Some (tuple ~loc args), attrs) let add_record_rest_attr ~rest attrs = (Location.mknoloc record_rest_attr_name, Pt.PPat (rest, None)) :: attrs @@ -583,7 +585,9 @@ module E = struct let arg, attrs = encode_args ~map:(sub.expr sub) ~tuple:(fun ~loc args -> Ast_helper0.Exp.tuple ~loc args) - ~loc:args_loc ~attrs args + ~loc:args_loc ~attrs + ~mark_args:(lid.txt <> Longident.Lident "::") + args in construct ~loc ~attrs lid arg | Pexp_variant (lab, {txt = args; loc = args_loc}) -> @@ -591,7 +595,7 @@ module E = struct let arg, attrs = encode_args ~map:(sub.expr sub) ~tuple:(fun ~loc args -> Ast_helper0.Exp.tuple ~loc args) - ~loc:args_loc ~attrs args + ~loc:args_loc ~attrs ~mark_args:true args in variant ~loc ~attrs lab arg | Pexp_record (l, eo) -> @@ -833,7 +837,9 @@ module P = struct let arg, attrs = encode_args ~map:(sub.pat sub) ~tuple:(fun ~loc args -> Ast_helper0.Pat.tuple ~loc args) - ~loc:args_loc ~attrs args + ~loc:args_loc ~attrs + ~mark_args:(l.txt <> Longident.Lident "::") + args in construct ~loc ~attrs l arg | Ppat_variant (l, {txt = args; loc = args_loc}) -> @@ -841,7 +847,7 @@ module P = struct let arg, attrs = encode_args ~map:(sub.pat sub) ~tuple:(fun ~loc args -> Ast_helper0.Pat.tuple ~loc args) - ~loc:args_loc ~attrs args + ~loc:args_loc ~attrs ~mark_args:true args in variant ~loc ~attrs l arg | Ppat_record (lpl, cf, rest) -> diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index 45d88f80c78..c8b3a115d28 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -297,6 +297,48 @@ let map_pat_to0 p = let attr_names attrs = List.map (fun ({Location.txt}, _) -> txt) attrs +let test_list_constructor_wire_shape _ = + let lid name = Location.mknoloc (Longident.Lident name) in + List.iter + (fun attrs -> + let expr0 = + List.fold_right + (fun value tail -> + Ast_helper0.Exp.construct ~loc ~attrs (lid "::") + (Some + (Ast_helper0.Exp.tuple ~loc + [ + Ast_helper0.Exp.constant ~loc + (Parsetree0.Pconst_integer (value, None)); + tail; + ]))) + ["1"; "2"] + (Ast_helper0.Exp.construct ~loc (lid "[]") None) + in + let pat0 = + List.fold_right + (fun name tail -> + Ast_helper0.Pat.construct ~loc ~attrs (lid "::") + (Some + (Ast_helper0.Pat.tuple ~loc + [Ast_helper0.Pat.var ~loc (Location.mknoloc name); tail]))) + ["head"; "next"] + (Ast_helper0.Pat.construct ~loc (lid "[]") None) + in + let expr = map_expr0 expr0 in + let pat = map_pat0 pat0 in + (match (expr.pexp_desc, pat.ppat_desc) with + | Pexp_construct (_, {txt = [_; _]}), Ppat_construct (_, {txt = [_; _]}) + -> + () + | _ -> + assert_failure "Unmarked cons payloads must decode to two arguments"); + OUnit.assert_equal ~msg:"list expression wire shape and attributes" expr0 + (map_expr_to0 expr); + OUnit.assert_equal ~msg:"list pattern wire shape and attributes" pat0 + (map_pat_to0 pat)) + [[]; [attr "public_attr" (Parsetree0.PStr [])]] + let test_constructor_args_roundtrip_through_ast0 _ = let int_expr value = Ast_helper.Exp.constant ~loc (Parsetree.Pconst_integer (value, None)) @@ -1203,6 +1245,7 @@ let suites = >:: test_record_rest_roundtrips_through_ast0; "constructor_args_roundtrip_through_ast0" >:: test_constructor_args_roundtrip_through_ast0; + "list_constructor_wire_shape" >:: test_list_constructor_wire_shape; "constructor_args_keep_parentheses_location_in_ast0" >:: test_constructor_args_keep_parentheses_location_in_ast0; "constructor_argument_locations_through_ast0" From 60adb6fad02365d0565548921e5a1eebbccb2794 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 5 Sep 2026 06:57:51 +0200 Subject: [PATCH 35/40] Simplify AST0 argument tuple callbacks Signed-off-by: Christoph Knittel --- compiler/ml/ast_mapper_to0.ml | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 03cb7e989a1..2ba915dd928 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -113,13 +113,13 @@ let add_constructor_args_attr attrs = (Location.mknoloc constructor_args_attr_name, Pt.PStr []) :: attrs (* See the constructor argument bridge contract at Ast_mapper_from0.decode_args. *) -let encode_args ~map ~tuple ~loc ~attrs ~mark_args args = +let encode_args ~map ~tuple ~attrs ~mark_args args = match List.map map args with | [] -> (None, attrs) | [arg] -> (Some arg, attrs) | args -> let attrs = if mark_args then add_constructor_args_attr attrs else attrs in - (Some (tuple ~loc args), attrs) + (Some (tuple args), attrs) let add_record_rest_attr ~rest attrs = (Location.mknoloc record_rest_attr_name, Pt.PPat (rest, None)) :: attrs @@ -584,8 +584,8 @@ module E = struct let args_loc = sub.location sub args_loc in let arg, attrs = encode_args ~map:(sub.expr sub) - ~tuple:(fun ~loc args -> Ast_helper0.Exp.tuple ~loc args) - ~loc:args_loc ~attrs + ~tuple:(fun args -> Ast_helper0.Exp.tuple ~loc:args_loc args) + ~attrs ~mark_args:(lid.txt <> Longident.Lident "::") args in @@ -594,8 +594,8 @@ module E = struct let args_loc = sub.location sub args_loc in let arg, attrs = encode_args ~map:(sub.expr sub) - ~tuple:(fun ~loc args -> Ast_helper0.Exp.tuple ~loc args) - ~loc:args_loc ~attrs ~mark_args:true args + ~tuple:(fun args -> Ast_helper0.Exp.tuple ~loc:args_loc args) + ~attrs ~mark_args:true args in variant ~loc ~attrs lab arg | Pexp_record (l, eo) -> @@ -836,8 +836,8 @@ module P = struct let args_loc = sub.location sub args_loc in let arg, attrs = encode_args ~map:(sub.pat sub) - ~tuple:(fun ~loc args -> Ast_helper0.Pat.tuple ~loc args) - ~loc:args_loc ~attrs + ~tuple:(fun args -> Ast_helper0.Pat.tuple ~loc:args_loc args) + ~attrs ~mark_args:(l.txt <> Longident.Lident "::") args in @@ -846,8 +846,8 @@ module P = struct let args_loc = sub.location sub args_loc in let arg, attrs = encode_args ~map:(sub.pat sub) - ~tuple:(fun ~loc args -> Ast_helper0.Pat.tuple ~loc args) - ~loc:args_loc ~attrs ~mark_args:true args + ~tuple:(fun args -> Ast_helper0.Pat.tuple ~loc:args_loc args) + ~attrs ~mark_args:true args in variant ~loc ~attrs l arg | Ppat_record (lpl, cf, rest) -> From cdb15da67890b438b19dbe90097a49d926a1e810 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 5 Sep 2026 08:14:05 +0200 Subject: [PATCH 36/40] Preserve attributed list payload tuples across AST0 conversions Signed-off-by: Christoph Knittel --- compiler/ml/ast_mapper_from0.ml | 15 ++++++-- compiler/ml/pprintast.ml | 6 +-- compiler/syntax/src/res_comments_table.ml | 10 ++++- compiler/syntax/src/res_parsetree_viewer.ml | 10 ++++- tests/ounit_tests/ounit_ast_mapper0_tests.ml | 40 +++++++++++++++----- 5 files changed, 61 insertions(+), 20 deletions(-) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index c14b886385e..9ccf39ff02f 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -195,9 +195,11 @@ let remove_constructor_args_attr (attrs : Pt.attributes) = Decoding consumes the internal marker and restores the source list. Ordinary constructors also accept PPX-produced [explicit_arity] and - [ocaml.explicit_arity] attributes, and always split the list constructor - [::]. Other unmarked v0 tuples remain a single syntactic payload; Typecore - resolves semantic grouping once it knows the constructor declaration. + [ocaml.explicit_arity] attributes, and split the list constructor [::] when + its tuple has no attributes. Attributed cons tuples remain one payload so + their attributes survive another v0 conversion. Other unmarked v0 tuples + also remain a single syntactic payload; Typecore resolves semantic grouping + once it knows the constructor declaration. The tuple used to encode multiple arguments carries the argument-list location, preserving its parentheses span. For a single argument, v0 @@ -905,6 +907,10 @@ module E = struct decode_args ~map:(sub.expr sub) ~tuple_args:(fun arg -> match arg.pexp_desc with + | Pexp_tuple _ + when lid.txt = Longident.Lident "::" && arg.pexp_attributes <> [] + -> + None | Pexp_tuple args -> Some args | _ -> None) ~split_tuple: @@ -1163,6 +1169,9 @@ module P = struct decode_args ~map:(sub.pat sub) ~tuple_args:(fun arg -> match arg.ppat_desc with + | Ppat_tuple _ + when l.txt = Longident.Lident "::" && arg.ppat_attributes <> [] -> + None | Ppat_tuple args -> Some args | _ -> None) ~split_tuple: diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml index f04075a07a3..201d62ffee6 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -465,10 +465,8 @@ and pattern1 ctxt (f : Format.formatter) (x : pattern) : unit = | Ppat_construct ({txt = Lident ("()" | "[]"); _}, _) -> simple_pattern ctxt f x | Ppat_construct (({txt; _} as li), {txt = po}) -> ( - if - (* FIXME The third field always false *) - txt = Lident "::" - then pp f "%a" pattern_list_helper x + if txt = Lident "::" && List.length po = 2 then + pp f "%a" pattern_list_helper x else match po with | [] -> pp f "%a" longident_loc li diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index 5c1b7d69c3a..bb2afa3a94c 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -296,7 +296,10 @@ let partition_between_lines start_line end_line comments = let rec collect_list_patterns acc pattern = let open Parsetree in match pattern.ppat_desc with - | Ppat_construct ({txt = Longident.Lident "::"}, {txt = [pat; rest]}) -> + | Ppat_construct ({txt = Longident.Lident "::"}, {txt = [pat; rest]}) + | Ppat_construct + ( {txt = Longident.Lident "::"}, + {txt = [{ppat_desc = Ppat_tuple [pat; rest]}]} ) -> collect_list_patterns (pat :: acc) rest | Ppat_construct ({txt = Longident.Lident "[]"}, {txt = []}) -> List.rev acc | _ -> List.rev (pattern :: acc) @@ -304,7 +307,10 @@ let rec collect_list_patterns acc pattern = let rec collect_list_exprs acc expr = let open Parsetree in match expr.pexp_desc with - | Pexp_construct ({txt = Longident.Lident "::"}, {txt = [expr; rest]}) -> + | Pexp_construct ({txt = Longident.Lident "::"}, {txt = [expr; rest]}) + | Pexp_construct + ( {txt = Longident.Lident "::"}, + {txt = [{pexp_desc = Pexp_tuple [expr; rest]}]} ) -> collect_list_exprs (expr :: acc) rest | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> List.rev acc | _ -> List.rev (expr :: acc) diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index 3d753f0f66e..3d462f2517b 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -70,7 +70,10 @@ let collect_list_expressions expr = let rec collect acc expr = match expr.pexp_desc with | Pexp_construct ({txt = Longident.Lident "[]"}, _) -> (List.rev acc, None) - | Pexp_construct ({txt = Longident.Lident "::"}, {txt = hd :: [tail]}) -> + | Pexp_construct ({txt = Longident.Lident "::"}, {txt = hd :: [tail]}) + | Pexp_construct + ( {txt = Longident.Lident "::"}, + {txt = [{pexp_desc = Pexp_tuple [hd; tail]}]} ) -> collect (hd :: acc) tail | _ -> (List.rev acc, Some expr) in @@ -642,7 +645,10 @@ let mod_expr_functor mod_expr = let rec collect_patterns_from_list_construct acc pattern = let open Parsetree in match pattern.ppat_desc with - | Ppat_construct ({txt = Longident.Lident "::"}, {txt = [pat; rest]}) -> + | Ppat_construct ({txt = Longident.Lident "::"}, {txt = [pat; rest]}) + | Ppat_construct + ( {txt = Longident.Lident "::"}, + {txt = [{ppat_desc = Ppat_tuple [pat; rest]}]} ) -> collect_patterns_from_list_construct (pat :: acc) rest | _ -> (List.rev acc, pattern) diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index c8b3a115d28..1762f766b2d 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -300,13 +300,13 @@ let attr_names attrs = List.map (fun ({Location.txt}, _) -> txt) attrs let test_list_constructor_wire_shape _ = let lid name = Location.mknoloc (Longident.Lident name) in List.iter - (fun attrs -> + (fun (attrs, payload_attrs) -> let expr0 = List.fold_right (fun value tail -> Ast_helper0.Exp.construct ~loc ~attrs (lid "::") (Some - (Ast_helper0.Exp.tuple ~loc + (Ast_helper0.Exp.tuple ~loc ~attrs:payload_attrs [ Ast_helper0.Exp.constant ~loc (Parsetree0.Pconst_integer (value, None)); @@ -320,24 +320,46 @@ let test_list_constructor_wire_shape _ = (fun name tail -> Ast_helper0.Pat.construct ~loc ~attrs (lid "::") (Some - (Ast_helper0.Pat.tuple ~loc + (Ast_helper0.Pat.tuple ~loc ~attrs:payload_attrs [Ast_helper0.Pat.var ~loc (Location.mknoloc name); tail]))) ["head"; "next"] (Ast_helper0.Pat.construct ~loc (lid "[]") None) in let expr = map_expr0 expr0 in let pat = map_pat0 pat0 in - (match (expr.pexp_desc, pat.ppat_desc) with - | Pexp_construct (_, {txt = [_; _]}), Ppat_construct (_, {txt = [_; _]}) - -> + (match (payload_attrs, expr.pexp_desc, pat.ppat_desc) with + | ( [], + Pexp_construct (_, {txt = [_; _]}), + Ppat_construct (_, {txt = [_; _]}) ) -> + () + | ( _ :: _, + Pexp_construct (_, {txt = [{pexp_desc = Pexp_tuple [_; _]}]}), + Ppat_construct (_, {txt = [{ppat_desc = Ppat_tuple [_; _]}]}) ) -> () | _ -> - assert_failure "Unmarked cons payloads must decode to two arguments"); + assert_failure "Attributed cons payloads must retain their tuple node"); OUnit.assert_equal ~msg:"list expression wire shape and attributes" expr0 (map_expr_to0 expr); OUnit.assert_equal ~msg:"list pattern wire shape and attributes" pat0 - (map_pat_to0 pat)) - [[]; [attr "public_attr" (Parsetree0.PStr [])]] + (map_pat_to0 pat); + let structure = + [ + Ast_helper.Str.value ~loc Nonrecursive [Ast_helper.Vb.mk ~loc pat expr]; + ] + in + ignore (Typemod.type_structure Env.initial_safe_string structure loc); + let printed = + Res_printer.print_implementation structure ~comments:[] ~width:80 + in + let parsed = + Res_driver.parse_implementation_from_source + ~display_filename:"ListPayloadAttributes.res" ~source:printed + in + OUnit.assert_bool "attributed list payloads remain printable" + (not parsed.invalid); + ignore (Format.asprintf "%a" Pprintast.structure structure)) + (let attrs = [attr "public_attr" (Parsetree0.PStr [])] in + [([], []); (attrs, []); ([], attrs); (attrs, attrs)]) let test_constructor_args_roundtrip_through_ast0 _ = let int_expr value = From 045c62d6f452fbd50a5555a8aa980d4c78df946d Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 5 Sep 2026 18:58:55 +0200 Subject: [PATCH 37/40] Adapt constructor tag helper to argument lists Signed-off-by: Christoph Knittel --- compiler/ml/ast_helper.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index b4bc9d37dd2..7dbc41bb1ae 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -443,7 +443,7 @@ module Type = struct (Location.mkloc (Longident.Lident (if b then "true" else "false")) loc) - None + (Location.mkloc [] loc) | Pct_null -> Exp.ident ~loc (Location.mkloc (Longident.Lident "null") loc) | Pct_undefined -> From 87349f5878754e4fbd381b23bd6560868bb289e0 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 5 Sep 2026 19:19:06 +0200 Subject: [PATCH 38/40] Normalize constructor payload grouping in completion paths Signed-off-by: Christoph Knittel --- analysis/src/completion_expressions.ml | 20 +- analysis/src/completion_front_end.ml | 7 +- analysis/src/completion_patterns.ml | 20 +- analysis/src/shared_types.ml | 6 +- analysis/src/type_utils.ml | 168 ++-- .../tests/src/CompletionPayloadGrouping.res | 81 ++ .../CompletionPayloadGrouping.res.txt | 831 ++++++++++++++++++ 7 files changed, 1031 insertions(+), 102 deletions(-) create mode 100644 tests/analysis_tests/tests/src/CompletionPayloadGrouping.res create mode 100644 tests/analysis_tests/tests/src/expected/CompletionPayloadGrouping.res.txt diff --git a/analysis/src/completion_expressions.ml b/analysis/src/completion_expressions.ml index a47019b3bd0..8e6f01a34d4 100644 --- a/analysis/src/completion_expressions.ml +++ b/analysis/src/completion_expressions.ml @@ -166,18 +166,32 @@ let rec traverse_expr (exp : Parsetree.expression) ~expr_path ~pos (* Empty payload with cursor, like: #test() *) Some ( "", - [Completable.NPolyvariantPayload {constructor_name = txt; item_num = 0}] + [ + Completable.NPolyvariantPayload + {constructor_name = txt; item_num = 0; source_arity = 1}; + ] @ expr_path ) | Pexp_variant (txt, {txt = args}) when loc_has_cursor exp.pexp_loc -> args |> traverse_expr_tuple_items ~first_char_before_cursor_no_white ~pos ~next_expr_path:(fun item_num -> - [Completable.NPolyvariantPayload {constructor_name = txt; item_num}] + [ + Completable.NPolyvariantPayload + { + constructor_name = txt; + item_num; + source_arity = List.length args; + }; + ] @ expr_path) ~result_from_found_item_num:(fun item_num -> [ Completable.NPolyvariantPayload - {constructor_name = txt; item_num = item_num + 1}; + { + constructor_name = txt; + item_num = item_num + 1; + source_arity = List.length args; + }; ] @ expr_path) | _ -> None diff --git a/analysis/src/completion_front_end.ml b/analysis/src/completion_front_end.ml index 4b2c037986f..bdf4ffedcec 100644 --- a/analysis/src/completion_front_end.ml +++ b/analysis/src/completion_front_end.ml @@ -513,7 +513,12 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file |> List.iteri (fun index p -> scope_pattern p ~pattern_path: - (NPolyvariantPayload {item_num = index; constructor_name = txt} + (NPolyvariantPayload + { + item_num = index; + constructor_name = txt; + source_arity = List.length patterns; + } :: pattern_path) ?context_path) | Ppat_record (fields, _, rest) -> ( diff --git a/analysis/src/completion_patterns.ml b/analysis/src/completion_patterns.ml index 880b08e53ea..caf4b980ff0 100644 --- a/analysis/src/completion_patterns.ml +++ b/analysis/src/completion_patterns.ml @@ -224,19 +224,33 @@ and traverse_pattern (pat : Parsetree.pattern) ~pattern_path ~loc_has_cursor (* Empty payload with cursor, like: #test() *) Some ( "", - [Completable.NPolyvariantPayload {constructor_name = txt; item_num = 0}] + [ + Completable.NPolyvariantPayload + {constructor_name = txt; item_num = 0; source_arity = 1}; + ] @ pattern_path ) | Ppat_variant (txt, {txt = patterns}) when loc_has_cursor pat.ppat_loc -> patterns |> traverse_tuple_items ~loc_has_cursor ~first_char_before_cursor_no_white ~pos_before_cursor ~next_pattern_path:(fun item_num -> - [Completable.NPolyvariantPayload {constructor_name = txt; item_num}] + [ + Completable.NPolyvariantPayload + { + constructor_name = txt; + item_num; + source_arity = List.length patterns; + }; + ] @ pattern_path) ~result_from_found_item_num:(fun item_num -> [ Completable.NPolyvariantPayload - {constructor_name = txt; item_num = item_num + 1}; + { + constructor_name = txt; + item_num = item_num + 1; + source_arity = List.length patterns; + }; ] @ pattern_path) | _ -> None diff --git a/analysis/src/shared_types.ml b/analysis/src/shared_types.ml index 5c2e20e1333..0ac54f36620 100644 --- a/analysis/src/shared_types.ml +++ b/analysis/src/shared_types.ml @@ -610,7 +610,11 @@ module Completable = struct item_num: int; source_arity: int; } - | NPolyvariantPayload of {constructor_name: string; item_num: int} + | NPolyvariantPayload of { + constructor_name: string; + item_num: int; + source_arity: int; + } | NArray let nested_path_to_string p = diff --git a/analysis/src/type_utils.ml b/analysis/src/type_utils.ml index 9e0c2793e91..d0a703b2e87 100644 --- a/analysis/src/type_utils.ml +++ b/analysis/src/type_utils.ml @@ -603,11 +603,13 @@ let extract_type_from_resolved_type (typ : Type.t) ~env ~full ~state = (** The context we just came from as we resolve the nested structure. *) type ctx = Rfield of string (** A record field of name *) -(* Only a sole syntactic argument can be a tuple wrapping all constructor - arguments. A tuple within a multi-argument application is a real payload. *) +(* Translate source grouping to the resolved payload grouping in either + direction. Tuples within a multi-argument application remain real payloads. *) let normalize_constructor_payload_path ~argument_count ~source_arity ~item_num ~nested = match nested with + | _ when source_arity > 1 && argument_count = 1 -> + (0, Completable.NTupleItem {item_num} :: nested) | Completable.NTupleItem {item_num = tuple_item_num} :: nested when source_arity = 1 && item_num = 0 && argument_count > 1 -> (tuple_item_num, nested) @@ -703,28 +705,48 @@ let rec resolve_nested ?type_arg_context ~env ~full ~state ~nested ?ctx env, Some (Completable.RecordField {seen_fields}), type_arg_context ) - | ( NVariantPayload {constructor_name = "Some"; item_num = 0}, - Toption (env, ExtractedType typ) ) -> + | ( NVariantPayload {constructor_name = "Some"; item_num; source_arity}, + Toption (env, ExtractedType typ) ) + when item_num = 0 || source_arity > 1 -> + let _, nested = + normalize_constructor_payload_path ~argument_count:1 ~source_arity + ~item_num ~nested + in if Debug.verbose () then print_endline "[nested]--> moving into option Some"; typ |> resolve_nested ?type_arg_context ~env ~full ~state ~nested - | ( NVariantPayload {constructor_name = "Some"; item_num = 0}, - Toption (env, TypeExpr typ) ) -> + | ( NVariantPayload {constructor_name = "Some"; item_num; source_arity}, + Toption (env, TypeExpr typ) ) + when item_num = 0 || source_arity > 1 -> + let _, nested = + normalize_constructor_payload_path ~argument_count:1 ~source_arity + ~item_num ~nested + in if Debug.verbose () then print_endline "[nested]--> moving into option Some"; typ |> extract_type ~env ~state ~package:full.package |> Utils.Option.flat_map (fun (t, type_arg_context) -> t |> resolve_nested ?type_arg_context ~env ~state ~full ~nested) - | NVariantPayload {constructor_name = "Ok"; item_num = 0}, Tresult {ok_type} - -> + | ( NVariantPayload {constructor_name = "Ok"; item_num; source_arity}, + Tresult {ok_type} ) + when item_num = 0 || source_arity > 1 -> + let _, nested = + normalize_constructor_payload_path ~argument_count:1 ~source_arity + ~item_num ~nested + in if Debug.verbose () then print_endline "[nested]--> moving into result Ok"; ok_type |> extract_type ~env ~state ~package:full.package |> Utils.Option.flat_map (fun (t, type_arg_context) -> t |> resolve_nested ?type_arg_context ~env ~state ~full ~nested) - | ( NVariantPayload {constructor_name = "Error"; item_num = 0}, - Tresult {error_type} ) -> + | ( NVariantPayload {constructor_name = "Error"; item_num; source_arity}, + Tresult {error_type} ) + when item_num = 0 || source_arity > 1 -> + let _, nested = + normalize_constructor_payload_path ~argument_count:1 ~source_arity + ~item_num ~nested + in if Debug.verbose () then print_endline "[nested]--> moving into result Error"; error_type @@ -776,7 +798,7 @@ let rec resolve_nested ?type_arg_context ~env ~full ~state ~nested ?ctx TinlineRecord {env; fields} |> resolve_nested ?type_arg_context ~env ~state ~full ~nested | _ -> None) - | ( NPolyvariantPayload {constructor_name; item_num}, + | ( NPolyvariantPayload {constructor_name; item_num; source_arity}, Tpolyvariant {env; constructors} ) -> ( match constructors @@ -785,6 +807,11 @@ let rec resolve_nested ?type_arg_context ~env ~full ~state ~nested ?ctx with | None -> None | Some constructor -> ( + let item_num, nested = + normalize_constructor_payload_path + ~argument_count:(List.length constructor.args) + ~source_arity ~item_num ~nested + in match List.nth_opt constructor.args item_num with | None -> None | Some typ -> @@ -812,30 +839,21 @@ let find_type_of_record_field fields ~field_name = let typ = if optional then Utils.unwrap_if_option typ else typ in Some typ -let find_type_of_constructor_arg constructors ~constructor_name ~payload_num - ~env = - match - constructors - |> List.find_opt (fun (c : Constructor.t) -> c.cname.txt = constructor_name) - with - | Some {args = Args args} -> ( - match List.nth_opt args payload_num with - | None -> None - | Some (typ, _) -> Some (TypeExpr typ)) - | Some {args = InlineRecord fields} when payload_num = 0 -> - Some (ExtractedType (TinlineRecord {env; fields})) - | _ -> None - -let find_type_of_polyvariant_arg constructors ~constructor_name ~payload_num = +let find_type_of_polyvariant_arg constructors ~constructor_name ~item_num + ~source_arity ~nested = match constructors |> List.find_opt (fun (c : poly_variant_constructor) -> c.name = constructor_name) with | Some {args} -> ( - match List.nth_opt args payload_num with + let item_num, nested = + normalize_constructor_payload_path ~argument_count:(List.length args) + ~source_arity ~item_num ~nested + in + match List.nth_opt args item_num with | None -> None - | Some typ -> Some typ) + | Some typ -> Some (typ, nested)) | None -> None let rec resolve_nested_pattern_path (typ : inner_type) ~env ~full ~state ~nested @@ -848,50 +866,7 @@ let rec resolve_nested_pattern_path (typ : inner_type) ~env ~full ~state ~nested | ExtractedType t -> Some t in match nested with - | [] -> None - | [final_pattern_path] -> ( - match t with - | None -> None - | Some completion_type -> ( - match (final_pattern_path, completion_type) with - | ( Completable.NFollowRecordField {field_name}, - (TinlineRecord {fields} | Trecord {fields}) ) -> ( - match fields |> find_type_of_record_field ~field_name with - | None -> None - | Some typ -> Some (TypeExpr typ, env)) - | NTupleItem {item_num}, Tuple (env, tuple_items, _) -> ( - match List.nth_opt tuple_items item_num with - | None -> None - | Some typ -> Some (TypeExpr typ, env)) - | ( NVariantPayload {constructor_name; item_num}, - Tvariant {env; constructors} ) -> ( - match - constructors - |> find_type_of_constructor_arg ~constructor_name - ~payload_num:item_num ~env - with - | Some typ -> Some (typ, env) - | None -> None) - | ( NPolyvariantPayload {constructor_name; item_num}, - Tpolyvariant {env; constructors} ) -> ( - match - constructors - |> find_type_of_polyvariant_arg ~constructor_name - ~payload_num:item_num - with - | Some typ -> Some (TypeExpr typ, env) - | None -> None) - | ( NVariantPayload {constructor_name = "Some"; item_num = 0}, - Toption (env, typ) ) -> - Some (typ, env) - | ( NVariantPayload {constructor_name = "Ok"; item_num = 0}, - Tresult {env; ok_type} ) -> - Some (TypeExpr ok_type, env) - | ( NVariantPayload {constructor_name = "Error"; item_num = 0}, - Tresult {env; error_type} ) -> - Some (TypeExpr error_type, env) - | NArray, Tarray (env, typ) -> Some (typ, env) - | _ -> None)) + | [] -> Some (typ, env) | pattern_path :: nested -> ( match t with | None -> None @@ -902,22 +877,12 @@ let rec resolve_nested_pattern_path (typ : inner_type) ~env ~full ~state ~nested match fields |> find_type_of_record_field ~field_name with | None -> None | Some typ -> - typ - |> extract_type ~env ~state ~package:full.package - |> get_extracted_type - |> Utils.Option.flat_map (fun typ -> - ExtractedType typ - |> resolve_nested_pattern_path ~env ~state ~full ~nested)) + TypeExpr typ |> resolve_nested_pattern_path ~env ~state ~full ~nested) | NTupleItem {item_num}, Tuple (env, tuple_items, _) -> ( match List.nth_opt tuple_items item_num with | None -> None | Some typ -> - typ - |> extract_type ~env ~state ~package:full.package - |> get_extracted_type - |> Utils.Option.flat_map (fun typ -> - ExtractedType typ - |> resolve_nested_pattern_path ~env ~state ~full ~nested)) + TypeExpr typ |> resolve_nested_pattern_path ~env ~state ~full ~nested) | ( NVariantPayload {constructor_name; item_num; source_arity}, Tvariant {env; constructors} ) -> ( match @@ -939,25 +904,40 @@ let rec resolve_nested_pattern_path (typ : inner_type) ~env ~full ~state ~nested ExtractedType (TinlineRecord {env; fields}) |> resolve_nested_pattern_path ~env ~state ~full ~nested | Some {args = InlineRecord _} | None -> None) - | ( NPolyvariantPayload {constructor_name; item_num}, + | ( NPolyvariantPayload {constructor_name; item_num; source_arity}, Tpolyvariant {env; constructors} ) -> ( match constructors - |> find_type_of_polyvariant_arg ~constructor_name - ~payload_num:item_num + |> find_type_of_polyvariant_arg ~constructor_name ~item_num + ~source_arity ~nested with - | Some typ -> + | Some (typ, nested) -> TypeExpr typ |> resolve_nested_pattern_path ~env ~state ~full ~nested | None -> None) - | ( NVariantPayload {constructor_name = "Some"; item_num = 0}, - Toption (env, typ) ) -> + | ( NVariantPayload {constructor_name = "Some"; item_num; source_arity}, + Toption (env, typ) ) + when item_num = 0 || source_arity > 1 -> + let _, nested = + normalize_constructor_payload_path ~argument_count:1 ~source_arity + ~item_num ~nested + in typ |> resolve_nested_pattern_path ~env ~state ~full ~nested - | ( NVariantPayload {constructor_name = "Ok"; item_num = 0}, - Tresult {env; ok_type} ) -> + | ( NVariantPayload {constructor_name = "Ok"; item_num; source_arity}, + Tresult {env; ok_type} ) + when item_num = 0 || source_arity > 1 -> + let _, nested = + normalize_constructor_payload_path ~argument_count:1 ~source_arity + ~item_num ~nested + in TypeExpr ok_type |> resolve_nested_pattern_path ~env ~state ~full ~nested - | ( NVariantPayload {constructor_name = "Error"; item_num = 0}, - Tresult {env; error_type} ) -> + | ( NVariantPayload {constructor_name = "Error"; item_num; source_arity}, + Tresult {env; error_type} ) + when item_num = 0 || source_arity > 1 -> + let _, nested = + normalize_constructor_payload_path ~argument_count:1 ~source_arity + ~item_num ~nested + in TypeExpr error_type |> resolve_nested_pattern_path ~env ~state ~full ~nested | NArray, Tarray (env, typ) -> diff --git a/tests/analysis_tests/tests/src/CompletionPayloadGrouping.res b/tests/analysis_tests/tests/src/CompletionPayloadGrouping.res new file mode 100644 index 00000000000..9759b2c3ab6 --- /dev/null +++ b/tests/analysis_tests/tests/src/CompletionPayloadGrouping.res @@ -0,0 +1,81 @@ +type payload = {name: string, enabled: bool} +type t = Unary((payload, payload)) | Pair(payload, payload) +let consume = (value: t) => ignore(value) +let value = Pair({name: "", enabled: true}, {name: "", enabled: false}) +let consumeOption = (value: option<(payload, payload)>) => ignore(value) +let optionValue = Some(({name: "", enabled: true}, {name: "", enabled: false})) +type poly = [#Poly((int, payload))] +let consumePoly = (value: poly) => ignore(value) +let polyValue: poly = #Poly((1, {name: "", enabled: true})) + +// consume(Unary({}, {})) +// ^com + +// consume(Unary({}, {})) +// ^com + +// switch value { | Unary({}, _) => () } +// ^com + +// switch value { | Unary(_, {}) => () } +// ^com + +// consumeOption(Some({}, {})) +// ^com + +// consumeOption(Some({}, {})) +// ^com + +// switch optionValue { | Some(_, {}) => () | None => () } +// ^com + +// consumePoly(#Poly((1, {}))) +// ^com + +// switch polyValue { | #Poly((_, {})) => () } +// ^com + +// consumePoly(#Poly(1, {})) +// ^com + +// switch polyValue { | #Poly(_, {}) => () } +// ^com + +// switch value { | Pair((first, second)) => first. } +// ^com + +// switch value { | Pair((first, second)) => second. } +// ^com + +// switch value { | Unary(first, second) => first. } +// ^com + +// switch value { | Unary(first, second) => second. } +// ^com + +// switch polyValue { | #Poly((_, record)) => record. } +// ^com + +// switch polyValue { | #Poly(_, record) => record. } +// ^com + +let consumeResult = (value: result<(payload, payload), (payload, payload)>) => ignore(value) +let resultValue: result<(payload, payload), (payload, payload)> = Ok(({name: "", enabled: true}, {name: "", enabled: false})) + +// consumeResult(Ok({}, {})) +// ^com + +// switch resultValue { | Ok(_, {}) => () | _ => () } +// ^com + +// switch resultValue { | Ok(first, second) => second. | _ => () } +// ^com + +// consumeResult(Error({}, {})) +// ^com + +// switch resultValue { | Error(_, {}) => () | _ => () } +// ^com + +// switch resultValue { | Error(first, second) => second. | _ => () } +// ^com diff --git a/tests/analysis_tests/tests/src/expected/CompletionPayloadGrouping.res.txt b/tests/analysis_tests/tests/src/expected/CompletionPayloadGrouping.res.txt new file mode 100644 index 00000000000..239242c1c44 --- /dev/null +++ b/tests/analysis_tests/tests/src/expected/CompletionPayloadGrouping.res.txt @@ -0,0 +1,831 @@ +Complete src/CompletionPayloadGrouping.res 10:18 +posCursor:[10:18] posNoWhite:[10:17] Found expr:[10:3->10:25] +Pexp_apply ...[10:3->10:10] (...[10:11->10:24]) +Completable: Cexpression CArgument Value[consume]($0)->variantPayload::Unary($0), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath CArgument Value[consume]($0) +ContextPath Value[consume] +Path consume +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 13:22 +posCursor:[13:22] posNoWhite:[13:21] Found expr:[13:3->13:25] +Pexp_apply ...[13:3->13:10] (...[13:11->13:24]) +Completable: Cexpression CArgument Value[consume]($0)->variantPayload::Unary($1), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath CArgument Value[consume]($0) +ContextPath Value[consume] +Path consume +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 16:27 +posCursor:[16:27] posNoWhite:[16:26] Found pattern:[16:20->16:32] +Ppat_construct Unary:[16:20->16:25] +posCursor:[16:27] posNoWhite:[16:26] Found pattern:[16:26->16:28] +Completable: Cpattern Value[value]->variantPayload::Unary($0), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[value] +Path value +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 19:30 +posCursor:[19:30] posNoWhite:[19:29] Found pattern:[19:20->19:32] +Ppat_construct Unary:[19:20->19:25] +posCursor:[19:30] posNoWhite:[19:29] Found pattern:[19:29->19:31] +Completable: Cpattern Value[value]->variantPayload::Unary($1), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[value] +Path value +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 22:23 +posCursor:[22:23] posNoWhite:[22:22] Found expr:[22:3->22:30] +Pexp_apply ...[22:3->22:16] (...[22:17->22:29]) +Completable: Cexpression CArgument Value[consumeOption]($0)->variantPayload::Some($0), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath CArgument Value[consumeOption]($0) +ContextPath Value[consumeOption] +Path consumeOption +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 25:27 +posCursor:[25:27] posNoWhite:[25:26] Found expr:[25:3->25:30] +Pexp_apply ...[25:3->25:16] (...[25:17->25:29]) +Completable: Cexpression CArgument Value[consumeOption]($0)->variantPayload::Some($1), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath CArgument Value[consumeOption]($0) +ContextPath Value[consumeOption] +Path consumeOption +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 28:35 +posCursor:[28:35] posNoWhite:[28:34] Found pattern:[28:26->28:37] +Ppat_construct Some:[28:26->28:30] +posCursor:[28:35] posNoWhite:[28:34] Found pattern:[28:34->28:36] +Completable: Cpattern Value[optionValue]->variantPayload::Some($1), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[optionValue] +Path optionValue +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 31:26 +posCursor:[31:26] posNoWhite:[31:25] Found expr:[31:3->31:30] +Pexp_apply ...[31:3->31:14] (...[31:15->31:29]) +Completable: Cexpression CArgument Value[consumePoly]($0)->polyvariantPayload::Poly($0), tuple($1), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath CArgument Value[consumePoly]($0) +ContextPath Value[consumePoly] +Path consumePoly +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 34:35 +posCursor:[34:35] posNoWhite:[34:34] Found pattern:[34:24->34:38] +posCursor:[34:35] posNoWhite:[34:34] Found pattern:[34:30->34:37] +posCursor:[34:35] posNoWhite:[34:34] Found pattern:[34:34->34:36] +Completable: Cpattern Value[polyValue]->polyvariantPayload::Poly($0), tuple($1), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[polyValue] +Path polyValue +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 37:25 +posCursor:[37:25] posNoWhite:[37:24] Found expr:[37:3->37:28] +Pexp_apply ...[37:3->37:14] (...[37:15->37:27]) +Completable: Cexpression CArgument Value[consumePoly]($0)->polyvariantPayload::Poly($1), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath CArgument Value[consumePoly]($0) +ContextPath Value[consumePoly] +Path consumePoly +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 40:34 +posCursor:[40:34] posNoWhite:[40:33] Found pattern:[40:24->40:36] +posCursor:[40:34] posNoWhite:[40:33] Found pattern:[40:33->40:35] +Completable: Cpattern Value[polyValue]->polyvariantPayload::Poly($1), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[polyValue] +Path polyValue +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 43:51 +posCursor:[43:51] posNoWhite:[43:50] Found expr:[43:45->43:51] +Pexp_field [43:45->43:50] _:[43:52->43:51] +Completable: Cpath Value[first]."" +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[first]."" +ContextPath Value[first] +Path first +ContextPath CPatternPath(Value[value])->variantPayload::Pair($0)->tuple($0) +ContextPath Value[value] +Path value +ContextPath Value[first]-> +ContextPath Value[first] +Path first +ContextPath CPatternPath(Value[value])->variantPayload::Pair($0)->tuple($0) +ContextPath Value[value] +Path value +CPPipe pathFromEnv: found:true +Path CompletionPayloadGrouping. +Path +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 46:52 +posCursor:[46:52] posNoWhite:[46:51] Found expr:[46:45->46:52] +Pexp_field [46:45->46:51] _:[46:53->46:52] +Completable: Cpath Value[second]."" +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[second]."" +ContextPath Value[second] +Path second +ContextPath CPatternPath(Value[value])->variantPayload::Pair($0)->tuple($1) +ContextPath Value[value] +Path value +ContextPath Value[second]-> +ContextPath Value[second] +Path second +ContextPath CPatternPath(Value[value])->variantPayload::Pair($0)->tuple($1) +ContextPath Value[value] +Path value +CPPipe pathFromEnv: found:true +Path CompletionPayloadGrouping. +Path +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 49:50 +posCursor:[49:50] posNoWhite:[49:49] Found expr:[49:44->49:50] +Pexp_field [49:44->49:49] _:[49:51->49:50] +Completable: Cpath Value[first]."" +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[first]."" +ContextPath Value[first] +Path first +ContextPath CPatternPath(Value[value])->variantPayload::Unary($0) +ContextPath Value[value] +Path value +ContextPath Value[first]-> +ContextPath Value[first] +Path first +ContextPath CPatternPath(Value[value])->variantPayload::Unary($0) +ContextPath Value[value] +Path value +CPPipe pathFromEnv: found:true +Path CompletionPayloadGrouping. +Path +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 52:51 +posCursor:[52:51] posNoWhite:[52:50] Found expr:[52:44->52:51] +Pexp_field [52:44->52:50] _:[52:52->52:51] +Completable: Cpath Value[second]."" +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[second]."" +ContextPath Value[second] +Path second +ContextPath CPatternPath(Value[value])->variantPayload::Unary($1) +ContextPath Value[value] +Path value +ContextPath Value[second]-> +ContextPath Value[second] +Path second +ContextPath CPatternPath(Value[value])->variantPayload::Unary($1) +ContextPath Value[value] +Path value +CPPipe pathFromEnv: found:true +Path CompletionPayloadGrouping. +Path +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 55:53 +posCursor:[55:53] posNoWhite:[55:52] Found expr:[55:46->55:53] +Pexp_field [55:46->55:52] _:[55:54->55:53] +Completable: Cpath Value[record]."" +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[record]."" +ContextPath Value[record] +Path record +ContextPath CPatternPath(Value[polyValue])->polyvariantPayload::Poly($0)->tuple($1) +ContextPath Value[polyValue] +Path polyValue +ContextPath Value[record]-> +ContextPath Value[record] +Path record +ContextPath CPatternPath(Value[polyValue])->polyvariantPayload::Poly($0)->tuple($1) +ContextPath Value[polyValue] +Path polyValue +CPPipe pathFromEnv: found:true +Path CompletionPayloadGrouping. +Path +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 58:51 +posCursor:[58:51] posNoWhite:[58:50] Found expr:[58:44->58:51] +Pexp_field [58:44->58:50] _:[58:52->58:51] +Completable: Cpath Value[record]."" +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[record]."" +ContextPath Value[record] +Path record +ContextPath CPatternPath(Value[polyValue])->polyvariantPayload::Poly($1) +ContextPath Value[polyValue] +Path polyValue +ContextPath Value[record]-> +ContextPath Value[record] +Path record +ContextPath CPatternPath(Value[polyValue])->polyvariantPayload::Poly($1) +ContextPath Value[polyValue] +Path polyValue +CPPipe pathFromEnv: found:true +Path CompletionPayloadGrouping. +Path +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 64:25 +posCursor:[64:25] posNoWhite:[64:24] Found expr:[64:3->64:28] +Pexp_apply ...[64:3->64:16] (...[64:17->64:27]) +Completable: Cexpression CArgument Value[consumeResult]($0)->variantPayload::Ok($1), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath CArgument Value[consumeResult]($0) +ContextPath Value[consumeResult] +Path consumeResult +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 67:33 +posCursor:[67:33] posNoWhite:[67:32] Found pattern:[67:26->67:35] +Ppat_construct Ok:[67:26->67:28] +posCursor:[67:33] posNoWhite:[67:32] Found pattern:[67:32->67:34] +Completable: Cpattern Value[resultValue]->variantPayload::Ok($1), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[resultValue] +Path resultValue +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 70:54 +posCursor:[70:54] posNoWhite:[70:53] Found expr:[70:47->70:54] +Pexp_field [70:47->70:53] _:[70:55->70:54] +Completable: Cpath Value[second]."" +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[second]."" +ContextPath Value[second] +Path second +ContextPath CPatternPath(Value[resultValue])->variantPayload::Ok($1) +ContextPath Value[resultValue] +Path resultValue +ContextPath Value[second]-> +ContextPath Value[second] +Path second +ContextPath CPatternPath(Value[resultValue])->variantPayload::Ok($1) +ContextPath Value[resultValue] +Path resultValue +CPPipe pathFromEnv: found:true +Path CompletionPayloadGrouping. +Path +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 73:28 +posCursor:[73:28] posNoWhite:[73:27] Found expr:[73:3->73:31] +Pexp_apply ...[73:3->73:16] (...[73:17->73:30]) +Completable: Cexpression CArgument Value[consumeResult]($0)->variantPayload::Error($1), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath CArgument Value[consumeResult]($0) +ContextPath Value[consumeResult] +Path consumeResult +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 76:36 +posCursor:[76:36] posNoWhite:[76:35] Found pattern:[76:26->76:38] +Ppat_construct Error:[76:26->76:31] +posCursor:[76:36] posNoWhite:[76:35] Found pattern:[76:35->76:37] +Completable: Cpattern Value[resultValue]->variantPayload::Error($1), recordBody +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[resultValue] +Path resultValue +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + +Complete src/CompletionPayloadGrouping.res 79:57 +posCursor:[79:57] posNoWhite:[79:56] Found expr:[79:50->79:57] +Pexp_field [79:50->79:56] _:[79:58->79:57] +Completable: Cpath Value[second]."" +Package opens Stdlib.place holder Pervasives.JsxModules.place holder +Resolved opens 1 Stdlib +ContextPath Value[second]."" +ContextPath Value[second] +Path second +ContextPath CPatternPath(Value[resultValue])->variantPayload::Error($1) +ContextPath Value[resultValue] +Path resultValue +ContextPath Value[second]-> +ContextPath Value[second] +Path second +ContextPath CPatternPath(Value[resultValue])->variantPayload::Error($1) +ContextPath Value[resultValue] +Path resultValue +CPPipe pathFromEnv: found:true +Path CompletionPayloadGrouping. +Path +[ + { + "detail": "string", + "documentation": { + "kind": "markdown", + "value": "```rescript\nname: string\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "name", + "tags": [] + }, + { + "detail": "bool", + "documentation": { + "kind": "markdown", + "value": "```rescript\nenabled: bool\n```\n\n```rescript\ntype payload = {name: string, enabled: bool}\n```" + }, + "kind": 5, + "label": "enabled", + "tags": [] + } +] + From 531a5fd63bb747471e7326f34ba2b6f3988414ee Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 5 Sep 2026 20:06:32 +0200 Subject: [PATCH 39/40] Keep unary tuple signature help on its only parameter Signed-off-by: Christoph Knittel --- CHANGELOG.md | 4 +- analysis/src/signature_help.ml | 9 +++-- .../src/SignatureHelpConstructorTuple.res | 10 +++++ .../SignatureHelpConstructorTuple.res.txt | 40 ++++++++++++++++++- 4 files changed, 55 insertions(+), 8 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 8e5188d1e86..f8ca62d67ef 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -38,8 +38,8 @@ - Fix the side-effect analysis treating bigint exponentiation and bounds-checked array and string reads as pure, which let dead-code elimination drop an unused one that throws: `let _ = 2n ** -1n` no longer raised. https://github.com/rescript-lang/rescript/pull/8617 - Preserve record field `@as` annotations when formatting object types containing spreads. https://github.com/rescript-lang/rescript/pull/8619 -- Fix record-field completion inside tuple arguments of constructors with multiple arguments, in expressions and patterns. https://github.com/rescript-lang/rescript/pull/8610 -- Limit constructor signature help to the argument parentheses, excluding whitespace and comments between the constructor name and its arguments. https://github.com/rescript-lang/rescript/pull/8610 +- Fix record-field completion inside constructor tuple payloads and for their destructured bindings, including both supported tuple spellings and polymorphic variants. https://github.com/rescript-lang/rescript/pull/8610 +- Limit constructor signature help to the argument parentheses, excluding whitespace and comments between the constructor name and its arguments, and keep unary tuple payloads on parameter zero. https://github.com/rescript-lang/rescript/pull/8610 - Fix excessive parentheses and indentation in function assignments to refs, align record and array assignment formatting across refs and fields, and preserve function return-type parentheses and consistent JSX fragment layout in callbacks. https://github.com/rescript-lang/rescript/pull/8611 - Report an error instead of crashing when an integer in a variant constructor's `@as` annotation exceeds the compiler's integer range. https://github.com/rescript-lang/rescript/pull/8619 - Warn about an `@as` on a record field whose payload does not name the field, such as `@as(42)`. It renamed nothing and was silently accepted. https://github.com/rescript-lang/rescript/pull/8619 diff --git a/analysis/src/signature_help.ml b/analysis/src/signature_help.ml index 09dd23b531f..ac781234419 100644 --- a/analysis/src/signature_help.ml +++ b/analysis/src/signature_help.ml @@ -646,7 +646,8 @@ let signature_help ~debug ~source ~kind_file ~pos (List.map (fun (item : Parsetree.expression) -> item.pexp_loc) tuple_items) - | `ConstructorExpr (_, items) when List.length items > 1 -> + | `ConstructorExpr (_, items) when constructor_has_multiple_args + -> constructor_arg_index (List.map (fun (item : Parsetree.expression) -> item.pexp_loc) @@ -680,14 +681,14 @@ let signature_help ~debug ~source ~kind_file ~pos else ()); !field_index | _ -> -1) - | `ConstructorExpr (_, [_]) -> 0 + | `ConstructorExpr (_, _ :: _) -> 0 | `ConstructorPat (_, [{ppat_desc = Ppat_tuple tuple_items}]) when constructor_has_multiple_args -> constructor_arg_index (List.map (fun (item : Parsetree.pattern) -> item.ppat_loc) tuple_items) - | `ConstructorPat (_, items) when List.length items > 1 -> + | `ConstructorPat (_, items) when constructor_has_multiple_args -> constructor_arg_index (List.map (fun (item : Parsetree.pattern) -> item.ppat_loc) @@ -721,7 +722,7 @@ let signature_help ~debug ~source ~kind_file ~pos else ()); !field_index | _ -> -1) - | `ConstructorPat (_, [_]) -> 0 + | `ConstructorPat (_, _ :: _) -> 0 | _ -> -1 in diff --git a/tests/analysis_tests/tests/src/SignatureHelpConstructorTuple.res b/tests/analysis_tests/tests/src/SignatureHelpConstructorTuple.res index d0f8be98814..184629b74c0 100644 --- a/tests/analysis_tests/tests/src/SignatureHelpConstructorTuple.res +++ b/tests/analysis_tests/tests/src/SignatureHelpConstructorTuple.res @@ -1,5 +1,15 @@ type t = Pair(int, string) +type unary = Unary((int, string)) + +let unary = Unary(1, "test") +// ^she + +let readUnary = value => switch value { +| Unary(first, second) => second +// ^she +} + let value = Pair((1, "test")) // ^she diff --git a/tests/analysis_tests/tests/src/expected/SignatureHelpConstructorTuple.res.txt b/tests/analysis_tests/tests/src/expected/SignatureHelpConstructorTuple.res.txt index cf1d5b53e06..d00b3695935 100644 --- a/tests/analysis_tests/tests/src/expected/SignatureHelpConstructorTuple.res.txt +++ b/tests/analysis_tests/tests/src/expected/SignatureHelpConstructorTuple.res.txt @@ -1,4 +1,40 @@ -Signature help src/SignatureHelpConstructorTuple.res 2:23 +Signature help src/SignatureHelpConstructorTuple.res 4:22 +{ + "activeParameter": 0, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 0, + "label": "Unary((int, string))", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 6, 19 ] + } + ] + } + ] +} + +Signature help src/SignatureHelpConstructorTuple.res 8:17 +{ + "activeParameter": 0, + "activeSignature": 0, + "signatures": [ + { + "activeParameter": 0, + "label": "Unary((int, string))", + "parameters": [ + { + "documentation": { "kind": "markdown", "value": "" }, + "label": [ 6, 19 ] + } + ] + } + ] +} + +Signature help src/SignatureHelpConstructorTuple.res 12:23 { "activeParameter": 1, "activeSignature": 0, @@ -20,7 +56,7 @@ Signature help src/SignatureHelpConstructorTuple.res 2:23 ] } -Signature help src/SignatureHelpConstructorTuple.res 6:15 +Signature help src/SignatureHelpConstructorTuple.res 16:15 { "activeParameter": 1, "activeSignature": 0, From 425e204de8ed6ec9f611778bbf7e1531ce470f8d Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Sat, 5 Sep 2026 20:45:10 +0200 Subject: [PATCH 40/40] Preserve attributes on marked polymorphic variant type tuples Signed-off-by: Christoph Knittel --- compiler/ml/ast_mapper_from0.ml | 4 +- tests/ounit_tests/ounit_ast_mapper0_tests.ml | 52 ++++++++++++++++++++ 2 files changed, 55 insertions(+), 1 deletion(-) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 9ccf39ff02f..1c5ab711ae1 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -248,7 +248,9 @@ module T = struct in let txt = match typ.ptyp_desc with - | Ptyp_tuple args when has_constructor_args -> args + | Ptyp_tuple args when has_constructor_args && attrs = [] -> args + (* A PPX may annotate the synthesized tuple. Keep its wrapper when + consuming the marker so those attributes retain their owner. *) | _ -> [{typ with ptyp_attributes = attrs}] in {loc = typ.ptyp_loc; txt} diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index 1762f766b2d..033e23d767b 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -751,6 +751,56 @@ let test_polyvariant_args_roundtrip_through_ast0 _ = () | _ -> assert_failure "Expected two polymorphic variant type arguments" +let test_polyvariant_type_payload_attributes_through_ast0 _ = + let payload_loc = source_loc 10 30 in + let marker = attr "_res.constructor_args" (Parsetree0.PStr []) in + let before = attr "ppx.before" (Parsetree0.PStr []) in + let after = attr "ppx.after" (Parsetree0.PStr []) in + let item = + Ast_helper0.Typ.constr ~loc:(source_loc 12 15) + ~attrs:[attr "ppx.child" (Parsetree0.PStr [])] + (Location.mknoloc (Longident.Lident "int")) + [] + in + let make_variant payload = + Ast_helper0.Typ.variant ~loc:(source_loc 0 32) + [Parsetree0.Rtag (located_string "Pair", [before], false, [payload])] + Closed None + in + List.iter + (fun payload_attrs -> + let payload = + Ast_helper0.Typ.tuple ~loc:payload_loc ~attrs:payload_attrs [item; item] + in + let from0 = Ast_mapper_from0.default_mapper in + let to0 = Ast_mapper_to0.default_mapper in + let decoded = from0.typ from0 (make_variant payload) in + let remaining_attrs = + List.filter (fun attribute -> attribute <> marker) payload_attrs + in + (match decoded.ptyp_desc with + | Ptyp_variant ([Rtag (_, _, false, [{loc; txt}])], _, _) -> ( + OUnit.assert_equal payload_loc loc; + match (remaining_attrs, txt) with + | [], [_; _] -> () + | _ :: _, [{ptyp_desc = Ptyp_tuple [_; _]; ptyp_attributes}] -> + OUnit.assert_bool "bridge marker is consumed" + (not (has_attr "_res.constructor_args" ptyp_attributes)) + | _ -> assert_failure "Expected attributed tuple wrapper to survive") + | _ -> assert_failure "Expected a polymorphic variant type"); + let expected_payload = + if remaining_attrs = [] then payload + else {payload with ptyp_attributes = remaining_attrs} + in + let encoded = to0.typ to0 decoded in + OUnit.assert_equal + ~msg:"preserve payload attributes, children and locations" + (make_variant expected_payload) + encoded; + OUnit.assert_equal ~msg:"a second bridge roundtrip is stable" encoded + (to0.typ to0 (from0.typ from0 encoded))) + [[marker]; [before; marker]; [marker; after]; [before; marker; after]] + let assert_string_expr ~expected_source ~expected_semantic expr = match expr.Parsetree.pexp_desc with | Pexp_constant (Pconst_string payload) -> @@ -1280,6 +1330,8 @@ let suites = >:: test_fresh_ast0_constructor_tuple_defers_arity_to_typechecker; "polyvariant_args_roundtrip_through_ast0" >:: test_polyvariant_args_roundtrip_through_ast0; + "polyvariant_type_payload_attributes_through_ast0" + >:: test_polyvariant_type_payload_attributes_through_ast0; "polyvariant_args_keep_parentheses_location_in_ast0" >:: test_polyvariant_args_keep_parentheses_location_in_ast0; "value_constraint_roundtrips_through_ast0"