From 917530aa64f36400769d2904f58f3d99ff17ede9 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:01:57 +0200 Subject: [PATCH 01/13] 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 | 112 ++++++--------- 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, 938 insertions(+), 695 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 a3ed213e9ff..651b6600bf5 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 @@ -1043,7 +1030,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}, []); }, _ ); }; @@ -1283,17 +1270,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 @@ -1301,18 +1292,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 25c05907f98..19b5f11a3b8 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -2,9 +2,9 @@ let cmi_magic_number = "Caml1999I030" (* Magic numbers for marshaled values of the *current* parsetree, whose layout changes across compiler versions. *) -and ast_impl_magic_number = "ResImpl01304" +and ast_impl_magic_number = "ResImpl01305" -and ast_intf_magic_number = "ResIntf01304" +and ast_intf_magic_number = "ResIntf01305" (* 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 b8ccadda9e5..b0902833543 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 22a8ee36b48..55f276eec01 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -231,11 +231,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 658095545ab..63304956bf2 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 2899c914163..000812cca3e 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 99e54d2f4cf..9f728568522 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: @@ -595,14 +602,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] @@ -664,11 +669,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 @@ -677,13 +680,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 030aa7fe597..bb1520c3929 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 72f81567fbb..a58d0f83d49 100644 --- a/compiler/ml/ast_payload.ml +++ b/compiler/ml/ast_payload.ml @@ -279,8 +279,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 3044e9a08ba..c41f9048fab 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 d421bc2b6f0..9ae19eb7e02 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 b15cecd6f37..039bea5c49d 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; @@ -778,10 +778,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 00b6b60e729..dd80ef11d36 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 = @@ -1424,17 +1425,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)] @@ -1486,8 +1482,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 -> [] @@ -1553,7 +1555,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 = @@ -2171,7 +2173,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, _) @@ -2426,7 +2429,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 @@ -2739,8 +2742,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 @@ -3550,12 +3559,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 @@ -3662,13 +3667,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 @@ -4340,7 +4345,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 @@ -4404,7 +4409,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 @@ -4420,14 +4425,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 1dde1a25662..ac35a909b27 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 adfb7f34e8c..8f251e5f84b 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 @@ -6304,14 +6250,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 0a2aeeb21bc..9acb810e69a 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 @@ -645,9 +643,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 7893e4f3209..da3d53a57d3 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -2128,19 +2128,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 @@ -2714,20 +2716,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; @@ -2745,7 +2745,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 @@ -2763,7 +2763,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 = @@ -2771,16 +2771,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; @@ -2798,7 +2791,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 @@ -2814,6 +2807,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 @@ -3207,7 +3201,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = match (return_expr.pexp_desc, opt_braces) with | _, Some _ -> true | ( ( Pexp_array _ | Pexp_tuple _ - | Pexp_construct (_, Some _) + | Pexp_construct (_, _ :: _) | Pexp_record _ ), _ ) -> true @@ -3353,23 +3347,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; @@ -3394,7 +3375,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 @@ -3480,23 +3461,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; @@ -3521,7 +3488,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 @@ -3543,6 +3510,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) -> @@ -3992,7 +3960,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 @@ -5560,7 +5528,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 5f6afa03430..d5c12b2019b 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 32e2564b049..015389f80dc 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -187,8 +187,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) -> @@ -703,6 +820,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 843776dd6ca6f653463d4b110b67af3cdc1e4f05 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:08:55 +0200 Subject: [PATCH 02/13] 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 651b6600bf5..97166999a12 100644 --- a/analysis/src/completion_front_end.ml +++ b/analysis/src/completion_front_end.ml @@ -1856,10 +1856,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 ( @@ -1870,9 +1867,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 55f276eec01..f86df5142fa 100644 --- a/compiler/jsoo/jsoo_playground_main.ml +++ b/compiler/jsoo/jsoo_playground_main.ml @@ -231,7 +231,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) = @@ -245,10 +245,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 @@ -288,7 +288,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 @@ -567,12 +567,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 015389f80dc..fc2f30be672 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -684,7 +684,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); @@ -704,7 +704,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 066e90d9e1c8df86d99768ce9b2c8c6e70362a8f Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:09:00 +0200 Subject: [PATCH 03/13] 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 8f251e5f84b..1b817cb6a2f 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 1f5f01e7e3cb1122105a138a8ce91258aeb14477 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:09:05 +0200 Subject: [PATCH 04/13] 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 da3d53a57d3..a868811c185 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -2617,6 +2617,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 @@ -2714,101 +2757,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 @@ -3054,6 +3009,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 @@ -3345,59 +3345,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 -> @@ -3459,59 +3407,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 aa8fd172945f9bad6c9eef5b84ca43dc39297bf4 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:09:08 +0200 Subject: [PATCH 05/13] 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 bb1520c3929..3406361b77d 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 9edec645de97bac410983a677c59cac7809a3e96 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:33:01 +0200 Subject: [PATCH 06/13] 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 9aa5c5756b6..15c3d43b135 100644 --- a/compiler/ml/builtin_attributes.ml +++ b/compiler/ml/builtin_attributes.ml @@ -207,11 +207,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 63bf7623315..a5ccce220a8 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 @@ -89,7 +88,6 @@ val warning_scope : *) val warn_on_literal_pattern : Parsetree.attributes -> bool -val explicit_arity : Parsetree.attributes -> bool val immediate : Parsetree.attributes -> bool From ba681ec574ac48d9d599f1075eb6cc06cf2ad5c8 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:33:33 +0200 Subject: [PATCH 07/13] 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 dd80ef11d36..51c27944bd4 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1389,7 +1389,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 @@ -1424,7 +1424,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 @@ -2740,8 +2740,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 758d9b11830a616494c3a1348ab8eda2946d9e89 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:41:05 +0200 Subject: [PATCH 08/13] 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 4dcfb0ee52a..081cca177b9 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 0fe7287a9da95e1e621c876cc80999c1a91533eb Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:51:28 +0200 Subject: [PATCH 09/13] 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 3406361b77d..5d1620162e9 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 51c27944bd4..e22249bbc2e 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -1217,6 +1217,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 () -> @@ -1390,6 +1402,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 @@ -1425,6 +1441,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 @@ -4410,6 +4429,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 @@ -4425,6 +4447,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 fc2f30be672..6f73e214c82 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -218,7 +218,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 @@ -246,6 +251,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)) @@ -824,6 +885,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 244813eff50beb55e494a2f43c55b71169d64f06 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 19:52:23 +0200 Subject: [PATCH 10/13] 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 b374049de4787f68937d764af14f2284a2c9191c Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 20:41:06 +0200 Subject: [PATCH 11/13] 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 5d1620162e9..2377c1fc43a 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 9acb810e69a..796b107c30c 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 a868811c185..0133555b555 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -2617,6 +2617,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 @@ -2661,6 +2671,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 "_" @@ -3172,6 +3191,15 @@ and print_object_get_doc ~state ~expr_loc parent_expr 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 print_arrow e = let async, parameters, return_expr = Parsetree_viewer.fun_expr e in let attrs_on_arrow = e.pexp_attributes in diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index 6f73e214c82..5ba36009a8f 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -237,6 +237,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)) @@ -883,6 +972,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 6e1f2795240e04fcef599153eb0ec662ef8ce898 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 21:15:28 +0200 Subject: [PATCH 12/13] 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 19b5f11a3b8..1a187acfa85 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -1,4 +1,4 @@ -let cmi_magic_number = "Caml1999I030" +let cmi_magic_number = "Caml1999I031" (* 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 = "Caml1999T032" +and cmt_magic_number = "Caml1999T033" let load_path = ref ([] : string list) From cbf4a97d54d433d014051b0aaf4ac679577da127 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Thu, 3 Sep 2026 21:32:25 +0200 Subject: [PATCH 13/13] 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