From ebfda40d05fb2c6f4154989664096c7c31ec9128 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 14 Aug 2026 16:32:26 +0200 Subject: [PATCH 01/10] Enforce function arity in inclusion, type equality, and coercion Add the arity guard (already present in unify) to the Tarrow cases of moregen, eqtype, and subtype_rec. Previously a curried implementation (int => int => int) could satisfy an uncurried interface ((int, int) => int) through signature inclusion or :> coercion; calls made through the interface type compile to direct JavaScript calls with the declared arity, so a first-class use of such a value miscompiled (e.g. returning a closure where an int was expected). The value-mismatch report in includemod now prints a dedicated hint when the two sides are functions of different arities, replacing the vestigial empty curry_kind slot. mcomp is deliberately left arity-lenient: it is an incompatibility oracle for pattern and GADT reasoning, where leniency errs toward "possibly compatible". Co-Authored-By: Claude Fable 5 Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 1 + compiler/ml/ctype.ml | 12 ++++---- compiler/ml/includemod.ml | 29 +++++++++++++++--- tests/ERROR_VARIANTS.md | 4 +-- .../coercion_arity_mismatch.res.expected | 9 ++++++ ...dule_sig_value_arity_mismatch.res.expected | 30 +++++++++++++++++++ .../fixtures/coercion_arity_mismatch.res | 2 ++ .../module_sig_value_arity_mismatch.res | 5 ++++ .../Iface_value_arity_mismatch.expected | 20 +++++++++++++ .../Iface_value_arity_mismatch/Foo.res | 1 + .../Iface_value_arity_mismatch/Foo.resi | 1 + 11 files changed, 102 insertions(+), 12 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/coercion_arity_mismatch.res.expected create mode 100644 tests/build_tests/super_errors/expected/module_sig_value_arity_mismatch.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/coercion_arity_mismatch.res create mode 100644 tests/build_tests/super_errors/fixtures/module_sig_value_arity_mismatch.res create mode 100644 tests/build_tests/super_errors_multi/expected/Iface_value_arity_mismatch.expected create mode 100644 tests/build_tests/super_errors_multi/fixtures/Iface_value_arity_mismatch/Foo.res create mode 100644 tests/build_tests/super_errors_multi/fixtures/Iface_value_arity_mismatch/Foo.resi diff --git a/CHANGELOG.md b/CHANGELOG.md index c8fc4e07038..3ddd25cf26f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -26,6 +26,7 @@ #### :bug: Bug fix - Preserve parentheses around multiplication, division, and modulo expressions used as exponents. https://github.com/rescript-lang/rescript/pull/8550 +- Enforce function arity in interface/module inclusion and type coercion. Previously a curried implementation (e.g. `int => int => int`) could satisfy an uncurried interface (`(int, int) => int`) or be coerced to it, which could miscompile calls made through the interface type. Such mismatches are now compile errors with an explanatory hint. - Preserve multibyte characters when wrapping long source lines in compiler code frames. https://github.com/rescript-lang/rescript/pull/8520 - Fix reanalyze optional-argument diagnostics for functions passed or returned as first-class values. https://github.com/rescript-lang/rescript/pull/8321 diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index bc9cff521d7..7de120c53f7 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -2740,8 +2740,8 @@ let rec moregen inst_nongen type_pairs env t1 t2 = | Tvar _, _ when may_instantiate inst_nongen t1' -> moregen_occur env t1'.level t2; link_type t1' t2 - | Tarrow (arg1, ret1, _), Tarrow (arg2, ret2, _) - when Asttypes.same_arg_label arg1.lbl arg2.lbl -> + | Tarrow (arg1, ret1, a1), Tarrow (arg2, ret2, a2) + when a1 = a2 && Asttypes.same_arg_label arg1.lbl arg2.lbl -> moregen inst_nongen type_pairs env arg1.typ arg2.typ; moregen inst_nongen type_pairs env ret1 ret2 | Ttuple tl1, Ttuple tl2 -> @@ -3010,8 +3010,8 @@ let rec eqtype rename type_pairs subst env t1 t2 = if List.exists (fun (_, t) -> t == t2') !subst then raise (Unify []); subst := (t1', t2') :: !subst) - | Tarrow (arg1, ret1, _), Tarrow (arg2, ret2, _) - when Asttypes.same_arg_label arg1.lbl arg2.lbl -> + | Tarrow (arg1, ret1, a1), Tarrow (arg2, ret2, a2) + when a1 = a2 && Asttypes.same_arg_label arg1.lbl arg2.lbl -> eqtype rename type_pairs subst env arg1.typ arg2.typ; eqtype rename type_pairs subst env ret1 ret2 | Ttuple tl1, Ttuple tl2 -> @@ -3410,8 +3410,8 @@ let rec subtype_rec env trace t1 t2 cstrs = Type_pairs.add subtypes (t1, t2) (); match (t1.desc, t2.desc) with | Tvar _, _ | _, Tvar _ -> (trace, t1, t2, !univar_pairs, None) :: cstrs - | Tarrow (arg1, ret1, _), Tarrow (arg2, ret2, _) - when Asttypes.same_arg_label arg1.lbl arg2.lbl -> + | Tarrow (arg1, ret1, a1), Tarrow (arg2, ret2, a2) + when a1 = a2 && Asttypes.same_arg_label arg1.lbl arg2.lbl -> let cstrs = subtype_rec env ((arg2.typ, arg1.typ) :: trace) diff --git a/compiler/ml/includemod.ml b/compiler/ml/includemod.ml index bd2e430030e..efaba656b74 100644 --- a/compiler/ml/includemod.ml +++ b/compiler/ml/includemod.ml @@ -493,16 +493,37 @@ let show_locs ppf (loc1, loc2) = show_loc "Expected declaration" ppf loc2; show_loc "Actual declaration" ppf loc1 +(* Best-effort: the head arity of a function type, without an env to expand + aliases in. *) +let head_arity ty = + match (Btype.repr ty).desc with + | Tarrow (_, _, arity) -> arity + | _ -> None + +let show_arity_mismatch ppf (d1 : value_description) (d2 : value_description) = + match (head_arity d1.val_type, head_arity d2.val_type) with + | Some n1, Some n2 when n1 <> n2 -> + let args n = + if n = 1 then "1 argument" else string_of_int n ^ " arguments" + in + fprintf ppf + "@\n\ + @[The implementation is a function taking %s, but the interface expects \ + a function taking %s.@ A function's arity is part of its type: calls \ + are compiled to plain JavaScript calls with exactly that many \ + arguments.@]" + (args n1) (args n2) + | _ -> () + let include_err ppf = function | Missing_field (id, loc, kind) -> fprintf ppf "The %s `%a' is required but not provided" kind ident id; show_loc "Expected declaration" ppf loc | Value_descriptions (id, d1, d2) -> - let curry_kind_1, curry_kind_2 = ("", "") in fprintf ppf - "@[Values do not match:@ %a%s@;<1 -2>is not included in@ %a%s@]" - (value_description id) d1 curry_kind_1 (value_description id) d2 - curry_kind_2; + "@[Values do not match:@ %a@;<1 -2>is not included in@ %a@]" + (value_description id) d1 (value_description id) d2; + show_arity_mismatch ppf d1 d2; show_locs ppf (d1.val_loc, d2.val_loc) | Type_declarations (id, d1, d2, errs) -> fprintf ppf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]" diff --git a/tests/ERROR_VARIANTS.md b/tests/ERROR_VARIANTS.md index f22efc29f25..d01285bc0d2 100644 --- a/tests/ERROR_VARIANTS.md +++ b/tests/ERROR_VARIANTS.md @@ -208,7 +208,7 @@ Source: [typecore.ml:27](../compiler/ml/typecore.ml). | `Undefined_method` | ✓ | `super_errors_multi/Cross_module_alias_dot_access`, `undefined_method` | | | `Private_type` | ✓ | `private_type_construction.res` | | | `Private_label` | ✓ | `private_label.res` | | -| `Not_subtype` | ✓ | `subtype_*.res`, `dict_show_no_coercion.res`, etc. | | +| `Not_subtype` | ✓ | `subtype_*.res`, `coercion_arity_mismatch.res`, `dict_show_no_coercion.res`, etc. | | | `Too_many_arguments` | ✓ | `too_many_arguments.res`, `moreArguments*.res` | | | `Abstract_wrong_label` | ✓ | `abstract_wrong_label.res` | Multi-arg function literal where an inner argument label doesn't match the expected arrow's label (e.g. `let f: (~a, ~b) => int = (~a, ~c) => …`). | | `Scoping_let_module` | ✓ | `scoping_let_module.res` | | @@ -353,7 +353,7 @@ Wrapper symptoms attached to inclusion failures. Source: [includemod.ml:23](../c | Variant | Status | Fixture | Notes | |---|---|---|---| | `Missing_field` | ✓ | `super_errors_multi/Iface_missing_value` | | -| `Value_descriptions` | ✓ | `super_errors_multi/Iface_value_descriptions`, `super_errors_multi/Smoke_interface_mismatch` | | +| `Value_descriptions` | ✓ | `super_errors_multi/Iface_value_descriptions`, `super_errors_multi/Iface_value_arity_mismatch`, `super_errors_multi/Smoke_interface_mismatch`, `module_sig_value_arity_mismatch.res` | Arity mismatches print a dedicated hint (implementation vs interface argument counts). | | `Type_declarations` | ✓ | `super_errors_multi/Iface_type_decl_record`, `super_errors_multi/Iface_type_decl_variant`, `RecordInclusion.res` | | | `Extension_constructors` | ✓ | `super_errors_multi/Iface_extension_constructors` | | | `Module_types` | ✓ | `super_errors_multi/Iface_module_types` | | diff --git a/tests/build_tests/super_errors/expected/coercion_arity_mismatch.res.expected b/tests/build_tests/super_errors/expected/coercion_arity_mismatch.res.expected new file mode 100644 index 00000000000..6fd77c58aa4 --- /dev/null +++ b/tests/build_tests/super_errors/expected/coercion_arity_mismatch.res.expected @@ -0,0 +1,9 @@ + + We've found a bug for you! + /.../fixtures/coercion_arity_mismatch.res:2:10-31 + + 1 │ let f = (x: int) => (y: int) => x + y + 2 │ let g = (f :> (int, int) => int) + 3 │ + + Type int => int => int is not a subtype of (int, int) => int \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/module_sig_value_arity_mismatch.res.expected b/tests/build_tests/super_errors/expected/module_sig_value_arity_mismatch.res.expected new file mode 100644 index 00000000000..6b6cd48d755 --- /dev/null +++ b/tests/build_tests/super_errors/expected/module_sig_value_arity_mismatch.res.expected @@ -0,0 +1,30 @@ + + We've found a bug for you! + /.../fixtures/module_sig_value_arity_mismatch.res:3:5-5:1 + + 1 │ module M: { + 2 │ let f: (int, int) => int + 3 │ } = { + 4 │  let f = (x: int) => (y: int) => x + y + 5 │ } + 6 │ + + Signature mismatch: + Modules do not match: + { + let f: int => int => int +} + is not included in + { + let f: (int, int) => int +} + Values do not match: + let f: int => int => int + is not included in + let f: (int, int) => int + The implementation is a function taking 1 argument, but the interface expects a function taking 2 arguments. + A function's arity is part of its type: calls are compiled to plain JavaScript calls with exactly that many arguments. + /.../fixtures/module_sig_value_arity_mismatch.res:2:3-26: + Expected declaration + /.../fixtures/module_sig_value_arity_mismatch.res:4:7: + Actual declaration \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/coercion_arity_mismatch.res b/tests/build_tests/super_errors/fixtures/coercion_arity_mismatch.res new file mode 100644 index 00000000000..93d9111360e --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/coercion_arity_mismatch.res @@ -0,0 +1,2 @@ +let f = (x: int) => (y: int) => x + y +let g = (f :> (int, int) => int) diff --git a/tests/build_tests/super_errors/fixtures/module_sig_value_arity_mismatch.res b/tests/build_tests/super_errors/fixtures/module_sig_value_arity_mismatch.res new file mode 100644 index 00000000000..a335585ac0a --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/module_sig_value_arity_mismatch.res @@ -0,0 +1,5 @@ +module M: { + let f: (int, int) => int +} = { + let f = (x: int) => (y: int) => x + y +} diff --git a/tests/build_tests/super_errors_multi/expected/Iface_value_arity_mismatch.expected b/tests/build_tests/super_errors_multi/expected/Iface_value_arity_mismatch.expected new file mode 100644 index 00000000000..6423de23231 --- /dev/null +++ b/tests/build_tests/super_errors_multi/expected/Iface_value_arity_mismatch.expected @@ -0,0 +1,20 @@ +===== Foo.res ===== + + We've found a bug for you! + /.../fixtures/Iface_value_arity_mismatch/Foo.res:1:5 + + 1 │ let f = (x: int) => (y: int) => x + y + 2 │ + + The implementation /.../fixtures/Iface_value_arity_mismatch/Foo.res + does not match the interface /.../fixtures/Iface_value_arity_mismatch/foo.cmi: + Values do not match: + let f: int => int => int + is not included in + let f: (int, int) => int + The implementation is a function taking 1 argument, but the interface expects a function taking 2 arguments. + A function's arity is part of its type: calls are compiled to plain JavaScript calls with exactly that many arguments. + /.../fixtures/Iface_value_arity_mismatch/Foo.resi:1:1-24: + Expected declaration + /.../fixtures/Iface_value_arity_mismatch/Foo.res:1:5: + Actual declaration \ No newline at end of file diff --git a/tests/build_tests/super_errors_multi/fixtures/Iface_value_arity_mismatch/Foo.res b/tests/build_tests/super_errors_multi/fixtures/Iface_value_arity_mismatch/Foo.res new file mode 100644 index 00000000000..84288dfea8d --- /dev/null +++ b/tests/build_tests/super_errors_multi/fixtures/Iface_value_arity_mismatch/Foo.res @@ -0,0 +1 @@ +let f = (x: int) => (y: int) => x + y diff --git a/tests/build_tests/super_errors_multi/fixtures/Iface_value_arity_mismatch/Foo.resi b/tests/build_tests/super_errors_multi/fixtures/Iface_value_arity_mismatch/Foo.resi new file mode 100644 index 00000000000..7724dd35de5 --- /dev/null +++ b/tests/build_tests/super_errors_multi/fixtures/Iface_value_arity_mismatch/Foo.resi @@ -0,0 +1 @@ +let f: (int, int) => int From ab2699f326eb32caeb4c8a53fcbf75f46964e058 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 14 Aug 2026 16:57:10 +0200 Subject: [PATCH 02/10] Harden the Parsetree0 PPX bridge and add a round-trip corpus The v0 bridge (ast_mapper_to0 / ast_mapper_from0) had several fidelity bugs that surfaced whenever code passed through an external PPX: - the internal res.async marker leaked back into the program as a real attribute after decoding; - attributes on an arrow-type node were merged into the argument's attribute list on the way back, which crashed the formatter with a stack overflow; the two lists are now kept separable with an internal _res.arrow_node_attrs marker, and the arrow_type viewer additionally always consumes the head argument so it can never return its input as the "return type"; - the await node's own attributes were dropped entirely (losing e.g. @outer in "@outer await (@inner e)" and res.braces on async bodies); res.await now serves as the boundary between await-node attributes and inner-expression attributes; - JSX container elements were rebuilt without a closing tag, printing unclosed elements; a closing tag matching the opening tag is now synthesized; - PPX-emitted OCaml-style `function | p -> e` hit assert false; it is now desugared to `fun x -> match x with ...` like the OCaml parser would. Marshaled current-parsetree streams (-as-pp, res_parser -print binary, Ast_mapper.apply_lazy) now carry their own magic numbers (ResImpl01300/ResIntf01300); the Caml1999M022/N022 pair is reserved for the frozen Parsetree0 wire format that external PPXes rely on. Round-trip sweep over all 350 syntax test files: 37 diverging files before, 21 after, no regressions; every arrows/functions/async/await file now round-trips byte-identically. New ast-mapping corpus file FunctionsAndArrows.res pins the constructs, and a unit test covers the function-cases desugaring. Co-Authored-By: Claude Fable 5 Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 2 + compiler/core/js_implementation.ml | 4 +- compiler/ext/config.ml | 9 +++ compiler/ext/config.mli | 9 +++ compiler/ml/ast_mapper.ml | 6 +- compiler/ml/ast_mapper_from0.ml | 66 +++++++++++++++++-- compiler/ml/ast_mapper_to0.ml | 25 +++++-- compiler/syntax/src/res_driver_binary.ml | 8 +-- compiler/syntax/src/res_parsetree_viewer.ml | 6 ++ tests/ounit_tests/ounit_ast_mapper0_tests.ml | 33 ++++++++++ .../data/ast-mapping/FunctionsAndArrows.res | 50 ++++++++++++++ .../expected/ForAwaitOfExpressions.res.txt | 24 ++++--- .../expected/FunctionsAndArrows.res.txt | 50 ++++++++++++++ 13 files changed, 259 insertions(+), 33 deletions(-) create mode 100644 tests/syntax_tests/data/ast-mapping/FunctionsAndArrows.res create mode 100644 tests/syntax_tests/data/ast-mapping/expected/FunctionsAndArrows.res.txt diff --git a/CHANGELOG.md b/CHANGELOG.md index 3ddd25cf26f..0d1ac7afdbb 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -27,6 +27,7 @@ - Preserve parentheses around multiplication, division, and modulo expressions used as exponents. https://github.com/rescript-lang/rescript/pull/8550 - Enforce function arity in interface/module inclusion and type coercion. Previously a curried implementation (e.g. `int => int => int`) could satisfy an uncurried interface (`(int, int) => int`) or be coerced to it, which could miscompile calls made through the interface type. Such mismatches are now compile errors with an explanatory hint. +- Fix losses of fidelity when code passes through an external PPX: the internal `@res.async` marker no longer leaks into the program, attributes on an arrow type or on an `await` expression are no longer dropped or relocated (previously this could crash the formatter), JSX elements keep their closing tag, and PPX-emitted OCaml-style `function` is desugared instead of crashing the compiler. - Preserve multibyte characters when wrapping long source lines in compiler code frames. https://github.com/rescript-lang/rescript/pull/8520 - Fix reanalyze optional-argument diagnostics for functions passed or returned as first-class values. https://github.com/rescript-lang/rescript/pull/8321 @@ -39,6 +40,7 @@ #### :house: Internal - Remove unused compiler IR definitions, modules, helpers, error variants, and Typedtree fields. https://github.com/rescript-lang/rescript/pull/8551 https://github.com/rescript-lang/rescript/pull/8555 +- Give marshaled current-parsetree streams (`-as-pp`, `res_parser -print binary`) their own magic numbers, distinct from the frozen Parsetree0 wire format used for external PPXes. - Add the `-check-lam` compiler option, enable Lambda invariant checking in compiler tests, and remove build-profile-dependent checking. https://github.com/rescript-lang/rescript/pull/8534 - Replace `-bs-diagnose` with `-debug-ir` and make IR diagnostic artifacts deterministic, compilation-local, and easy to clean. https://github.com/rescript-lang/rescript/pull/8535 - Replace CPPO-based browser conditionals with Dune-selected native and playground compiler implementations. https://github.com/rescript-lang/rescript/pull/8541 diff --git a/compiler/core/js_implementation.ml b/compiler/core/js_implementation.ml index df6ab959d12..479860ff9cd 100644 --- a/compiler/core/js_implementation.ml +++ b/compiler/core/js_implementation.ml @@ -43,7 +43,7 @@ let after_parsing_sig ppf outputprefix ast = (* to support relocate to another directory *) ast); if !Js_config.as_pp then ( - output_string stdout Config.ast_intf_magic_number; + output_string stdout Config.res_ast_intf_magic_number; output_value stdout (!Location.input_name : string); output_value stdout ast); if !Js_config.syntax_only then Warnings.check_fatal () @@ -124,7 +124,7 @@ let after_parsing_impl ppf outputprefix (ast : Parsetree.structure) = ~output:(outputprefix ^ Literals.suffix_ast) ast); if !Js_config.as_pp then ( - output_string stdout Config.ast_impl_magic_number; + output_string stdout Config.res_ast_impl_magic_number; output_value stdout (!Location.input_name : string); output_value stdout ast); if !Js_config.syntax_only then Warnings.check_fatal () diff --git a/compiler/ext/config.ml b/compiler/ext/config.ml index d9f7bb64256..05da6896088 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -4,6 +4,15 @@ and ast_impl_magic_number = "Caml1999M022" and ast_intf_magic_number = "Caml1999N022" +(* Magic numbers for marshaled values of the *current* parsetree, whose layout + changes across compiler versions. The [ast_impl_magic_number] / + [ast_intf_magic_number] pair above identifies the frozen Parsetree0 (OCaml + 4.06) layout used on the external-PPX wire and must never be written in + front of a current-parsetree value. *) +and res_ast_impl_magic_number = "ResImpl01300" + +and res_ast_intf_magic_number = "ResIntf01300" + and cmt_magic_number = "Caml1999T022" let load_path = ref ([] : string list) diff --git a/compiler/ext/config.mli b/compiler/ext/config.mli index fe13a03c99b..6c85b26884d 100644 --- a/compiler/ext/config.mli +++ b/compiler/ext/config.mli @@ -27,5 +27,14 @@ val ast_intf_magic_number : string val ast_impl_magic_number : string (* Magic number for file holding an implementation syntax tree *) + +val res_ast_intf_magic_number : string +(* Magic number for a marshaled current-parsetree signature (layout changes + across compiler versions; distinct from the frozen Parsetree0 wire format) *) + +val res_ast_impl_magic_number : string +(* Magic number for a marshaled current-parsetree structure (layout changes + across compiler versions; distinct from the frozen Parsetree0 wire format) *) + val cmt_magic_number : string (* Magic number for compiled interface files *) diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 5ec5c766030..a07a7cfdd74 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -744,7 +744,7 @@ let apply_lazy ~source ~target mapper = let ic = open_in_bin source in let magic = - really_input_string ic (String.length Config.ast_impl_magic_number) + really_input_string ic (String.length Config.res_ast_impl_magic_number) in let rewrite transform = @@ -762,9 +762,9 @@ let apply_lazy ~source ~target mapper = failwith "Ast_mapper: OCaml version mismatch or malformed input" in - if magic = Config.ast_impl_magic_number then + if magic = Config.res_ast_impl_magic_number then rewrite (implem : structure -> structure) - else if magic = Config.ast_intf_magic_number then + else if magic = Config.res_ast_intf_magic_number then rewrite (iface : signature -> signature) else fail () diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 539833fb495..3f15aa17ee5 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -141,8 +141,24 @@ module T = struct | Ptyp_var s -> Typ.var ~loc ~attrs s | Ptyp_arrow (lbl, t1, t2) -> let lbl = Asttypes.to_arg_label lbl in - Typ.arrow ~loc ~arity:None - {attrs; lbl; typ = sub.typ sub t1} + (* [Ast_mapper_to0] flattens the current parsetree's node/argument + attribute split into the v0 arrow's single attribute list, marking + the boundary with [_res.arrow_node_attrs] when node attributes are + present: node attributes come before the marker, argument attributes + after it. Without a marker, everything is an argument attribute. *) + let node_attrs, arg_attrs = + let rec split acc = function + | ({txt = "_res.arrow_node_attrs"}, _) :: rest -> + Some (List.rev acc, rest) + | a :: rest -> split (a :: acc) rest + | [] -> None + in + match split [] attrs with + | Some (node_attrs, arg_attrs) -> (node_attrs, arg_attrs) + | None -> ([], attrs) + in + Typ.arrow ~loc ~attrs:node_attrs ~arity:None + {attrs = arg_attrs; lbl; typ = sub.typ sub t1} (sub.typ sub t2) | Ptyp_tuple tyl -> Typ.tuple ~loc ~attrs (List.map (sub.typ sub) tyl) | Ptyp_constr (lid, tl) -> ( @@ -468,9 +484,20 @@ module E = struct in match desc with | _ when has_await_attribute attrs -> - let attrs = remove_await_attribute e.pexp_attributes in - let e = sub.expr sub {e with pexp_attributes = attrs} in - await ~loc e + (* [Ast_mapper_to0] merges the await node's attributes and the inner + expression's attributes into the one v0 slot, with [res.await] as + the boundary: await-node attributes before it, inner attributes + after it. *) + let await_attrs0, inner_attrs0 = + let rec split acc = function + | ({Location.txt = "res.await"}, _) :: rest -> (List.rev acc, rest) + | a :: rest -> split (a :: acc) rest + | [] -> (List.rev acc, []) + in + split [] e.pexp_attributes + in + let inner = sub.expr sub {e with pexp_attributes = inner_attrs0} in + await ~loc ~attrs:(sub.attributes sub await_attrs0) inner | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) | Pexp_constant x -> constant ~loc ~attrs (map_constant x) | Pexp_let (r, vbs, e) -> @@ -478,10 +505,25 @@ module E = struct | Pexp_fun (lab, def, p, e) -> let lab = Asttypes.to_arg_label lab in let async = Ext_list.exists attrs (fun ({txt}, _) -> txt = "res.async") in + (* [res.async] is bridge metadata added by [Ast_mapper_to0]; it is + decoded into the [async] flag and must not survive as a real + attribute. *) + let attrs = attrs |> List.filter (fun ({txt}, _) -> txt <> "res.async") in fun_ ~loc ~attrs ~async ~arity:None lab (map_opt (sub.expr sub) def) (sub.pat sub p) (sub.expr sub e) - | Pexp_function _ -> assert false + | Pexp_function cases -> + (* The current parsetree has no [function] construct; it can only come + from an external PPX emitting OCaml-style [function | p -> e]. + Desugar to [fun x -> match x with | p -> e] with an unshadowable + parameter name, as the OCaml parser would. *) + let param = "*function*" in + let pat = Pat.var ~loc (Location.mkloc param loc) in + let scrutinee = + ident ~loc (Location.mkloc (Longident.Lident param) loc) + in + let body = match_ ~loc scrutinee (sub.cases sub cases) in + fun_ ~loc ~attrs ~async:false ~arity:None Nolabel None pat body | Pexp_apply ({pexp_desc = Pexp_ident tag_name}, args) when has_jsx_attribute () -> ( let attrs = attrs |> List.filter (fun ({txt}, _) -> txt <> "JSX") in @@ -502,8 +544,18 @@ module E = struct match children with | None -> jsx_unary_element ~loc ~attrs jsx_tag_name props | Some children -> + (* The v0 encoding has no closing-tag information; synthesize one + matching the opening tag, otherwise the printer emits an element + that is never closed. *) + let closing_tag = + { + Pt.jsx_closing_container_tag_start = Lexing.dummy_pos; + jsx_closing_container_tag_name = jsx_tag_name; + jsx_closing_container_tag_end = Lexing.dummy_pos; + } + in jsx_container_element ~loc ~attrs jsx_tag_name props Lexing.dummy_pos - children None) + children (Some closing_tag)) | Pexp_apply (e, l) -> let e = match (e.pexp_desc, l) with diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 3bd7bd0ad70..18a3cdc9fe1 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -124,10 +124,22 @@ module T = struct | Ptyp_var s -> var ~loc ~attrs s | Ptyp_arrow {arg; ret; arity} -> ( let lbl = Asttypes.to_noloc arg.lbl in + (* v0 arrows have a single attribute slot for what the current parsetree + splits into node attributes and argument attributes. Keep the split + recoverable: when node attributes are present, separate the two lists + with an internal marker that [Ast_mapper_from0] strips again. Without + node attributes (the common case) the encoding is unchanged. *) + let arg_attrs = sub.attributes sub arg.attrs in + let merged_attrs = + if attrs = [] then arg_attrs + else + attrs + @ ({txt = "_res.arrow_node_attrs"; loc = Location.none}, Pt.PStr []) + :: arg_attrs + in let typ0 = - arrow ~loc - ~attrs:(attrs @ sub.attributes sub arg.attrs) - lbl (sub.typ sub arg.typ) (sub.typ sub ret) + arrow ~loc ~attrs:merged_attrs lbl (sub.typ sub arg.typ) + (sub.typ sub ret) in match arity with | None -> typ0 @@ -526,11 +538,16 @@ module E = struct open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) | Pexp_await e -> + (* Single v0 attribute slot for two nodes: the await node's own + attributes go in front of the [res.await] marker, the inner + expression's attributes after it, so [Ast_mapper_from0] can split + them again. *) let e = sub.expr sub e in { e with pexp_attributes = - (Location.mknoloc "res.await", Pt.PStr []) :: e.pexp_attributes; + attrs + @ ((Location.mknoloc "res.await", Pt.PStr []) :: e.pexp_attributes); } | Pexp_jsx_element (Jsx_fragment diff --git a/compiler/syntax/src/res_driver_binary.ml b/compiler/syntax/src/res_driver_binary.ml index b6c9318d5cc..55fa069f510 100644 --- a/compiler/syntax/src/res_driver_binary.ml +++ b/compiler/syntax/src/res_driver_binary.ml @@ -3,22 +3,22 @@ let print_engine = { print_implementation = (fun ~width:_ ~filename ~comments:_ structure -> - output_string stdout Config.ast_impl_magic_number; + output_string stdout Config.res_ast_impl_magic_number; output_value stdout filename; output_value stdout structure); print_implementation_from_source = (fun ~width:_ ~source:_ ~comments:_ structure -> - output_string stdout Config.ast_impl_magic_number; + output_string stdout Config.res_ast_impl_magic_number; output_value stdout "source"; output_value stdout structure); print_interface = (fun ~width:_ ~filename ~comments:_ signature -> - output_string stdout Config.ast_intf_magic_number; + output_string stdout Config.res_ast_intf_magic_number; output_value stdout filename; output_value stdout signature); print_interface_from_source = (fun ~width:_ ~source:_ ~comments:_ signature -> - output_string stdout Config.ast_intf_magic_number; + output_string stdout Config.res_ast_intf_magic_number; output_value stdout "source"; output_value stdout signature); } diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index 5a0301dbc7a..c0cbdcbec0e 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -13,6 +13,12 @@ let arrow_type ?(max_arity = max_int) ct = | {ptyp_desc = Ptyp_arrow {arg = {lbl = Nolabel; attrs = []} as arg; ret}} -> process attrs_before (arg :: acc) ret (max_arity - 1) + | {ptyp_desc = Ptyp_arrow {arg = {lbl = Nolabel} as arg; ret}} when acc = [] + -> + (* The head argument is always consumed, attributes or not: returning + the input node itself as the "return type" would make the printer + recurse forever. *) + process attrs_before (arg :: acc) ret (max_arity - 1) | {ptyp_desc = Ptyp_arrow {arg = {lbl = Nolabel}}; ptyp_attributes = _attrs} as return_type -> let args = List.rev acc in diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index b1d902e34d0..450d6197406 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -67,6 +67,37 @@ let test_record_rest_roundtrips_through_ast0 _ = () | _ -> assert_failure "Expected record rest after ast0 roundtrip" +let map_expr0 e = + Ast_mapper_from0.default_mapper.expr Ast_mapper_from0.default_mapper e + +(* A PPX can emit OCaml-style [function | p -> e]; the bridge must desugar it + to [fun x -> match x with | p -> e] rather than crash. *) +let test_function_cases_desugar_to_fun_match _ = + let case0 = + { + Parsetree0.pc_lhs = Ast_helper0.Pat.any ~loc (); + pc_guard = None; + pc_rhs = + Ast_helper0.Exp.constant ~loc (Parsetree0.Pconst_integer ("1", None)); + } + in + let expr = map_expr0 (Ast_helper0.Exp.function_ ~loc [case0]) in + match expr.pexp_desc with + | Parsetree.Pexp_fun + { + arg_label = Nolabel; + default = None; + lhs = {ppat_desc = Ppat_var {txt = param}}; + rhs = + { + pexp_desc = + Pexp_match ({pexp_desc = Pexp_ident {txt = Lident scrutinee}}, [_]); + }; + } -> + OUnit.assert_equal ~msg:"scrutinee is the introduced parameter" param + scrutinee + | _ -> assert_failure "Expected fun x -> match x with ... after desugaring" + let suites = __FILE__ >::: [ @@ -76,4 +107,6 @@ let suites = >:: test_malformed_internal_record_rest_attr_fails; "record_rest_roundtrips_through_ast0" >:: test_record_rest_roundtrips_through_ast0; + "function_cases_desugar_to_fun_match" + >:: test_function_cases_desugar_to_fun_match; ] diff --git a/tests/syntax_tests/data/ast-mapping/FunctionsAndArrows.res b/tests/syntax_tests/data/ast-mapping/FunctionsAndArrows.res new file mode 100644 index 00000000000..75ff778dd51 --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/FunctionsAndArrows.res @@ -0,0 +1,50 @@ +// Round-trip coverage for functions and arrow types through the +// Parsetree0 bridge (ast_mapper_to0 / ast_mapper_from0). + +// n-ary functions and arity-1 sugar +let add = (a, b, c) => a + b + c +let id = x => x + +// labeled, optional, and default parameters +let labeled = (~x, ~y) => x - y +let optional = (~x=?, ~y=1, z) => { + switch x { + | Some(x) => x + y + z + | None => y + z + } +} + +// async functions, with and without newtypes +let fetch = async (url, ~timeout) => url ++ Int.toString(timeout) +let poly = async (type a, x: a) => x +let f = async (type a, ()) => await Promise.resolve() + +// await with attributes on both the await node and the inner expression +let g = async () => @outer await (@inner Promise.resolve(1)) + +// nested and curried-looking shapes must stay distinct +let curried = a => b => a + b +let nested = (a, b) => (c, d) => a + b + c + d + +// underscore apply sugar +let underscore = add(1, _, 3) + +// explicit partial application +let partial = add(1, ...) + +// arrow types: labeled, optional, uncurried groups, nested functions +type cb = (~x: int, ~y: float) => string +type opt = (~x: int=?, unit) => int +type nested2 = (int, int) => (string, string) => bool +type curriedAnnot = int => int => int + +// attributes on the arrow node vs on an argument +type nodeAttr = @attr (string => unit) +type argAttr = (@as("x") ~foo: string, int) => int + +// phantom @as arguments in externals (arity != arrow-chain length) +@val +external phantom: (~a: int, @as(json`false`) _, ~c: string) => unit = "phantom" + +// external with uncurried callback argument +@val external onEvent: (string, (~event: string) => unit) => unit = "on" diff --git a/tests/syntax_tests/data/ast-mapping/expected/ForAwaitOfExpressions.res.txt b/tests/syntax_tests/data/ast-mapping/expected/ForAwaitOfExpressions.res.txt index 113504d8853..de4ed562f6e 100644 --- a/tests/syntax_tests/data/ast-mapping/expected/ForAwaitOfExpressions.res.txt +++ b/tests/syntax_tests/data/ast-mapping/expected/ForAwaitOfExpressions.res.txt @@ -1,18 +1,16 @@ // Test for await..of AST mapping -let testForAwaitOf = - @res.async - async () => { - let iterable = asyncIterable +let testForAwaitOf = async () => { + let iterable = asyncIterable - // Basic for await..of - for await x of iterable { - Console.log(x) - } + // Basic for await..of + for await x of iterable { + Console.log(x) + } - // Nested async loop body - for await item of iterable { - let result = await Promise.resolve(item + 1) - Console.log(result) - } + // Nested async loop body + for await item of iterable { + let result = await Promise.resolve(item + 1) + Console.log(result) } +} diff --git a/tests/syntax_tests/data/ast-mapping/expected/FunctionsAndArrows.res.txt b/tests/syntax_tests/data/ast-mapping/expected/FunctionsAndArrows.res.txt new file mode 100644 index 00000000000..75ff778dd51 --- /dev/null +++ b/tests/syntax_tests/data/ast-mapping/expected/FunctionsAndArrows.res.txt @@ -0,0 +1,50 @@ +// Round-trip coverage for functions and arrow types through the +// Parsetree0 bridge (ast_mapper_to0 / ast_mapper_from0). + +// n-ary functions and arity-1 sugar +let add = (a, b, c) => a + b + c +let id = x => x + +// labeled, optional, and default parameters +let labeled = (~x, ~y) => x - y +let optional = (~x=?, ~y=1, z) => { + switch x { + | Some(x) => x + y + z + | None => y + z + } +} + +// async functions, with and without newtypes +let fetch = async (url, ~timeout) => url ++ Int.toString(timeout) +let poly = async (type a, x: a) => x +let f = async (type a, ()) => await Promise.resolve() + +// await with attributes on both the await node and the inner expression +let g = async () => @outer await (@inner Promise.resolve(1)) + +// nested and curried-looking shapes must stay distinct +let curried = a => b => a + b +let nested = (a, b) => (c, d) => a + b + c + d + +// underscore apply sugar +let underscore = add(1, _, 3) + +// explicit partial application +let partial = add(1, ...) + +// arrow types: labeled, optional, uncurried groups, nested functions +type cb = (~x: int, ~y: float) => string +type opt = (~x: int=?, unit) => int +type nested2 = (int, int) => (string, string) => bool +type curriedAnnot = int => int => int + +// attributes on the arrow node vs on an argument +type nodeAttr = @attr (string => unit) +type argAttr = (@as("x") ~foo: string, int) => int + +// phantom @as arguments in externals (arity != arrow-chain length) +@val +external phantom: (~a: int, @as(json`false`) _, ~c: string) => unit = "phantom" + +// external with uncurried callback argument +@val external onEvent: (string, (~event: string) => unit) => unit = "on" From e019ed3f0e24053e365cd8ae66a56a60f3081de8 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 14 Aug 2026 17:08:05 +0200 Subject: [PATCH 03/10] Make parsetree arrow arity honest The parser deliberately decremented the head arity of an external's arrow type for each labelled phantom argument (~x: @as(json`...`) _), and the printer contained the mirror-image hack re-adding it. The decremented number was consumed by nobody else: external processing erases phantom arguments from the type and recounts the arity from the kept arguments (process_obj returns List.length args, and the non-obj path rebuilds the type with Typ.arrows, which stamps its own arity). Remove the fudge and the compensation, along with the In_external tracking module whose only purpose it was. The parsetree invariant is now unconditional: a head arrow's arity equals the number of written parameters. Also fix bare labeled arrow types (~x: int => string) parsing with no arity: they printed identically to the parenthesized form ((~x: int) => string) but did not unify with it. Verified: AsInUncurriedExternals formatting is idempotent, its bridge round-trip and generated JS are byte-identical, and the full test suite passes with no .mjs drift. Co-Authored-By: Claude Fable 5 Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 2 + compiler/syntax/src/res_core.ml | 44 +++++-------------- compiler/syntax/src/res_parsetree_viewer.ml | 17 +------ .../errors/typexpr/expected/arrow.res.txt | 2 +- .../grammar/typexpr/expected/es6Arrow.res.txt | 16 +++---- tests/tests/src/bare_labeled_arrow_type.mjs | 20 +++++++++ tests/tests/src/bare_labeled_arrow_type.res | 12 +++++ 7 files changed, 56 insertions(+), 57 deletions(-) create mode 100644 tests/tests/src/bare_labeled_arrow_type.mjs create mode 100644 tests/tests/src/bare_labeled_arrow_type.res diff --git a/CHANGELOG.md b/CHANGELOG.md index 0d1ac7afdbb..1f7f672f1f6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -27,6 +27,7 @@ - Preserve parentheses around multiplication, division, and modulo expressions used as exponents. https://github.com/rescript-lang/rescript/pull/8550 - Enforce function arity in interface/module inclusion and type coercion. Previously a curried implementation (e.g. `int => int => int`) could satisfy an uncurried interface (`(int, int) => int`) or be coerced to it, which could miscompile calls made through the interface type. Such mismatches are now compile errors with an explanatory hint. +- Fix bare labeled arrow types (`~x: int => string`) getting no arity: they printed identically to their parenthesized form (`(~x: int) => string`) but did not unify with it. - Fix losses of fidelity when code passes through an external PPX: the internal `@res.async` marker no longer leaks into the program, attributes on an arrow type or on an `await` expression are no longer dropped or relocated (previously this could crash the formatter), JSX elements keep their closing tag, and PPX-emitted OCaml-style `function` is desugared instead of crashing the compiler. - Preserve multibyte characters when wrapping long source lines in compiler code frames. https://github.com/rescript-lang/rescript/pull/8520 - Fix reanalyze optional-argument diagnostics for functions passed or returned as first-class values. https://github.com/rescript-lang/rescript/pull/8321 @@ -41,6 +42,7 @@ - Remove unused compiler IR definitions, modules, helpers, error variants, and Typedtree fields. https://github.com/rescript-lang/rescript/pull/8551 https://github.com/rescript-lang/rescript/pull/8555 - Give marshaled current-parsetree streams (`-as-pp`, `res_parser -print binary`) their own magic numbers, distinct from the frozen Parsetree0 wire format used for external PPXes. +- Make parsetree arrow arity honest for externals with phantom `@as(...) _` arguments: the parser no longer pre-decrements the head arity (external processing recounts after erasing phantoms), and the mirrored printer compensation is removed. The arity annotation now always equals the number of written parameters. - Add the `-check-lam` compiler option, enable Lambda invariant checking in compiler tests, and remove build-profile-dependent checking. https://github.com/rescript-lang/rescript/pull/8534 - Replace `-bs-diagnose` with `-debug-ir` and make IR diagnostic artifacts deterministic, compilation-local, and easy to clean. https://github.com/rescript-lang/rescript/pull/8535 - Replace CPPO-based browser conditionals with Dune-selected native and playground compiler implementations. https://github.com/rescript-lang/rescript/pull/8541 diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 91b821a459d..4d0e319940b 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -263,10 +263,6 @@ module Error_messages = struct "Spreading JSX children is no longer supported." end -module In_external = struct - let status = ref false -end - let ternary_attr = (Location.mknoloc "res.ternary", Parsetree.PStr []) let if_let_attr = (Location.mknoloc "res.iflet", Parsetree.PStr []) let make_await_attr loc = (Location.mkloc "res.await" loc, Parsetree.PStr []) @@ -5059,7 +5055,11 @@ and parse_es6_arrow_type ?current_type_name_path ?inline_types_context ~attrs p ?inline_types_context p in let loc = mk_loc start_pos p.prev_end_pos in - Ast_helper.Typ.arrow ~loc ~arity:None {attrs; lbl; typ} return_type + (* A bare labeled arrow type [~x: t => u] is a complete one-parameter + arrow, exactly like its parenthesized form [(~x: t) => u]; it must + carry the same arity or the two spellings produce types that print + identically but do not unify. *) + Ast_helper.Typ.arrow ~loc ~arity:(Some 1) {attrs; lbl; typ} return_type | DocComment _ -> assert false | _ -> let parameters = @@ -5075,35 +5075,19 @@ and parse_es6_arrow_type ?current_type_name_path ?inline_types_context ~attrs p ?inline_types_context p in let end_pos = p.prev_end_pos in - let return_type_arity = 0 in - let _paramNum, typ, _arity = + let arity = List.length parameters in + let _paramNum, typ = List.fold_right - (fun {attrs; label = arg_lbl; typ; start_pos} (param_num, t, arity) -> + (fun {attrs; label = arg_lbl; typ; start_pos} (param_num, t) -> let loc = mk_loc start_pos end_pos in - let arity = - (* Workaround for ~lbl: @as(json`false`) _, which changes the arity *) - match arg_lbl with - | Labelled _s -> - let typ_is_any = - match typ.ptyp_desc with - | Ptyp_any -> true - | _ -> false - in - let has_as = - Ext_list.exists typ.ptyp_attributes (fun (x, _) -> x.txt = "as") - in - if !In_external.status && typ_is_any && has_as then arity - 1 - else arity - | _ -> arity - in let t_arg = Ast_helper.Typ.arrow ~loc ~arity:None {attrs; lbl = arg_lbl; typ} t in if param_num = 1 then - (param_num - 1, Ast_uncurried.uncurried_type ~arity t_arg, 1) - else (param_num - 1, t_arg, arity + 1)) + (param_num - 1, Ast_uncurried.uncurried_type ~arity t_arg) + else (param_num - 1, t_arg)) parameters - (List.length parameters, return_type, return_type_arity + 1) + (List.length parameters, return_type) in { typ with @@ -6640,13 +6624,9 @@ and parse_type_definition_or_extension ~attrs p = (* external value-name : typexp = external-declaration *) and parse_external_def ~attrs ~start_pos p = - let in_external = !In_external.status in - In_external.status := true; Parser.leave_breadcrumb p Grammar.External; Fun.protect - ~finally:(fun () -> - Parser.eat_breadcrumb p; - In_external.status := in_external) + ~finally:(fun () -> Parser.eat_breadcrumb p) (fun () -> Parser.expect Token.External p; let name, loc = parse_lident p in diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index c0cbdcbec0e..23da01e468c 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -1,9 +1,6 @@ open Parsetree let arrow_type ?(max_arity = max_int) ct = - let has_as_attr attrs = - Ext_list.exists attrs (fun (x, _) -> x.Asttypes.txt = "as") - in let rec process attrs_before acc typ max_arity = match typ with | _ when max_arity < 0 -> (attrs_before, List.rev acc, typ) @@ -27,19 +24,7 @@ let arrow_type ?(max_arity = max_int) ct = ptyp_desc = Ptyp_arrow {arg = {lbl = Labelled _ | Optional _} as arg; ret}; ptyp_attributes = _attrs; } -> - (* Res_core.parse_es6_arrow_type has a workaround that removed an extra arity for the function if the - argument is a Ptyp_any with @as attribute i.e. ~x: @as(`{prop: value}`) _. - - When this case is encountered we add that missing arity so the arrow is printed properly. - *) - let arity = - match arg.typ with - | {ptyp_desc = Ptyp_any; ptyp_attributes = attrs1} - when has_as_attr attrs1 -> - max_arity - | _ -> max_arity - 1 - in - process attrs_before (arg :: acc) ret arity + process attrs_before (arg :: acc) ret (max_arity - 1) | typ -> (attrs_before, List.rev acc, typ) in match ct with diff --git a/tests/syntax_tests/data/parsing/errors/typexpr/expected/arrow.res.txt b/tests/syntax_tests/data/parsing/errors/typexpr/expected/arrow.res.txt index c621d68f7f0..31e172542b1 100644 --- a/tests/syntax_tests/data/parsing/errors/typexpr/expected/arrow.res.txt +++ b/tests/syntax_tests/data/parsing/errors/typexpr/expected/arrow.res.txt @@ -46,5 +46,5 @@ module Error3 = type nonrec observation = { observed: int ; - onStep: currentValue:unit -> [%rescript.typehole ] } + onStep: currentValue:unit -> [%rescript.typehole ] (a:1) } end \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/es6Arrow.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/es6Arrow.res.txt index 2de8c1b7878..de16403398b 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/es6Arrow.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/es6Arrow.res.txt @@ -12,15 +12,15 @@ let (t : a:int -> b:int -> int (a:2)) = xf let (t : ?a:int -> ?b:int -> int (a:2)) = xf let (t : int -> int -> int -> int (a:1) (a:1) (a:1)) = xf let (t : a:int -> b:int -> c:int -> int (a:1) (a:1) (a:1)) = xf -type nonrec t = f:int -> string -type nonrec t = ?f:int -> string -let (f : f:int -> string) = fx -let (f : ?f:int -> string) = fx type nonrec t = f:int -> string (a:1) -type nonrec t = f:int -> string +type nonrec t = ?f:int -> string (a:1) +let (f : f:int -> string (a:1)) = fx +let (f : ?f:int -> string (a:1)) = fx +type nonrec t = f:int -> string (a:1) +type nonrec t = f:int -> string (a:1) +type nonrec t = f:(int -> string (a:1)) -> float (a:1) type nonrec t = f:(int -> string (a:1)) -> float (a:1) -type nonrec t = f:(int -> string (a:1)) -> float -type nonrec t = f:int -> string -> float (a:1) +type nonrec t = f:int -> string -> float (a:1) (a:1) type nonrec t = a:int[@attrBeforeLblA ] -> b:int[@attrBeforeLblB ] -> ((float)[@attr ]) -> unit (a:3) @@ -28,7 +28,7 @@ type nonrec t = ((a:int -> ((b:int -> ((float)[@attr ]) -> unit (a:1) (a:1))[@attrBeforeLblB ]) (a:1)) [@attrBeforeLblA ]) -type nonrec t = a:int[@attr ] -> unit +type nonrec t = a:int[@attr ] -> unit (a:1) type nonrec 'a getInitialPropsFn = < query: string dict ;req: < .. > nullable > -> < .. > Promise.t (a:1) \ No newline at end of file diff --git a/tests/tests/src/bare_labeled_arrow_type.mjs b/tests/tests/src/bare_labeled_arrow_type.mjs new file mode 100644 index 00000000000..32036e7c680 --- /dev/null +++ b/tests/tests/src/bare_labeled_arrow_type.mjs @@ -0,0 +1,20 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +function f(x) { + return x.toString(); +} + +let r = (1).toString(); + +let g = f; + +let h = f; + +export { + f, + g, + h, + r, +} +/* r Not a pure module */ diff --git a/tests/tests/src/bare_labeled_arrow_type.res b/tests/tests/src/bare_labeled_arrow_type.res new file mode 100644 index 00000000000..dc942979768 --- /dev/null +++ b/tests/tests/src/bare_labeled_arrow_type.res @@ -0,0 +1,12 @@ +// Regression test: a bare labeled arrow type (~x: int => string, without +// parens) must be the same type as the parenthesized spelling below; the +// unparenthesized form used to get no arity, so the two printed identically +// but did not unify. The formatter normalizes the bare form away, so the +// parser-level behavior is pinned by the es6Arrow.res parsing snapshot; +// this file keeps the unification working end to end. +type t = (~x: int) => string + +let f: t = (~x) => Int.toString(x) +let g: (~x: int) => string = f +let h: t = g +let r = f(~x=1) From 8de13f5679ea5d9c5ed01350d62e6a9104c4a3bd Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 14 Aug 2026 18:02:06 +0200 Subject: [PATCH 04/10] Make functions and arrow types n-ary in the parsetree Replace the curried one-parameter-per-node encoding with n-ary nodes: Ptyp_arrow of {params: arg list; ret: core_type} Pexp_fun of {params: fun_param list; body: expression; async: bool} where fun_param carries per-parameter attributes, label, default, and pattern. The arity annotation is gone from the parsetree: a function's arity is List.length params, unrepresentable wrong. ast_uncurried.ml is deleted; Ast_helper.Typ.arrow and Exp.fun_ are list-first and assert non-empty parameter lists. The typed layers are unchanged: typetexp folds the params list into the existing curried Tarrow/Ttyp_arrow chains (Some arity on the head, None inside), and typecore peels parameters one at a time, reproducing the legacy per-level type_function calls; synthesized rest-functions carry an internal #res.fun_rest attribute consumed immediately on re-entry. The Parsetree0 bridge re-curries on the way out (byte-identical wire format for external PPXes) and gathers Has_arityN / res.arity groups back into one node on the way in; bare PPX-fabricated v0 funs decode as one-parameter functions instead of the old, mostly unusable arity-None encoding. Attribute contract: in-parens parameter attributes stay on the patterns (as before); arrow-level attributes (@attr (a, b) => ...) live on the function node; p_attrs is populated only by the PPX bridge. Printing is byte-identical across the syntax test corpus; generated JavaScript is byte-identical across the test suite except UncurriedExternals.res, where `@this this => async arg => ...` now honors the written nesting (a method returning an async function) instead of absorbing the nested lambda's parameter into the method - the group-boundary ambiguity this representation removes. Signature help no longer includes the opening paren in the first parameter's highlight range, and completion debug traces lose their synthetic chain-node lines. Also fixes three latent Typ.arrow-on-empty-params paths (zero-argument externals, @deriving(accessors) zero-argument constructors in signatures, parser error recovery) that the old arrows helper silently absorbed. Co-Authored-By: Claude Fable 5 Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 1 + analysis/src/completion_front_end.ml | 70 +++-- analysis/src/dump_ast.ml | 2 +- analysis/src/hint.ml | 3 +- analysis/src/signature_help.ml | 65 ++-- analysis/src/xform.ml | 24 +- compiler/frontend/ast_compatible.ml | 10 +- compiler/frontend/ast_compatible.mli | 1 - compiler/frontend/ast_core_type.ml | 41 +-- compiler/frontend/ast_core_type_class_type.ml | 12 +- compiler/frontend/ast_derive_abstract.ml | 8 +- compiler/frontend/ast_derive_js_mapper.ml | 14 +- compiler/frontend/ast_derive_projector.ml | 28 +- compiler/frontend/ast_exp_handle_external.ml | 10 +- compiler/frontend/ast_external_process.ml | 20 +- compiler/frontend/ast_pat.ml | 4 +- compiler/frontend/ast_typ_uncurry.ml | 15 +- compiler/frontend/ast_typ_uncurry.mli | 2 +- compiler/frontend/ast_uncurry_gen.ml | 118 ++++---- compiler/frontend/ast_uncurry_gen.mli | 3 +- compiler/frontend/bs_ast_mapper.ml | 24 +- compiler/frontend/bs_builtin_ppx.ml | 37 +-- compiler/ml/ast_async.ml | 20 +- compiler/ml/ast_helper.ml | 33 ++- compiler/ml/ast_helper.mli | 14 +- compiler/ml/ast_iterator.ml | 15 +- compiler/ml/ast_mapper.ml | 24 +- compiler/ml/ast_mapper_from0.ml | 86 +++++- compiler/ml/ast_mapper_to0.ml | 131 ++++---- compiler/ml/ast_uncurried.ml | 21 -- compiler/ml/depend.ml | 16 +- compiler/ml/parsetree.ml | 38 ++- compiler/ml/pprintast.ml | 61 ++-- compiler/ml/printast.ml | 36 +-- compiler/ml/typecore.ml | 179 +++++++---- compiler/ml/typetexp.ml | 42 ++- compiler/syntax/src/jsx_v4.ml | 280 ++++++++++-------- compiler/syntax/src/res_ast_debugger.ml | 32 +- compiler/syntax/src/res_comments_table.ml | 100 ++----- compiler/syntax/src/res_core.ml | 94 +++--- compiler/syntax/src/res_parens.ml | 15 +- compiler/syntax/src/res_parsetree_viewer.ml | 112 +++---- compiler/syntax/src/res_parsetree_viewer.mli | 1 - compiler/syntax/src/res_printer.ml | 24 +- .../deadcode/expected/deadcode.txt | 16 +- .../expected/CompletionInferValues.res.txt | 4 - .../src/expected/FirstClassModules.res.txt | 1 - .../tests/src/expected/SignatureHelp.res.txt | 123 ++++---- tests/ounit_tests/ounit_ast_mapper0_tests.ml | 13 +- .../expected/ambiguousArrow.res.txt | 5 +- .../errors/expressions/expected/arrow.res.txt | 4 +- .../errors/expressions/expected/block.res.txt | 21 +- .../expected/UncurriedByDefault.res.txt | 11 +- .../expressions/expected/apply.res.txt | 2 +- .../expressions/expected/async.res.txt | 4 +- .../grammar/expressions/expected/jsx.res.txt | 71 ++--- .../expected/locallyAbstractTypes.res.txt | 11 +- .../grammar/typexpr/expected/es6Arrow.res.txt | 4 +- .../grammar/typexpr/expected/poly.res.txt | 5 +- .../typexpr/expected/uncurried.res.txt | 8 +- tests/tests/src/UncurriedExternals.mjs | 4 +- tools/src/transforms.ml | 21 +- 62 files changed, 1153 insertions(+), 1061 deletions(-) delete mode 100644 compiler/ml/ast_uncurried.ml diff --git a/CHANGELOG.md b/CHANGELOG.md index 1f7f672f1f6..8518a3c6b99 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -41,6 +41,7 @@ #### :house: Internal - Remove unused compiler IR definitions, modules, helpers, error variants, and Typedtree fields. https://github.com/rescript-lang/rescript/pull/8551 https://github.com/rescript-lang/rescript/pull/8555 +- Make functions and arrow types n-ary in the parsetree: `Pexp_fun` carries a parameter list and `Ptyp_arrow` a parameter list, replacing the curried one-parameter-per-node chains with an `arity` annotation on the head. Arity is now structural (`List.length params`) and `ast_uncurried.ml` is deleted. The typed layers, cmt format, generated JavaScript, printed output, and the external-PPX wire format are unchanged. - Give marshaled current-parsetree streams (`-as-pp`, `res_parser -print binary`) their own magic numbers, distinct from the frozen Parsetree0 wire format used for external PPXes. - Make parsetree arrow arity honest for externals with phantom `@as(...) _` arguments: the parser no longer pre-decrements the head arity (external processing recounts after erasing phantoms), and the mirrored printer compensation is removed. The arity annotation now always equals the number of written parameters. - Add the `-check-lam` compiler option, enable Lambda invariant checking in compiler tests, and remove build-profile-dependent checking. https://github.com/rescript-lang/rescript/pull/8534 diff --git a/analysis/src/completion_front_end.ml b/analysis/src/completion_front_end.ml index b1562a608cc..e7d61ad9c13 100644 --- a/analysis/src/completion_front_end.ml +++ b/analysis/src/completion_front_end.ml @@ -1601,42 +1601,48 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file | Some context_path -> set_result (Cpath (CPObj (context_path, label))) | None -> ()) - | Pexp_fun - {arg_label = lbl; default = default_exp_opt; lhs = pat; rhs = e} -> + | Pexp_fun {params; body = e} -> let old_scope = !scope in (match (!processing_fun, !current_ctx_path) with | None, Some ctx_path -> processing_fun := Some (ctx_path, 0) | _ -> ()); - let arg_context_path = - match !processing_fun with - | None -> None - | Some (ctx_path, current_unlabelled_count) -> - (processing_fun := - match lbl with - | Nolabel -> Some (ctx_path, current_unlabelled_count + 1) - | _ -> Some (ctx_path, current_unlabelled_count)); - if Debug.verbose () then - print_endline "[expr_iter] Completing for argument value"; - Some - (Completable.CArgument - { - function_context_path = ctx_path; - argument_label = - (match lbl with - | Nolabel -> - Unlabelled - {argument_position = current_unlabelled_count} - | Optional {txt = name} -> Optional name - | Labelled {txt = name} -> Labelled name); - }) - in - (match default_exp_opt with - | None -> () - | Some default_exp -> iterator.expr iterator default_exp); - if loc_has_cursor e.pexp_loc = false then - complete_pattern ?context_path:arg_context_path pat; - scope_pattern ?context_path:arg_context_path pat; - iterator.pat iterator pat; + params + |> List.iter + (fun + ({p_lbl = lbl; p_default = default_exp_opt; p_pat = pat} : + Parsetree.fun_param) + -> + let arg_context_path = + match !processing_fun with + | None -> None + | Some (ctx_path, current_unlabelled_count) -> + (processing_fun := + match lbl with + | Nolabel -> + Some (ctx_path, current_unlabelled_count + 1) + | _ -> Some (ctx_path, current_unlabelled_count)); + if Debug.verbose () then + print_endline "[expr_iter] Completing for argument value"; + Some + (Completable.CArgument + { + function_context_path = ctx_path; + argument_label = + (match lbl with + | Nolabel -> + Unlabelled + {argument_position = current_unlabelled_count} + | Optional {txt = name} -> Optional name + | Labelled {txt = name} -> Labelled name); + }) + in + (match default_exp_opt with + | None -> () + | Some default_exp -> iterator.expr iterator default_exp); + if loc_has_cursor e.pexp_loc = false then + complete_pattern ?context_path:arg_context_path pat; + scope_pattern ?context_path:arg_context_path pat; + iterator.pat iterator pat); iterator.expr iterator e; scope := old_scope; processed := true diff --git a/analysis/src/dump_ast.ml b/analysis/src/dump_ast.ml index 19b45e07f2a..14c4215e1c0 100644 --- a/analysis/src/dump_ast.ml +++ b/analysis/src/dump_ast.ml @@ -242,7 +242,7 @@ and print_expr_item expr ~pos ~indentation = | None -> "" | Some expr -> "," ^ print_expr_item expr ~pos ~indentation) ^ ")" - | Pexp_fun {arg_label = arg; lhs = pattern; rhs = next_expr} -> + | Pexp_fun {params = {p_lbl = arg; p_pat = pattern} :: _; body = next_expr} -> "Pexp_fun(\n" ^ add_indentation (indentation + 1) ^ "arg: " diff --git a/analysis/src/hint.ml b/analysis/src/hint.ml index 49b290089bc..9f696668eb4 100644 --- a/analysis/src/hint.ml +++ b/analysis/src/hint.ml @@ -62,8 +62,7 @@ let inlay ~source ~kind_file ~pos ~max_length ~full ~state ~debug = ( Pexp_constant _ | Pexp_tuple _ | Pexp_record _ | Pexp_variant _ | Pexp_apply _ | Pexp_match _ | Pexp_construct _ | Pexp_ifthenelse _ | Pexp_array _ | Pexp_ident _ | Pexp_try _ | Pexp_send _ - | Pexp_field _ | Pexp_open _ - | Pexp_fun {arity = Some _} ); + | Pexp_field _ | Pexp_open _ | Pexp_fun _ ); }; } -> push vb.pvb_pat.ppat_loc Type diff --git a/analysis/src/signature_help.ml b/analysis/src/signature_help.ml index aca9539536e..ae5c3fe71aa 100644 --- a/analysis/src/signature_help.ml +++ b/analysis/src/signature_help.ml @@ -112,36 +112,43 @@ let extract_parameters ~signature ~type_str_for_parser ~label_prefix_len = | _ -> false -> let rec extract_params expr params = match expr with - | { - (* Gotcha: functions with multiple arugments are modelled as a series of single argument functions. *) - Parsetree.ptyp_desc = Ptyp_arrow {arg; ret = next_function_expr}; - ptyp_loc; - } -> - let start_offset = - ptyp_loc |> Loc.start - |> Pos.position_to_offset type_str_for_parser - |> Option.get + | {Parsetree.ptyp_desc = Ptyp_arrow {params = args; ret}} -> + let params = + List.fold_left + (fun params (arg : Parsetree.arg) -> + let start_loc = + (* For a labeled argument the label precedes the type. *) + match arg.lbl with + | Asttypes.Labelled {loc} | Optional {loc} -> loc |> Loc.start + | Nolabel -> arg.typ.ptyp_loc |> Loc.start + in + let start_offset = + start_loc + |> Pos.position_to_offset type_str_for_parser + |> Option.get + in + let end_offset = + arg.typ.ptyp_loc |> Loc.end_ + |> Pos.position_to_offset type_str_for_parser + |> Option.get + in + (* The AST locations does not account for "=?" of optional arguments, so add that to the offset here if needed. *) + let end_offset = + match arg.lbl with + | Asttypes.Optional _ -> end_offset + 2 + | _ -> end_offset + in + params + @ [ + ( arg.lbl, + (* Remove the label prefix offset here, since we're not + showing that to the end user. *) + start_offset - label_prefix_len, + end_offset - label_prefix_len ); + ]) + params args in - let end_offset = - arg.typ.ptyp_loc |> Loc.end_ - |> Pos.position_to_offset type_str_for_parser - |> Option.get - in - (* The AST locations does not account for "=?" of optional arguments, so add that to the offset here if needed. *) - let end_offset = - match arg.lbl with - | Asttypes.Optional _ -> end_offset + 2 - | _ -> end_offset - in - extract_params next_function_expr - (params - @ [ - ( arg.lbl, - (* Remove the label prefix offset here, since we're not showing - that to the end user. *) - start_offset - label_prefix_len, - end_offset - label_prefix_len ); - ]) + extract_params ret params | _ -> params in extract_params expr [] diff --git a/analysis/src/xform.ml b/analysis/src/xform.ml index d5c59eba513..bb8fbcb04e3 100644 --- a/analysis/src/xform.ml +++ b/analysis/src/xform.ml @@ -261,7 +261,7 @@ module Add_braces_to_fn = struct | _ -> false in (match e.pexp_desc with - | Pexp_fun {rhs = body_expr} + | Pexp_fun {body = body_expr} when Loc.has_pos ~pos body_expr.pexp_loc && is_braced_expr body_expr = false && is_function body_expr = false -> @@ -303,18 +303,18 @@ module Add_type_annotation = struct result := Some (if is_unlabeled_only_arg then WithParens else Plain) | _ -> () in - let rec process_function ~arg_num (e : Parsetree.expression) = + let process_function (e : Parsetree.expression) = match e.pexp_desc with - | Pexp_fun {arg_label; lhs = pat; rhs = e} -> - let is_unlabeled_only_arg = - arg_num = 1 && arg_label = Nolabel - && - match e.pexp_desc with - | Pexp_fun _ -> false - | _ -> true + | Pexp_fun {params} -> + let single_param = + match params with + | [_] -> true + | _ -> false in - process_pattern ~is_unlabeled_only_arg pat; - process_function ~arg_num:(arg_num + 1) e + params + |> List.iter (fun ({p_lbl; p_pat} : Parsetree.fun_param) -> + let is_unlabeled_only_arg = single_param && p_lbl = Nolabel in + process_pattern ~is_unlabeled_only_arg p_pat) | _ -> () in let structure_item (iterator : Ast_iterator.iterator) @@ -327,7 +327,7 @@ module Add_type_annotation = struct if not is_jsx_component then process_pattern vb.pvb_pat; process_function vb.pvb_expr in - bindings |> List.iter (process_binding ~arg_num:1); + bindings |> List.iter process_binding; Ast_iterator.default_iterator.structure_item iterator si | _ -> Ast_iterator.default_iterator.structure_item iterator si in diff --git a/compiler/frontend/ast_compatible.ml b/compiler/frontend/ast_compatible.ml index 55a898b333c..8769bd1ab5d 100644 --- a/compiler/frontend/ast_compatible.ml +++ b/compiler/frontend/ast_compatible.ml @@ -73,18 +73,16 @@ let app2 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 : expression = }; } -let fun_ ?(loc = default_loc) ?(attrs = []) ?(async = false) ~arity pat exp = +let fun_ ?(loc = default_loc) ?(attrs = []) ?(async = false) pat exp = { pexp_loc = loc; pexp_attributes = attrs; pexp_desc = Pexp_fun { - arg_label = Nolabel; - default = None; - lhs = pat; - rhs = exp; - arity; + params = + [{p_attrs = []; p_lbl = Nolabel; p_default = None; p_pat = pat}]; + body = exp; async; }; } diff --git a/compiler/frontend/ast_compatible.mli b/compiler/frontend/ast_compatible.mli index eaf359e4a1e..42b33b188c4 100644 --- a/compiler/frontend/ast_compatible.mli +++ b/compiler/frontend/ast_compatible.mli @@ -59,7 +59,6 @@ val fun_ : ?loc:Location.t -> ?attrs:attrs -> ?async:bool -> - arity:int option -> pattern -> expression -> expression diff --git a/compiler/frontend/ast_core_type.ml b/compiler/frontend/ast_core_type.ml index cac1e1e2c18..b2f96ca4bac 100644 --- a/compiler/frontend/ast_core_type.ml +++ b/compiler/frontend/ast_core_type.ml @@ -97,7 +97,9 @@ let from_labels ~loc arity labels : t = Ext_list.map2 labels tyvars (fun label tyvar -> {Parsetree.attrs = []; lbl = Asttypes.Labelled label; typ = tyvar}) in - Typ.arrows ~loc args result_type + match args with + | [] -> result_type + | _ -> Typ.arrow ~loc args result_type let make_obj ~loc xs = Typ.object_ ~loc xs Closed @@ -108,40 +110,15 @@ let make_obj ~loc xs = Typ.object_ ~loc xs Closed {[ 'a -> ('a. 'a -> 'b) ]} *) -let rec get_uncurry_arity_aux (ty : t) acc = - match ty.ptyp_desc with - | Ptyp_arrow {ret = new_ty} -> get_uncurry_arity_aux new_ty (succ acc) - | Ptyp_poly (_, ty) -> get_uncurry_arity_aux ty acc - | _ -> acc - -(** - {[ unit -> 'b ]} return arity 1 - {[ unit -> 'a1 -> a2']} arity 2 - {[ 'a1 -> 'a2 -> ... 'aN -> 'b ]} return arity N -*) let get_curry_arity (ty : t) = match ty.ptyp_desc with - | Ptyp_arrow {arity = Some arity} -> arity - | _ -> get_uncurry_arity_aux ty 0 + | Ptyp_arrow {params} -> List.length params + | _ -> 0 let is_arity_one ty = get_curry_arity ty = 1 let list_of_arrow (ty : t) : t * Parsetree.arg list = - let rec aux (ty : t) acc = - match ty.ptyp_desc with - | Ptyp_arrow {arg; ret; arity} when arity = None || acc = [] -> - aux ret (arg :: acc) - | Ptyp_poly _ -> - (* unreachable: [list_of_arrow] only recurses into an arrow's return - (and is only ever called on an external's type annotation), so to get - here a [Ptyp_poly] would have to sit in an external's arg/return - position. The external type — and every arrow arg/return — is parsed - by [parse_typ_expr], which never routes to [parse_poly_type_expr]; an - inline `'a. …` there is a plain syntax error ("Did you forget a `=`"). - [Ptyp_poly] is produced only for record/object field types and - signature `val` descriptions, and a field-nested poly is a non-arrow - leaf that [list_of_arrow] stops at, never the recursed return. *) - assert false - | _ -> (ty, List.rev acc) - in - aux ty [] + match ty.ptyp_desc with + | Ptyp_arrow {params; ret} -> (ret, params) + | _ -> (ty, []) + diff --git a/compiler/frontend/ast_core_type_class_type.ml b/compiler/frontend/ast_core_type_class_type.ml index 4a4f1799d22..3f43e81d3f9 100644 --- a/compiler/frontend/ast_core_type_class_type.ml +++ b/compiler/frontend/ast_core_type_class_type.ml @@ -67,14 +67,18 @@ let default_typ_mapper = Bs_ast_mapper.default_mapper.typ let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) = let loc = ty.ptyp_loc in match ty.ptyp_desc with - | Ptyp_arrow {arity} + | Ptyp_arrow {params = _} (* let it go without regard label names, it will report error later when the label is not empty *) -> ( match fst (Ast_attributes.process_attributes_rev ty.ptyp_attributes) with - | Meth_callback _ -> - Ast_typ_uncurry.to_method_callback_type loc self ~arity ty + | Meth_callback _ -> ( + match ty.ptyp_desc with + | Ptyp_arrow {params} -> + Ast_typ_uncurry.to_method_callback_type loc self + ~arity:(List.length params) ty + | _ -> assert false) | Nothing -> Bs_ast_mapper.default_mapper.typ self ty) | Ptyp_object (methods, closed_flag) -> let ( +> ) attr (typ : Parsetree.core_type) = @@ -100,7 +104,7 @@ let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) = | Meth_callback attr, attrs -> (attrs, attr +> ty) in Ast_compatible.object_field name attrs - (Ast_helper.Typ.arrows ~loc + (Ast_helper.Typ.arrow ~loc [{attrs = []; lbl = Nolabel; typ = self.typ self core_type}] (Ast_literal.type_unit ~loc ())) in diff --git a/compiler/frontend/ast_derive_abstract.ml b/compiler/frontend/ast_derive_abstract.ml index b4521eb5371..9f11354b8e9 100644 --- a/compiler/frontend/ast_derive_abstract.ml +++ b/compiler/frontend/ast_derive_abstract.ml @@ -125,11 +125,11 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) : let accessor_type = if is_optional then let optional_type = Ast_core_type.lift_option_type pld_type in - Ast_helper.Typ.arrows ~loc + Ast_helper.Typ.arrow ~loc [{attrs = []; lbl = Nolabel; typ = core_type}] optional_type else - Ast_helper.Typ.arrows ~loc + Ast_helper.Typ.arrow ~loc [{attrs = []; lbl = Nolabel; typ = core_type}] pld_type in @@ -159,7 +159,7 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) : let acc = if pld_mutable = Mutable then let setter_type = - Ast_helper.Typ.arrows ~loc:pld_loc + Ast_helper.Typ.arrow ~loc:pld_loc [ ({attrs = []; lbl = Nolabel; typ = core_type} : Parsetree.arg); @@ -182,7 +182,7 @@ let handle_tdcl light (tdcl : Parsetree.type_declaration) : let make_type = match maker_args with | [] -> core_type - | args -> Ast_helper.Typ.arrows ~loc args core_type + | args -> Ast_helper.Typ.arrow ~loc args core_type in ( new_tdcl, if is_private then setter_accessor diff --git a/compiler/frontend/ast_derive_js_mapper.ml b/compiler/frontend/ast_derive_js_mapper.ml index ffb5dbd6eca..c46fc23b3aa 100644 --- a/compiler/frontend/ast_derive_js_mapper.ml +++ b/compiler/frontend/ast_derive_js_mapper.ml @@ -69,7 +69,7 @@ let erase_type_str = Str.primitive (Val.mk ~prim:["%identity"] {loc = noloc; txt = erase_type_lit} - (Ast_helper.Typ.arrows [{attrs = []; lbl = Nolabel; typ = any}] any)) + (Ast_helper.Typ.arrow [{attrs = []; lbl = Nolabel; typ = any}] any)) let unsafe_index = "_index" @@ -79,7 +79,7 @@ let unsafe_index_get = (Val.mk ~prim:[""] {loc = noloc; txt = unsafe_index} ~attrs:[Ast_attributes.get_index] - (Ast_helper.Typ.arrows + (Ast_helper.Typ.arrow [ {attrs = []; lbl = Nolabel; typ = any}; {attrs = []; lbl = Nolabel; typ = any}; @@ -135,7 +135,7 @@ let app1 = Ast_compatible.app1 let app2 = Ast_compatible.app2 -let ( ->~ ) a b = Ast_helper.Typ.arrows [{attrs = []; lbl = Nolabel; typ = a}] b +let ( ->~ ) a b = Ast_helper.Typ.arrow [{attrs = []; lbl = Nolabel; typ = a}] b let raise_when_not_found_ident = Longident.Ldot (Lident Primitive_modules.util, "raiseWhenNotFound") @@ -174,7 +174,7 @@ let init () = in let to_js_body body = Ast_comb.single_non_rec_value pat_to_js - (Ast_compatible.fun_ ~arity:(Some 1) + (Ast_compatible.fun_ (Pat.constraint_ (Pat.var pat_param) core_type) body) in @@ -226,7 +226,7 @@ let init () = in let from_js = Ast_comb.single_non_rec_value pat_from_js - (Ast_compatible.fun_ ~arity:(Some 1) (Pat.var pat_param) + (Ast_compatible.fun_ (Pat.var pat_param) (if create_type then Exp.let_ Nonrecursive [Vb.mk (Pat.var pat_param) (exp_param +: new_type)] @@ -268,7 +268,7 @@ let init () = app2 unsafe_index_get_exp exp_map exp_param else app1 erase_type_exp exp_param); Ast_comb.single_non_rec_value pat_from_js - (Ast_compatible.fun_ ~arity:(Some 1) (Pat.var pat_param) + (Ast_compatible.fun_ (Pat.var pat_param) (let result = app2 unsafe_index_get_exp rev_exp_map exp_param in @@ -300,7 +300,7 @@ let init () = let pat_from_js = {Asttypes.loc; txt = from_js} in let to_js_type result = Ast_comb.single_non_rec_val pat_to_js - (Ast_helper.Typ.arrows + (Ast_helper.Typ.arrow [{attrs = []; lbl = Nolabel; typ = core_type}] result) in diff --git a/compiler/frontend/ast_derive_projector.ml b/compiler/frontend/ast_derive_projector.ml index 3d2c7d19620..abfe8209398 100644 --- a/compiler/frontend/ast_derive_projector.ml +++ b/compiler/frontend/ast_derive_projector.ml @@ -20,11 +20,6 @@ let init () = { structure_gen = (fun (tdcls : tdcls) _explict_nonrec -> - let handle_uncurried_accessor_tranform ~arity accessor = - (* Accessors with no params (arity of 0) are simply values and not functions *) - if arity > 0 then Ast_uncurried.uncurried_fun ~arity accessor - else accessor - in let handle_tdcl tdcl = let core_type = Ast_derive_util.core_type_of_type_declaration tdcl @@ -47,7 +42,7 @@ let init () = let txt = "param" in Ast_comb.single_non_rec_value ?attrs:gentype_attrs pld_name (* arity will always be 1 since these are single param functions *) - (Ast_compatible.fun_ ~arity:(Some 1) + (Ast_compatible.fun_ (Pat.constraint_ (Pat.var {txt; loc}) core_type) (Exp.field (Exp.ident {txt = Lident txt; loc}) @@ -106,11 +101,11 @@ let init () = Exp.ident {loc; txt = Lident x})))) annotate_type in - Ext_list.fold_right vars exp (fun var b -> - Ast_compatible.fun_ ~arity:None - (Pat.var {loc; txt = var}) - b) - |> handle_uncurried_accessor_tranform ~arity)) + Ast_helper.Exp.fun_ + (Ext_list.map vars (fun var -> + Ast_helper.Exp.fun_param Nolabel + (Pat.var {loc; txt = var}))) + exp)) | Ptype_abstract | Ptype_open -> Ast_derive_util.not_applicable tdcl.ptype_loc deriving_name; [] @@ -135,7 +130,7 @@ let init () = | Ptype_record label_declarations -> Ext_list.map label_declarations (fun {pld_name; pld_type} -> Ast_comb.single_non_rec_val ?attrs:gentype_attrs pld_name - (Ast_helper.Typ.arrows + (Ast_helper.Typ.arrow [{attrs = []; lbl = Nolabel; typ = core_type}] pld_type (*arity will alwys be 1 since these are single param functions*))) @@ -162,12 +157,15 @@ let init () = in Ast_comb.single_non_rec_val ?attrs:gentype_attrs {loc; txt = Ext_string.uncapitalize_ascii con_name} - (let args = + (match Ext_list.map pcd_args (fun x -> ({attrs = []; lbl = Nolabel; typ = x} : Parsetree.arg)) - in - Ast_helper.Typ.arrows ~loc args annotate_type)) + with + | [] -> + (* zero-argument constructor: the accessor is a value *) + annotate_type + | args -> Ast_helper.Typ.arrow ~loc args annotate_type)) | Ptype_open | Ptype_abstract -> Ast_derive_util.not_applicable tdcl.ptype_loc deriving_name; [] diff --git a/compiler/frontend/ast_exp_handle_external.ml b/compiler/frontend/ast_exp_handle_external.ml index 375d5e98bc0..bb1875a7f55 100644 --- a/compiler/frontend/ast_exp_handle_external.ml +++ b/compiler/frontend/ast_exp_handle_external.ml @@ -27,7 +27,7 @@ let handle_debugger loc (payload : Ast_payload.t) = | PStr [] -> Ast_external_mk.local_external_apply loc ~pval_prim:["%debugger"] ~pval_type: - (Ast_helper.Typ.arrows + (Ast_helper.Typ.arrow [{attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}] (Ast_literal.type_unit ())) [Ast_literal.val_unit ~loc ()] @@ -54,7 +54,7 @@ let handle_raw ~kind loc payload = pexp_desc = Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"] ~pval_type: - (Ast_helper.Typ.arrows + (Ast_helper.Typ.arrow [{attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}] (Ast_helper.Typ.any ())) [exp]; @@ -87,7 +87,7 @@ let handle_ffi ~loc ~payload = Ext_list.init effective_arity (fun _ -> ({attrs = []; lbl = Nolabel; typ = any} : Parsetree.arg)) in - Ast_helper.Typ.arrows ~loc args any + Ast_helper.Typ.arrow ~loc args any in match !is_function with | Some arity -> Ast_helper.Exp.constraint_ ~loc e (arrow ~arity) @@ -99,7 +99,7 @@ let handle_ffi ~loc ~payload = pexp_desc = Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_expr"] ~pval_type: - (Ast_helper.Typ.arrows + (Ast_helper.Typ.arrow [{attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}] (Ast_helper.Typ.any ())) [exp]; @@ -118,7 +118,7 @@ let handle_raw_structure loc payload = pexp_desc = Ast_external_mk.local_external_apply loc ~pval_prim:["#raw_stmt"] ~pval_type: - (Ast_helper.Typ.arrows + (Ast_helper.Typ.arrow [{attrs = []; lbl = Nolabel; typ = Ast_helper.Typ.any ()}] (Ast_helper.Typ.any ())) [exp]; diff --git a/compiler/frontend/ast_external_process.ml b/compiler/frontend/ast_external_process.ml index ab9831756dd..4291de8a047 100644 --- a/compiler/frontend/ast_external_process.ml +++ b/compiler/frontend/ast_external_process.ml @@ -593,7 +593,9 @@ let process_obj (loc : Location.t) (st : external_desc) (prim_name : string) in ( List.length args, - Ast_helper.Typ.arrows ~loc args result, + (match args with + | [] -> result + | _ -> Ast_helper.Typ.arrow ~loc args result), External_ffi_types.ffi_obj_create arg_kinds ) | _ -> Location.raise_errorf ~loc "Attribute found that conflicts with %@obj" @@ -906,14 +908,6 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type) (prim_attributes : Ast_attributes.t) (prim_name : string) : Parsetree.core_type * External_ffi_types.t * Parsetree.attributes * bool = let prim_name_with_source = {name = prim_name; source = External} in - let type_annotation, build_uncurried_type = - match type_annotation with - | {ptyp_desc = Ptyp_arrow {arity = Some _}} -> - ( type_annotation, - fun ~arity (x : Parsetree.core_type) -> - Ast_uncurried.uncurried_type ~arity x ) - | _ -> (type_annotation, fun ~arity:_ x -> x) - in let result_type, arg_types_ty = (* Note this assumes external type is syntatic (no abstraction)*) Ast_core_type.list_of_arrow type_annotation @@ -925,10 +919,10 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type) in if external_desc.mk_obj then (* warn unused attributes here ? *) - let arity, new_type, spec = + let _arity, new_type, spec = process_obj loc external_desc prim_name arg_types_ty result_type in - (build_uncurried_type ~arity new_type, spec, unused_attrs, false) + (new_type, spec, unused_attrs, false) else let splice = external_desc.splice in let arg_type_specs, args, arg_type_specs_length = @@ -1016,7 +1010,9 @@ let handle_attributes (loc : Bs_loc.t) (type_annotation : Parsetree.core_type) let return_wrapper = check_return_wrapper loc external_desc.return_wrapper result_type in - ( Ast_helper.Typ.arrows ~loc args result_type, + ( (match args with + | [] -> result_type + | _ -> Ast_helper.Typ.arrow ~loc args result_type), External_ffi_types.ffi_bs arg_type_specs return_wrapper ffi, unused_attrs, relative ) diff --git a/compiler/frontend/ast_pat.ml b/compiler/frontend/ast_pat.ml index 7cea97c972f..6bf3b4803db 100644 --- a/compiler/frontend/ast_pat.ml +++ b/compiler/frontend/ast_pat.ml @@ -24,9 +24,9 @@ type t = Parsetree.pattern -let rec labels_of_fun (e : Parsetree.expression) = +let labels_of_fun (e : Parsetree.expression) = match e.pexp_desc with - | Pexp_fun {arg_label = l; rhs = e} -> l :: labels_of_fun e + | Pexp_fun {params} -> List.map (fun {Parsetree.p_lbl} -> p_lbl) params | _ -> [] let rec is_single_variable_pattern_conservative (p : t) = diff --git a/compiler/frontend/ast_typ_uncurry.ml b/compiler/frontend/ast_typ_uncurry.ml index 275b5eff49f..f3d6f083b4c 100644 --- a/compiler/frontend/ast_typ_uncurry.ml +++ b/compiler/frontend/ast_typ_uncurry.ml @@ -27,12 +27,9 @@ type typ = Parsetree.core_type let to_method_callback_type loc (mapper : Bs_ast_mapper.mapper) ~arity (meth_type : Parsetree.core_type) = let meth_type = Bs_ast_mapper.default_mapper.typ mapper meth_type in - match arity with - | Some n -> - Ast_helper.Typ.constr - { - txt = Ldot (Ast_literal.Lid.method_callback, "arity" ^ string_of_int n); - loc; - } - [meth_type] - | None -> assert false + Ast_helper.Typ.constr + { + txt = Ldot (Ast_literal.Lid.method_callback, "arity" ^ string_of_int arity); + loc; + } + [meth_type] diff --git a/compiler/frontend/ast_typ_uncurry.mli b/compiler/frontend/ast_typ_uncurry.mli index 63bb4cf7881..5dcb092a69c 100644 --- a/compiler/frontend/ast_typ_uncurry.mli +++ b/compiler/frontend/ast_typ_uncurry.mli @@ -30,7 +30,7 @@ type typ = Parsetree.core_type val to_method_callback_type : Ast_helper.loc -> Bs_ast_mapper.mapper -> - arity:int option -> + arity:int -> typ -> (* Method type *) typ diff --git a/compiler/frontend/ast_uncurry_gen.ml b/compiler/frontend/ast_uncurry_gen.ml index 5d80377668c..217cc313d27 100644 --- a/compiler/frontend/ast_uncurry_gen.ml +++ b/compiler/frontend/ast_uncurry_gen.ml @@ -25,64 +25,64 @@ open Ast_helper (* Handling `fun [@this]` used in `object [@bs] end` *) -let to_method_callback ~async loc (self : Bs_ast_mapper.mapper) label - (self_pat : Parsetree.pattern) body : Parsetree.expression_desc = - let self_pat = self.pat self self_pat in - (match Ast_pat.is_single_variable_pattern_conservative self_pat with - | None -> Bs_syntaxerr.err self_pat.ppat_loc Bs_this_simple_pattern - | Some self -> Stack.push self Js_config.self_stack); - Bs_syntaxerr.optional_err loc label; - let rec aux acc (body : Parsetree.expression) = - match Ast_attributes.process_attributes_rev body.pexp_attributes with - | Nothing, attrs -> ( - match body.pexp_desc with - | Pexp_fun {arg_label; lhs = arg; rhs = body; async} -> - Bs_syntaxerr.optional_err loc arg_label; - aux ((arg_label, self.pat self arg, attrs, async) :: acc) body - | _ -> (self.expr self body, acc)) - | _, _ -> (self.expr self body, acc) - in - let result, rev_extra_args = aux [(label, self_pat, [], false)] body in - let body = - Ext_list.fold_left rev_extra_args result (fun e (label, p, attrs, async) -> - Ast_helper.Exp.fun_ ~loc ~attrs ~arity:None ~async label None p e) - in - let arity = List.length rev_extra_args in - let body = - match body.pexp_desc with - | Pexp_fun f -> +let to_method_callback ~async loc (self : Bs_ast_mapper.mapper) + (params : Parsetree.fun_param list) body : Parsetree.expression_desc = + match params with + | [] -> assert false + | {p_lbl = label; p_pat = self_pat} :: rest -> + let self_pat = self.pat self self_pat in + (match Ast_pat.is_single_variable_pattern_conservative self_pat with + | None -> Bs_syntaxerr.err self_pat.ppat_loc Bs_this_simple_pattern + | Some self -> Stack.push self Js_config.self_stack); + Bs_syntaxerr.optional_err loc label; + let rest = + Ext_list.map rest (fun (p : Parsetree.fun_param) -> + Bs_syntaxerr.optional_err loc p.p_lbl; + {p with p_pat = self.pat self p.p_pat}) + in + let mapped_params = + { + Parsetree.p_attrs = []; + p_lbl = label; + p_default = None; + p_pat = self_pat; + } + :: rest + in + let result = self.expr self body in + let arity = List.length mapped_params in + let body = Ast_async.make_function_async ~async - {body with pexp_desc = Pexp_fun {f with arity = Some arity; async}} - | _ -> body - in - let arity_s = string_of_int arity in - Stack.pop Js_config.self_stack |> ignore; - Parsetree.Pexp_apply - { - funct = - Exp.ident ~loc - {loc; txt = Ldot (Ast_literal.Lid.js_extern, "unsafe_to_method")}; - args = - [ - ( Nolabel, - Exp.constraint_ ~loc - (Exp.record ~loc - [ + (Ast_helper.Exp.fun_ ~loc ~async mapped_params result) + in + let arity_s = string_of_int arity in + Stack.pop Js_config.self_stack |> ignore; + Parsetree.Pexp_apply + { + funct = + Exp.ident ~loc + {loc; txt = Ldot (Ast_literal.Lid.js_extern, "unsafe_to_method")}; + args = + [ + ( Nolabel, + Exp.constraint_ ~loc + (Exp.record ~loc + [ + { + lid = {loc; txt = Ast_literal.Lid.hidden_field arity_s}; + x = body; + opt = false; + }; + ] + None) + (Typ.constr ~loc { - lid = {loc; txt = Ast_literal.Lid.hidden_field arity_s}; - x = body; - opt = false; - }; - ] - None) - (Typ.constr ~loc - { - loc; - txt = - Ldot (Ast_literal.Lid.method_callback, "arity" ^ arity_s); - } - [Typ.any ~loc ()]) ); - ]; - partial = false; - transformed_jsx = false; - } + loc; + txt = + Ldot (Ast_literal.Lid.method_callback, "arity" ^ arity_s); + } + [Typ.any ~loc ()]) ); + ]; + partial = false; + transformed_jsx = false; + } diff --git a/compiler/frontend/ast_uncurry_gen.mli b/compiler/frontend/ast_uncurry_gen.mli index cdaebeb26fa..2e7ea41c8fd 100644 --- a/compiler/frontend/ast_uncurry_gen.mli +++ b/compiler/frontend/ast_uncurry_gen.mli @@ -26,8 +26,7 @@ val to_method_callback : async:bool -> Location.t -> Bs_ast_mapper.mapper -> - Asttypes.arg_label -> - Parsetree.pattern -> + Parsetree.fun_param list -> Parsetree.expression -> Parsetree.expression_desc (** syntax: diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml index 332ac5b57a2..9edf483334c 100644 --- a/compiler/frontend/bs_ast_mapper.ml +++ b/compiler/frontend/bs_ast_mapper.ml @@ -99,9 +99,11 @@ module T = struct match desc with | Ptyp_any -> Typ.any ~loc ~attrs () | Ptyp_var s -> Typ.var ~loc ~attrs s - | Ptyp_arrow {arg; ret; arity} -> - Typ.arrow ~loc ~attrs ~arity - {arg with typ = sub.typ sub arg.typ} + | Ptyp_arrow {params; ret} -> + Typ.arrow ~loc ~attrs + (List.map + (fun (arg : Parsetree.arg) -> {arg with typ = sub.typ sub arg.typ}) + params) (sub.typ sub ret) | Ptyp_tuple tyl -> Typ.tuple ~loc ~attrs (List.map (sub.typ sub) tyl) | Ptyp_constr (lid, tl) -> @@ -323,11 +325,17 @@ module E = struct sub vbs) (sub.expr sub e) (* #end *) - | Pexp_fun {arg_label = lab; default = def; lhs = p; rhs = e; arity; async} - -> - fun_ ~loc ~attrs ~arity ~async lab - (map_opt (sub.expr sub) def) - (sub.pat sub p) (sub.expr sub e) + | Pexp_fun {params; body; async} -> + fun_ ~loc ~attrs ~async + (List.map + (fun (param : Parsetree.fun_param) -> + { + param with + p_default = map_opt (sub.expr sub) param.p_default; + p_pat = sub.pat sub param.p_pat; + }) + params) + (sub.expr sub body) | Pexp_apply {funct = e; args = l; partial; transformed_jsx} -> apply ~loc ~attrs ~partial ~transformed_jsx (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) diff --git a/compiler/frontend/bs_builtin_ppx.ml b/compiler/frontend/bs_builtin_ppx.ml index 40e9ff79bfb..16d78630b42 100644 --- a/compiler/frontend/bs_builtin_ppx.ml +++ b/compiler/frontend/bs_builtin_ppx.ml @@ -95,33 +95,29 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) | Pexp_newtype (s, body) -> let res = self.expr self body in {e with pexp_desc = Pexp_newtype (s, res)} - | Pexp_fun {arg_label = label; lhs = pat; rhs = body; async; arity; default} - -> ( + | Pexp_fun {params; body; async} -> ( match Ast_attributes.process_attributes_rev e.pexp_attributes with | Nothing, _ -> (* Handle @async x => y => ... is in async context *) async_context := (old_in_function_def && !async_context) || async; - (* The default mapper would descend into nested [Pexp_fun] nodes (used for - additional parameters) before visiting the function body. Those - nested calls see [async = false] and would reset [async_context] to - false, so by the time we translate the body we incorrectly think we are - outside of an async function. This shows up with function-level - [@directive] (GH #7974): the directive attribute lives on the outer - async lambda, while extra parameters are represented as nested - functions. Rebuild the function manually to keep the async flag alive - until the body is processed. *) let attrs = self.attributes self e.pexp_attributes in - let default = Option.map (self.expr self) default in - let lhs = self.pat self pat in + let params = + Ext_list.map params (fun (p : Parsetree.fun_param) -> + { + p with + p_default = Option.map (self.expr self) p.p_default; + p_pat = self.pat self p.p_pat; + }) + in let saved_in_function_def = !in_function_def in in_function_def := true; - (* Keep reporting nested parameters as part of a function definition so - they propagate async context exactly like the original mapper. *) - let rhs = self.expr self body in + (* Keep reporting the body as part of a function definition so nested + functions propagate async context exactly like the legacy curried + mapper did (GH #7974). *) + let body = self.expr self body in in_function_def := saved_in_function_def; let mapped = - Ast_helper.Exp.fun_ ~loc:e.pexp_loc ~attrs ~arity ~async label default - lhs rhs + Ast_helper.Exp.fun_ ~loc:e.pexp_loc ~attrs ~async params body in Ast_async.make_function_async ~async mapped | Meth_callback _, pexp_attributes -> @@ -130,8 +126,7 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) { e with pexp_desc = - Ast_uncurry_gen.to_method_callback ~async e.pexp_loc self label pat - body; + Ast_uncurry_gen.to_method_callback ~async e.pexp_loc self params body; pexp_attributes; }) | Pexp_apply _ -> Ast_exp_apply.app_exp_mapper e self @@ -737,7 +732,7 @@ let rec structure_mapper ~await_context (self : mapper) (stru : Ast_structure.t) | Pexp_ifthenelse (_, then_expr, Some else_expr) -> aux then_expr @ aux else_expr | Pexp_construct (_, Some expr) -> aux expr - | Pexp_fun {rhs = expr} | Pexp_newtype (_, expr) -> aux expr + | Pexp_fun {body = expr} | Pexp_newtype (_, expr) -> aux expr | Pexp_constraint (expr, _) -> aux expr | Pexp_match (expr, cases) -> let case_results = diff --git a/compiler/ml/ast_async.ml b/compiler/ml/ast_async.ml index d5494ebfba0..1281ed0298e 100644 --- a/compiler/ml/ast_async.ml +++ b/compiler/ml/ast_async.ml @@ -1,7 +1,14 @@ -let rec dig_async_payload_from_function (expr : Parsetree.expression) = +let dig_async_payload_from_function (expr : Parsetree.expression) = match expr.pexp_desc with | Pexp_fun {async} -> async - | Pexp_newtype (_, body) -> dig_async_payload_from_function body + | Pexp_newtype _ -> + let rec dig (e : Parsetree.expression) = + match e.pexp_desc with + | Pexp_newtype (_, body) -> dig body + | Pexp_fun {async} -> async + | _ -> false + in + dig expr | _ -> false let add_promise_type ?(loc = Location.none) ~async @@ -14,16 +21,17 @@ let add_promise_type ?(loc = Location.none) ~async Ast_helper.Exp.apply ~loc unsafe_async [(Nolabel, result)] else result -let rec add_promise_to_result ~loc (e : Parsetree.expression) = +let add_promise_to_result ~loc (e : Parsetree.expression) = match e.pexp_desc with | Pexp_fun f -> - let rhs = add_promise_to_result ~loc f.rhs in - {e with pexp_desc = Pexp_fun {f with rhs}} + let body = add_promise_type ~loc ~async:true f.body in + {e with pexp_desc = Pexp_fun {f with body}} | _ -> add_promise_type ~loc ~async:true e let make_function_async ~async (e : Parsetree.expression) = if async then match e.pexp_desc with - | Pexp_fun {lhs = {ppat_loc}} -> add_promise_to_result ~loc:ppat_loc e + | Pexp_fun {params = {p_pat = {ppat_loc}} :: _} -> + add_promise_to_result ~loc:ppat_loc e | _ -> assert false else e diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index da26d2ba637..ed29a89a785 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -54,17 +54,9 @@ module Typ = struct let any ?loc ?attrs () = mk ?loc ?attrs Ptyp_any let var ?loc ?attrs a = mk ?loc ?attrs (Ptyp_var a) - let arrow ?loc ?attrs ~arity arg ret = - mk ?loc ?attrs (Ptyp_arrow {arg; ret; arity}) - let arrows ?loc ?attrs args ret = - let arity = Some (List.length args) in - let rec build_arrows arity_to_use = function - | [] -> ret - | [arg] -> arrow ?loc ?attrs ~arity:arity_to_use arg ret - | arg :: rest -> - arrow ?loc ?attrs ~arity:arity_to_use arg (build_arrows None rest) - in - build_arrows arity args + let arrow ?loc ?attrs params ret = + assert (params <> []); + mk ?loc ?attrs (Ptyp_arrow {params; ret}) let tuple ?loc ?attrs a = mk ?loc ?attrs (Ptyp_tuple a) let constr ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_constr (a, b)) let object_ ?loc ?attrs a b = mk ?loc ?attrs (Ptyp_object (a, b)) @@ -91,9 +83,15 @@ module Typ = struct | Ptyp_var x -> check_variable var_names t.ptyp_loc x; Ptyp_var x - | Ptyp_arrow ({arg; ret} as arr) -> + | Ptyp_arrow {params; ret} -> Ptyp_arrow - {arr with arg = {arr.arg with typ = loop arg.typ}; ret = loop ret} + { + params = + List.map + (fun (arg : Parsetree.arg) -> {arg with typ = loop arg.typ}) + params; + ret = loop ret; + } | Ptyp_tuple lst -> Ptyp_tuple (List.map loop lst) | Ptyp_constr ({txt = Longident.Lident s}, []) when List.mem s var_names -> @@ -160,9 +158,12 @@ module Exp = struct let ident ?loc ?attrs a = mk ?loc ?attrs (Pexp_ident a) let constant ?loc ?attrs a = mk ?loc ?attrs (Pexp_constant a) let let_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_let (a, b, c)) - let fun_ ?loc ?attrs ?(async = false) ~arity a b c d = - mk ?loc ?attrs - (Pexp_fun {arg_label = a; default = b; lhs = c; rhs = d; arity; async}) + let fun_ ?loc ?attrs ?(async = false) params body = + assert (params <> []); + mk ?loc ?attrs (Pexp_fun {params; body; async}) + + let fun_param ?(attrs = []) ?default lbl pat = + {p_attrs = attrs; p_lbl = lbl; p_default = default; p_pat = pat} let apply ?loc ?attrs ?(partial = false) ?(transformed_jsx = false) funct args = mk ?loc ?attrs (Pexp_apply {funct; args; partial; transformed_jsx}) diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index ed16a6f9d12..789b3d669ae 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -54,9 +54,9 @@ module Typ : sig val any : ?loc:loc -> ?attrs:attrs -> unit -> core_type val var : ?loc:loc -> ?attrs:attrs -> string -> core_type - val arrow : - ?loc:loc -> ?attrs:attrs -> arity:arity -> arg -> core_type -> core_type - val arrows : ?loc:loc -> ?attrs:attrs -> arg list -> core_type -> core_type + + (* n-ary arrow type; the params list must be non-empty *) + val arrow : ?loc:loc -> ?attrs:attrs -> arg list -> core_type -> core_type val tuple : ?loc:loc -> ?attrs:attrs -> core_type list -> core_type val constr : ?loc:loc -> ?attrs:attrs -> lid -> core_type list -> core_type val object_ : @@ -134,12 +134,12 @@ module Exp : sig ?loc:loc -> ?attrs:attrs -> ?async:bool -> - arity:int option -> - arg_label -> - expression option -> - pattern -> + fun_param list -> expression -> expression + + val fun_param : + ?attrs:attrs -> ?default:expression -> arg_label -> pattern -> fun_param val apply : ?loc:loc -> ?attrs:attrs -> diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index f1421d518e7..80bd5b78cba 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -96,8 +96,8 @@ module T = struct sub.attributes sub attrs; match desc with | Ptyp_any | Ptyp_var _ -> () - | Ptyp_arrow {arg; ret} -> - sub.typ sub arg.typ; + | Ptyp_arrow {params; ret} -> + List.iter (fun (arg : Parsetree.arg) -> sub.typ sub arg.typ) params; sub.typ sub ret | Ptyp_tuple tyl -> List.iter (sub.typ sub) tyl | Ptyp_constr (lid, tl) -> @@ -289,10 +289,13 @@ module E = struct | Pexp_let (_r, vbs, e) -> List.iter (sub.value_binding sub) vbs; sub.expr sub e - | Pexp_fun {default = def; lhs = p; rhs = e} -> - iter_opt (sub.expr sub) def; - sub.pat sub p; - sub.expr sub e + | Pexp_fun {params; body} -> + List.iter + (fun {p_default; p_pat} -> + iter_opt (sub.expr sub) p_default; + sub.pat sub p_pat) + params; + sub.expr sub body | Pexp_apply {funct = e; args = l} -> sub.expr sub e; List.iter (iter_snd (sub.expr sub)) l diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index a07a7cfdd74..415c0765d36 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -91,9 +91,11 @@ module T = struct match desc with | Ptyp_any -> Typ.any ~loc ~attrs () | Ptyp_var s -> Typ.var ~loc ~attrs s - | Ptyp_arrow {arg; ret; arity} -> - Typ.arrow ~loc ~attrs ~arity - {arg with typ = sub.typ sub arg.typ} + | Ptyp_arrow {params; ret} -> + Typ.arrow ~loc ~attrs + (List.map + (fun (arg : Parsetree.arg) -> {arg with typ = sub.typ sub arg.typ}) + params) (sub.typ sub ret) | Ptyp_tuple tyl -> Typ.tuple ~loc ~attrs (List.map (sub.typ sub) tyl) | Ptyp_constr (lid, tl) -> @@ -286,11 +288,17 @@ module E = struct | Pexp_constant x -> constant ~loc ~attrs x | Pexp_let (r, vbs, e) -> let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e) - | Pexp_fun {arg_label = lab; default = def; lhs = p; rhs = e; arity; async} - -> - fun_ ~loc ~attrs ~arity ~async lab - (map_opt (sub.expr sub) def) - (sub.pat sub p) (sub.expr sub e) + | Pexp_fun {params; body; async} -> + fun_ ~loc ~attrs ~async + (List.map + (fun param -> + { + param with + p_default = map_opt (sub.expr sub) param.p_default; + p_pat = sub.pat sub param.p_pat; + }) + params) + (sub.expr sub body) | Pexp_apply {funct = e; args = l; partial; transformed_jsx} -> apply ~loc ~attrs ~partial ~transformed_jsx (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 3f15aa17ee5..2c87f14d8ab 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -157,8 +157,8 @@ module T = struct | Some (node_attrs, arg_attrs) -> (node_attrs, arg_attrs) | None -> ([], attrs) in - Typ.arrow ~loc ~attrs:node_attrs ~arity:None - {attrs = arg_attrs; lbl; typ = sub.typ sub t1} + Typ.arrow ~loc ~attrs:node_attrs + [{attrs = arg_attrs; lbl; typ = sub.typ sub t1}] (sub.typ sub t2) | Ptyp_tuple tyl -> Typ.tuple ~loc ~attrs (List.map (sub.typ sub) tyl) | Ptyp_constr (lid, tl) -> ( @@ -166,8 +166,8 @@ module T = struct Typ.constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) in match typ0.ptyp_desc with - | Ptyp_constr (lid, [({ptyp_desc = Ptyp_arrow arr} as fun_t); t_arity]) - when lid.txt = Lident "function$" -> + | Ptyp_constr (lid, [({ptyp_desc = Ptyp_arrow _} as fun_t); t_arity]) + when lid.txt = Lident "function$" -> ( let decode_arity_string arity_s = int_of_string ((String.sub [@doesNotRaise]) arity_s 9 (String.length arity_s - 9)) @@ -179,7 +179,26 @@ module T = struct | _ -> assert false in let arity = arity_from_type t_arity in - {fun_t with ptyp_desc = Ptyp_arrow {arr with arity = Some arity}} + (* Gather [arity] parameters from the converted chain of unary + arrows into one n-ary node. Nested first-class function types + are left intact: gathering stops once [arity] parameters have + been collected (or the chain runs out, for PPX-mangled input). *) + let rec gather ~is_head n acc (t : Parsetree.core_type) = + if n <= 0 then (List.rev acc, t) + else + match t.ptyp_desc with + | Ptyp_arrow {params; ret} + when List.length params <= n && (is_head || t.ptyp_attributes = []) + -> + gather ~is_head:false + (n - List.length params) + (List.rev_append params acc) + ret + | _ -> (List.rev acc, t) + in + match gather ~is_head:true arity [] fun_t with + | [], _ -> fun_t + | params, ret -> {fun_t with ptyp_desc = Ptyp_arrow {params; ret}}) | _ -> typ0) | Ptyp_object (l, o) -> Typ.object_ ~loc ~attrs (List.map (object_field sub) l) o @@ -503,15 +522,26 @@ module E = struct | Pexp_let (r, vbs, e) -> let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e) | Pexp_fun (lab, def, p, e) -> + (* A bare (non-Function$-wrapped) v0 fun becomes a one-parameter + function; [Function$] decoding below gathers chains of these into + one n-ary node. The v0 node's attributes are the parameter's + attributes (that is where the old parser kept them). *) let lab = Asttypes.to_arg_label lab in let async = Ext_list.exists attrs (fun ({txt}, _) -> txt = "res.async") in (* [res.async] is bridge metadata added by [Ast_mapper_to0]; it is decoded into the [async] flag and must not survive as a real attribute. *) let attrs = attrs |> List.filter (fun ({txt}, _) -> txt <> "res.async") in - fun_ ~loc ~attrs ~async ~arity:None lab - (map_opt (sub.expr sub) def) - (sub.pat sub p) (sub.expr sub e) + fun_ ~loc ~async + [ + { + p_attrs = attrs; + p_lbl = lab; + p_default = map_opt (sub.expr sub) def; + p_pat = sub.pat sub p; + }; + ] + (sub.expr sub e) | Pexp_function cases -> (* The current parsetree has no [function] construct; it can only come from an external PPX emitting OCaml-style [function | p -> e]. @@ -523,7 +553,9 @@ module E = struct ident ~loc (Location.mkloc (Longident.Lident param) loc) in let body = match_ ~loc scrutinee (sub.cases sub cases) in - fun_ ~loc ~attrs ~async:false ~arity:None Nolabel None pat body + fun_ ~loc ~attrs + [{p_attrs = []; p_lbl = Nolabel; p_default = None; p_pat = pat}] + body | Pexp_apply ({pexp_desc = Pexp_ident tag_name}, args) when has_jsx_attribute () -> ( let attrs = attrs |> List.filter (fun ({txt}, _) -> txt <> "JSX") in @@ -633,9 +665,39 @@ module E = struct | [] -> assert false in match arg1 with - | Some ({pexp_desc = Pexp_fun f} as e1) -> - let arity = Some (attributes_to_arity attrs) in - {e1 with pexp_desc = Pexp_fun {f with arity}} + | Some ({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 + left intact: gathering stops once [arity] parameters have been + collected (or the chain shape breaks, for PPX-mangled input). *) + let rec gather ~is_head n acc (e : Parsetree.expression) = + if n <= 0 then (List.rev acc, e) + else + match e.pexp_desc with + | Pexp_fun {params; body; async = inner_async} + when List.length params <= n + && (is_head || (e.pexp_attributes = [] && not inner_async)) + -> + gather ~is_head:false + (n - List.length params) + (List.rev_append params acc) + body + | _ -> (List.rev acc, e) + in + match gather ~is_head:true arity [] e1 with + | [], _ -> e1 + | params, body -> + (* The construct node's other attributes become the function + node's attributes rather than being dropped. *) + let node_attrs = + attrs |> List.filter (fun ({txt}, _) -> txt <> "res.arity") + in + { + e1 with + pexp_desc = Pexp_fun {params; body; async = f.async}; + pexp_attributes = e1.pexp_attributes @ node_attrs; + }) | _ -> exp1) | _ -> exp1) | Pexp_variant (lab, eo) -> diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 18a3cdc9fe1..d9b4abb175b 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -122,37 +122,48 @@ module T = struct match desc with | Ptyp_any -> any ~loc ~attrs () | Ptyp_var s -> var ~loc ~attrs s - | Ptyp_arrow {arg; ret; arity} -> ( - let lbl = Asttypes.to_noloc arg.lbl in - (* v0 arrows have a single attribute slot for what the current parsetree + | Ptyp_arrow {params; ret} -> + (* Re-curry the n-ary arrow into the v0 chain of unary arrows, and wrap + the head in function$(_, [#Has_arityN]). + + v0 arrows have a single attribute slot for what the current parsetree splits into node attributes and argument attributes. Keep the split recoverable: when node attributes are present, separate the two lists with an internal marker that [Ast_mapper_from0] strips again. Without node attributes (the common case) the encoding is unchanged. *) - let arg_attrs = sub.attributes sub arg.attrs in - let merged_attrs = - if attrs = [] then arg_attrs - else - attrs - @ ({txt = "_res.arrow_node_attrs"; loc = Location.none}, Pt.PStr []) - :: arg_attrs + let arity = List.length params in + let rec build (params : Parsetree.arg list) = + match params with + | [] -> sub.typ sub ret + | (arg : Parsetree.arg) :: rest -> + let lbl = Asttypes.to_noloc arg.lbl in + let arg_attrs = sub.attributes sub arg.attrs in + let is_head = List.length rest = arity - 1 in + let merged_attrs = + if is_head && attrs <> [] then + attrs + @ ( {txt = "_res.arrow_node_attrs"; loc = Location.none}, + Pt.PStr [] ) + :: arg_attrs + else arg_attrs + in + let arrow_loc = + if is_head then loc + else {loc with loc_start = arg.typ.ptyp_loc.loc_start} + in + arrow ~loc:arrow_loc ~attrs:merged_attrs lbl (sub.typ sub arg.typ) + (build rest) in - let typ0 = - arrow ~loc ~attrs:merged_attrs lbl (sub.typ sub arg.typ) - (sub.typ sub ret) + let typ0 = build params in + let arity_string = "Has_arity" ^ string_of_int arity in + let arity_type = + Ast_helper0.Typ.variant ~loc + [Rtag (Location.mknoloc arity_string, [], true, [])] + Closed None in - match arity with - | None -> typ0 - | Some arity -> - let arity_string = "Has_arity" ^ string_of_int arity in - let arity_type = - Ast_helper0.Typ.variant ~loc - [Rtag (Location.mknoloc arity_string, [], true, [])] - Closed None - in - Ast_helper0.Typ.constr ~loc - {txt = Lident "function$"; loc} - [typ0; arity_type]) + Ast_helper0.Typ.constr ~loc + {txt = Lident "function$"; loc} + [typ0; arity_type] | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) | Ptyp_constr (lid, tl) -> constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) @@ -394,37 +405,49 @@ module E = struct | Pexp_constant x -> constant ~loc ~attrs (map_constant x) | Pexp_let (r, vbs, e) -> let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) (sub.expr sub e) - | Pexp_fun {arg_label = lab; default = def; lhs = p; rhs = e; arity; async} - -> ( - let lab = Asttypes.to_noloc lab in - let attrs = - if async then - ({txt = "res.async"; loc = Location.none}, Pt.PStr []) :: attrs - else attrs + | Pexp_fun {params; body; async} -> + (* Re-curry the n-ary function into the v0 chain of unary funs, and + wrap it in Function$ carrying the arity as a res.arity attribute. + Each v0 fun node carries its parameter's attributes; the head + additionally carries the function node's own attributes (and the + res.async marker), matching what the old parser produced. *) + let arity = List.length params in + let rec build (params : Parsetree.fun_param list) = + match params with + | [] -> sub.expr sub body + | {p_attrs; p_lbl; p_default; p_pat} :: rest -> + let lab = Asttypes.to_noloc p_lbl in + let is_head = List.length rest = arity - 1 in + let level_attrs = + let param_attrs = sub.attributes sub p_attrs in + if is_head then + let base = attrs @ param_attrs in + if async then + ({txt = "res.async"; loc = Location.none}, Pt.PStr []) :: base + else base + else param_attrs + in + let fun_loc = + if is_head then loc + else {loc with loc_start = p_pat.ppat_loc.loc_start} + in + fun_ ~loc:fun_loc ~attrs:level_attrs lab + (map_opt (sub.expr sub) p_default) + (sub.pat sub p_pat) (build rest) in - let e = - fun_ ~loc ~attrs lab - (map_opt (sub.expr sub) def) - (sub.pat sub p) (sub.expr sub e) + let e = build params in + let arity_attr = + ( Location.mknoloc "res.arity", + Parsetree0.PStr + [ + Ast_helper0.Str.eval + (Ast_helper0.Exp.constant + (Pconst_integer (string_of_int arity, None))); + ] ) in - match arity with - | None -> e - | Some arity -> - let arity_to_attributes arity = - [ - ( Location.mknoloc "res.arity", - Parsetree0.PStr - [ - Ast_helper0.Str.eval - (Ast_helper0.Exp.constant - (Pconst_integer (string_of_int arity, None))); - ] ); - ] - in - Ast_helper0.Exp.construct - ~attrs:(arity_to_attributes arity) - (Location.mkloc (Longident.Lident "Function$") e.pexp_loc) - (Some e)) + Ast_helper0.Exp.construct ~attrs:[arity_attr] + (Location.mkloc (Longident.Lident "Function$") e.pexp_loc) + (Some e) | Pexp_apply {funct = e; args; partial} -> let e = match (e.pexp_desc, args) with diff --git a/compiler/ml/ast_uncurried.ml b/compiler/ml/ast_uncurried.ml deleted file mode 100644 index 3cd794e404b..00000000000 --- a/compiler/ml/ast_uncurried.ml +++ /dev/null @@ -1,21 +0,0 @@ -(* Uncurried AST *) - -let uncurried_type ~arity (t_arg : Parsetree.core_type) = - match t_arg.ptyp_desc with - | Ptyp_arrow arr -> - {t_arg with ptyp_desc = Ptyp_arrow {arr with arity = Some arity}} - | _ -> assert false - -let uncurried_fun ?(async = false) ~arity fun_expr = - let fun_expr = - match fun_expr.Parsetree.pexp_desc with - | Pexp_fun f -> - {fun_expr with pexp_desc = Pexp_fun {f with arity = Some arity; async}} - | _ -> assert false - in - fun_expr - -let expr_is_uncurried_fun (expr : Parsetree.expression) = - match expr.pexp_desc with - | Pexp_fun {arity = Some _} -> true - | _ -> false diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index efa9c71721a..4ebf8950d1b 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -99,8 +99,8 @@ let rec add_type bv ty = match ty.ptyp_desc with | Ptyp_any -> () | Ptyp_var _ -> () - | Ptyp_arrow {arg; ret} -> - add_type bv arg.typ; + | Ptyp_arrow {params; ret} -> + List.iter (fun arg -> add_type bv arg.typ) params; add_type bv ret | Ptyp_tuple tl -> List.iter (add_type bv) tl | Ptyp_constr (c, tl) -> @@ -212,9 +212,15 @@ let rec add_expr bv exp = | Pexp_let (rf, pel, e) -> let bv = add_bindings rf bv pel in add_expr bv e - | Pexp_fun {default = opte; lhs = p; rhs = e} -> - add_opt add_expr bv opte; - add_expr (add_pattern bv p) e + | Pexp_fun {params; body} -> + let bv = + List.fold_left + (fun bv {p_default; p_pat} -> + add_opt add_expr bv p_default; + add_pattern bv p_pat) + bv params + in + add_expr bv body | Pexp_apply {funct = e; args = el} -> add_expr bv e; List.iter (fun (_, e) -> add_expr bv e) el diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index 0f852f40706..8a24070102e 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -78,11 +78,11 @@ and arg = {attrs: attributes; lbl: arg_label; typ: core_type} and core_type_desc = | Ptyp_any (* _ *) | Ptyp_var of string (* 'a *) - | Ptyp_arrow of {arg: arg; ret: core_type; arity: arity} - (* T1 -> T2 Simple - ~l:T1 -> T2 Labelled - ?l:T1 -> T2 Optional - *) + | Ptyp_arrow of {params: arg list; ret: core_type} + (* (T1, ~l:T2, ?l:T3) => T n-ary uncurried function type. + The function's arity is [List.length params]; a function returning + another function is a nested [Ptyp_arrow] in [ret]. + Invariant: params <> [] (a zero-argument function takes [unit]). *) | Ptyp_tuple of core_type list (* T1 * ... * Tn @@ -232,24 +232,15 @@ and expression_desc = (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) *) - | Pexp_fun of { - arg_label: arg_label; - default: expression option; - lhs: pattern; - rhs: expression; - arity: arity; - async: bool; - } - (* fun P -> E1 (Simple, None) - fun ~l:P -> E1 (Labelled l, None) - fun ?l:P -> E1 (Optional l, None) - fun ?l:(P = E0) -> E1 (Optional l, Some E0) + | Pexp_fun of {params: fun_param list; body: expression; async: bool} + (* (P1, ~l:P2, ?l:P3=E0) => E n-ary uncurried function. + The function's arity is [List.length params]; a function returning + another function is a nested [Pexp_fun] in [body]. Notes: - - If E0 is provided, only Optional is allowed. - - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. + - A default expression is only allowed on Optional parameters. - "let f P = E" is represented using Pexp_fun. - *) + - Invariant: params <> [] (a zero-argument function takes [unit]). *) | Pexp_apply of { funct: expression; args: (arg_label * expression) list; @@ -408,6 +399,13 @@ and case = { pc_rhs: expression; } +and fun_param = { + p_attrs: attributes; + p_lbl: arg_label; + p_default: expression option; (* ~l=E0 default; only for Optional labels *) + p_pat: pattern; +} + (* Value descriptions *) and value_description = { pval_name: string loc; diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml index f3ba343e9f7..c98a43ef6e4 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -301,12 +301,16 @@ and core_type ctxt f x = (attributes ctxt) x.ptyp_attributes else match x.ptyp_desc with - | Ptyp_arrow {arg; ret; arity} -> - pp f "@[<2>%a@;->@;%a%s@]" (* FIXME remove parens later *) - (type_with_label ctxt) arg (core_type ctxt) ret - (match arity with - | None -> "" - | Some n -> " (a:" ^ string_of_int n ^ ")") + | Ptyp_arrow {params; ret} -> + (* printed in the legacy curried style, with the arity trailing *) + let rec args f = function + | [] -> () + | arg :: rest -> + pp f "%a@;->@;" (type_with_label ctxt) arg; + args f rest + in + pp f "@[<2>%a%a (a:%d)@]" args params (core_type ctxt) ret + (List.length params) | Ptyp_alias (ct, s) -> pp f "@[<2>%a@;as@;'%s@]" (core_type1 ctxt) ct s | Ptyp_poly ([], ct) -> core_type ctxt f ct | Ptyp_poly (sl, ct) -> @@ -623,15 +627,17 @@ and expression ctxt f x = | (Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _) when ctxt.semi -> paren true (expression reset_ctxt) f x - | Pexp_fun {arg_label = l; default = e0; lhs = p; rhs = e; arity; async} -> - let arity_str = - match arity with - | None -> "" - | Some arity -> "[arity:" ^ string_of_int arity ^ "]" - in + | Pexp_fun {params; body; async} -> + let arity_str = "[arity:" ^ string_of_int (List.length params) ^ "]" in let async_str = if async then "async " else "" in - pp f "@[<2>%sfun@;%s%a->@;%a@]" async_str arity_str (label_exp ctxt) - (l, e0, p) (expression ctxt) e + let rec pp_params f = function + | [] -> () + | {p_lbl; p_default; p_pat} :: rest -> + pp f "%a" (label_exp ctxt) (p_lbl, p_default, p_pat); + pp_params f rest + in + pp f "@[<2>%sfun@;%s%a->@;%a@]" async_str arity_str pp_params params + (expression ctxt) body | Pexp_match (e, l) -> pp f "@[@[@[<2>match %a@]@ with@]%a@]" (expression reset_ctxt) e (case_list ctxt) l @@ -1056,20 +1062,21 @@ and binding ctxt f {pvb_pat = p; pvb_expr = x; _} = if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x else match x.pexp_desc with - | Pexp_fun - {arg_label = label; default = eo; lhs = p; rhs = e; arity; async} -> - let arity_str = - match arity with - | None -> "" - | Some arity -> "[arity:" ^ string_of_int arity ^ "]" - in + | Pexp_fun {params; body; async} -> + let arity_str = "[arity:" ^ string_of_int (List.length params) ^ "]" in let async_str = if async then "async " else "" in - if label = Nolabel then - pp f "%s%s%a@ %a" async_str arity_str (simple_pattern ctxt) p - pp_print_pexp_function e - else - pp f "%s%s%a@ %a" async_str arity_str (label_exp ctxt) (label, eo, p) - pp_print_pexp_function e + let pp_param f {p_lbl; p_default; p_pat} = + if p_lbl = Nolabel then simple_pattern ctxt f p_pat + else label_exp ctxt f (p_lbl, p_default, p_pat) + in + let rec pp_params f = function + | [] -> () + | param :: rest -> + pp f "%a@ " pp_param param; + pp_params f rest + in + pp f "%s%s%a%a" async_str arity_str pp_params params + pp_print_pexp_function body | Pexp_newtype (str, e) -> pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e | _ -> pp f "=@;%a" (expression ctxt) x diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index 4c99c77e433..3d78c884183 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -131,15 +131,15 @@ let rec core_type i ppf x = match x.ptyp_desc with | Ptyp_any -> line i ppf "Ptyp_any\n" | Ptyp_var s -> line i ppf "Ptyp_var %s\n" s - | Ptyp_arrow {arg; ret; arity} -> + | Ptyp_arrow {params; ret} -> line i ppf "Ptyp_arrow\n"; - let () = - match arity with - | None -> () - | Some n -> line i ppf "arity = %d\n" n - in - arg_label_loc i ppf arg.lbl; - core_type i ppf arg.typ; + line i ppf "arity = %d\n" (List.length params); + List.iter + (fun (arg : Parsetree.arg) -> + arg_label_loc i ppf arg.lbl; + attributes i ppf arg.attrs; + core_type i ppf arg.typ) + params; core_type i ppf ret | Ptyp_tuple l -> line i ppf "Ptyp_tuple\n"; @@ -249,18 +249,18 @@ and expression i ppf x = line i ppf "Pexp_let %a\n" fmt_rec_flag rf; list i value_binding ppf l; expression i ppf e - | Pexp_fun {arg_label = l; default = eo; lhs = p; rhs = e; arity; async} -> + | Pexp_fun {params; body; async} -> line i ppf "Pexp_fun\n"; let () = if async then line i ppf "async\n" in - let () = - match arity with - | None -> () - | Some arity -> line i ppf "arity:%d\n" arity - in - arg_label_loc i ppf l; - option i expression ppf eo; - pattern i ppf p; - expression i ppf e + line i ppf "arity:%d\n" (List.length params); + List.iter + (fun {p_attrs; p_lbl; p_default; p_pat} -> + attributes i ppf p_attrs; + arg_label_loc i ppf p_lbl; + option i expression ppf p_default; + pattern i ppf p_pat) + params; + expression i ppf body | Pexp_apply {funct = e; args = l; partial; transformed_jsx} -> line i ppf "Pexp_apply\n"; if partial then line i ppf "partial\n"; diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index a6fc704bd48..6252b13e62a 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -165,9 +165,9 @@ let iter_expression f e = | Pexp_extension _ (* we don't iterate under extension point *) | Pexp_ident _ | Pexp_constant _ -> () - | Pexp_fun {default = eo; rhs = e} -> - may expr eo; - expr e + | Pexp_fun {params; body} -> + List.iter (fun {p_default} -> may expr p_default) params; + expr body | Pexp_apply {funct = e; args = lel} -> expr e; List.iter (fun (_, e) -> expr e) lel @@ -1971,9 +1971,21 @@ and is_nonexpansive_opt = function let rec approx_type env sty = match sty.ptyp_desc with - | Ptyp_arrow {arg = {lbl = p}; ret = sty; arity} -> - let ty1 = if is_optional p then type_option (newvar ()) else newvar () in - newty (Tarrow ({lbl = p; typ = ty1}, approx_type env sty, arity)) + | Ptyp_arrow {params; ret = sty} -> + let arity = Some (List.length params) in + let rec build n = function + | [] -> approx_type env sty + | ({lbl = p} : Parsetree.arg) :: rest -> + let ty1 = + if is_optional p then type_option (newvar ()) else newvar () + in + newty + (Tarrow + ( {lbl = p; typ = ty1}, + build (n + 1) rest, + if n = 0 then arity else None )) + in + build 0 params | Ptyp_tuple args -> newty (Ttuple (List.map (approx_type env) args)) | Ptyp_constr (lid, ctl) -> ( try @@ -1989,9 +2001,21 @@ let rec approx_type env sty = let rec type_approx env sexp = match sexp.pexp_desc with | Pexp_let (_, _, e) -> type_approx env e - | Pexp_fun {arg_label = p; rhs = e; arity} -> - let ty = if is_optional p then type_option (newvar ()) else newvar () in - newty (Tarrow ({lbl = p; typ = ty}, type_approx env e, arity)) + | Pexp_fun {params; body} -> + let arity = Some (List.length params) in + let rec build n = function + | [] -> type_approx env body + | {p_lbl} :: rest -> + let ty = + if is_optional p_lbl then type_option (newvar ()) else newvar () + in + newty + (Tarrow + ( {lbl = p_lbl; typ = ty}, + build (n + 1) rest, + if n = 0 then arity else None )) + in + build 0 params | Pexp_match (_, {pc_rhs = e} :: _) -> type_approx env e | Pexp_try (e, _) -> type_approx env e | Pexp_tuple l -> newty (Ttuple (List.map (type_approx env) l)) @@ -2449,61 +2473,90 @@ and type_expect_ ?deprecated_context ~context ?in_function ?(recarg = Rejected) exp_attributes = sexp.pexp_attributes; exp_env = env; } - | Pexp_fun - { - arg_label = l; - default = Some default; - lhs = spat; - rhs = sbody; - arity; - async; - } -> - assert (is_optional l); - (* default allowed only with optional argument *) - let open Ast_helper in - let default_loc = default.pexp_loc in - let scases = - [ - Exp.case - (Pat.construct ~loc:default_loc - (mknoloc Longident.(Ldot (Lident "*predef*", "Some"))) - (Some (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 - let sloc = - { - Location.loc_start = spat.ppat_loc.Location.loc_start; - loc_end = default_loc.Location.loc_end; - loc_ghost = true; - } - in - let smatch = - Exp.match_ ~loc:sloc - ~attrs:[(mknoloc "#optional_arg_default", PStr [])] - (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*"))) - scases - in - let pat = Pat.var ~loc:sloc (mknoloc "*opt*") in - let body = - Exp.let_ ~loc Nonrecursive - ~attrs:[(mknoloc "#default", PStr [])] - [Vb.mk spat smatch] - sbody + | Pexp_fun {params; body = sfun_body; async} -> ( + (* Peel one parameter at a time, reproducing the legacy curried typing: + the head parameter carries [Some arity] (the full parameter count), + the synthesized rest-functions carry [None]. Rest-functions are + marked with an internal attribute consumed right here, so it never + appears in user ASTs or in the typedtree. *) + let is_rest, node_attrs = + let rec split acc = function + | ({Location.txt = "#res.fun_rest"}, _) :: rest -> + (true, List.rev_append acc rest) + | a :: rest -> split (a :: acc) rest + | [] -> (false, List.rev acc) + in + split [] sexp.pexp_attributes in - type_function ?in_function ~arity ~async loc sexp.pexp_attributes env - ty_expected l - [Exp.case pat body] - | Pexp_fun - {arg_label = l; default = None; lhs = spat; rhs = sbody; arity; async} -> - type_function ?in_function ~arity ~async loc sexp.pexp_attributes env - ty_expected l - [Ast_helper.Exp.case spat sbody] + let arity = if is_rest then None else Some (List.length params) in + match params with + | [] -> assert false + | {p_attrs; p_lbl = l; p_default; p_pat = spat} :: rest_params -> ( + let level_attrs = node_attrs @ p_attrs in + let sbody = + match rest_params with + | [] -> sfun_body + | {p_pat = next_pat} :: _ -> + let rest_loc = + { + sexp.pexp_loc with + Location.loc_start = next_pat.ppat_loc.Location.loc_start; + } + in + { + pexp_desc = + Pexp_fun {params = rest_params; body = sfun_body; async = false}; + pexp_loc = rest_loc; + pexp_attributes = [(mknoloc "#res.fun_rest", PStr [])]; + } + in + match p_default with + | Some default -> + assert (is_optional l); + (* default allowed only with optional argument *) + let open Ast_helper in + let default_loc = default.pexp_loc in + let scases = + [ + Exp.case + (Pat.construct ~loc:default_loc + (mknoloc Longident.(Ldot (Lident "*predef*", "Some"))) + (Some (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 + let sloc = + { + Location.loc_start = spat.ppat_loc.Location.loc_start; + loc_end = default_loc.Location.loc_end; + loc_ghost = true; + } + in + let smatch = + Exp.match_ ~loc:sloc + ~attrs:[(mknoloc "#optional_arg_default", PStr [])] + (Exp.ident ~loc (mknoloc (Longident.Lident "*opt*"))) + scases + in + let pat = Pat.var ~loc:sloc (mknoloc "*opt*") in + let body = + Exp.let_ ~loc Nonrecursive + ~attrs:[(mknoloc "#default", PStr [])] + [Vb.mk spat smatch] + sbody + in + type_function ?in_function ~arity ~async loc level_attrs env ty_expected + l + [Exp.case pat body] + | None -> + type_function ?in_function ~arity ~async loc level_attrs env ty_expected + l + [Ast_helper.Exp.case spat sbody])) | Pexp_apply {funct = sfunct; args = sargs; partial; transformed_jsx} -> assert (sargs <> []); begin_def (); diff --git a/compiler/ml/typetexp.ml b/compiler/ml/typetexp.ml index 17c7c8274b9..aef3195a0a9 100644 --- a/compiler/ml/typetexp.ml +++ b/compiler/ml/typetexp.ml @@ -304,18 +304,40 @@ and transl_type_aux env policy styp = v) in ctyp (Ttyp_var name) ty - | Ptyp_arrow {arg; ret; arity} -> - let lbl = arg.lbl in - let cty1 = transl_type env policy arg.typ in + | Ptyp_arrow {params; ret} -> + (* The n-ary arrow is translated to the (still curried) [Tarrow] chain: + the head arrow carries [Some arity], inner arrows carry [None]. *) + let arity = List.length params in + let cparams = + List.map + (fun (arg : Parsetree.arg) -> + let cty = transl_type env policy arg.typ in + let ty = + if Btype.is_optional arg.lbl then + newty (Tconstr (Predef.path_option, [cty.ctyp_type], ref Mnil)) + else cty.ctyp_type + in + (arg, cty, ty)) + params + in let cty2 = transl_type env policy ret in - let ty1 = cty1.ctyp_type in - let ty1 = - if Btype.is_optional lbl then - newty (Tconstr (Predef.path_option, [ty1], ref Mnil)) - else ty1 + let rec fold n = function + | [] -> cty2 + | ((arg : Parsetree.arg), cty1, ty1) :: rest -> + let arrow_arity = if n = 0 then Some arity else None in + let ret_cty = fold (n + 1) rest in + let ty = + newty + (Tarrow ({lbl = arg.lbl; typ = ty1}, ret_cty.ctyp_type, arrow_arity)) + in + ctyp + (Ttyp_arrow + ( {attrs = arg.attrs; lbl = arg.lbl; typ = cty1}, + ret_cty, + arrow_arity )) + ty in - let ty = newty (Tarrow ({lbl; typ = ty1}, cty2.ctyp_type, arity)) in - ctyp (Ttyp_arrow ({attrs = arg.attrs; lbl; typ = cty1}, cty2, arity)) ty + fold 0 cparams | Ptyp_tuple stl -> assert (List.length stl >= 2); let ctys = List.map (transl_type env policy) stl in diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index dfbefe65f07..f678c56cff7 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -241,12 +241,28 @@ let make_props_record_type_sig ~core_type_of_attr ~external_ let rec recursively_transform_named_args_for_make expr args newtypes core_type = match expr.pexp_desc with + | Pexp_fun {params; body} -> + transform_params_for_make ~expr ~body params args newtypes core_type + | Pexp_newtype (label, expression) -> + recursively_transform_named_args_for_make expression args + (label :: newtypes) core_type + | Pexp_constraint (expression, core_type) -> + recursively_transform_named_args_for_make expression args newtypes + (Some core_type) + | _ -> (args, newtypes, core_type) + +and transform_params_for_make ~expr ~body params args newtypes core_type = + match params with + | [] -> + (* all parameters of this function consumed: keep walking into the body, + as the legacy chain walk did *) + recursively_transform_named_args_for_make body args newtypes core_type (* TODO: make this show up with a loc. *) - | Pexp_fun {arg_label = Labelled {txt = "key"} | Optional {txt = "key"}} -> + | {p_lbl = Labelled {txt = "key"} | Optional {txt = "key"}} :: _ -> Jsx_common.raise_error ~loc:expr.pexp_loc "Key cannot be accessed inside of a component. Don't worry - you can \ always key a component from its parent!" - | Pexp_fun {arg_label = arg; default; lhs = pattern; rhs = expression} + | {p_lbl = arg; p_default = default; p_pat = pattern} :: rest when is_optional arg || is_labelled arg -> let () = match (is_optional arg, pattern, default) with @@ -289,24 +305,24 @@ let rec recursively_transform_named_args_for_make expr args newtypes core_type = | _ -> None in - recursively_transform_named_args_for_make expression + transform_params_for_make ~expr ~body rest ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) newtypes core_type - | Pexp_fun - { - arg_label = Nolabel; - lhs = {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}; - } -> + | { + p_lbl = Nolabel; + p_pat = {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}; + } + :: _ -> (args, newtypes, core_type) - | Pexp_fun - { - arg_label = Nolabel; - lhs = - { - ppat_desc = - Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _); - } as pattern; - } -> + | { + p_lbl = Nolabel; + p_pat = + { + ppat_desc = + Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _); + } as pattern; + } + :: _ -> if txt = "ref" then let type_ = match pattern with @@ -324,17 +340,11 @@ let rec recursively_transform_named_args_for_make expr args newtypes core_type = newtypes, core_type ) else (args, newtypes, core_type) - | Pexp_fun {arg_label = Nolabel; lhs = pattern} -> + | {p_lbl = Nolabel; p_pat = pattern} :: _ -> Location.raise_errorf ~loc:pattern.ppat_loc "React: react.component refs only support plain arguments and type \ annotations." - | Pexp_newtype (label, expression) -> - recursively_transform_named_args_for_make expression args - (label :: newtypes) core_type - | Pexp_constraint (expression, core_type) -> - recursively_transform_named_args_for_make expression args newtypes - (Some core_type) - | _ -> (args, newtypes, core_type) + | _ :: _ -> (args, newtypes, core_type) let arg_to_type types ((name, default, {ppat_attributes = attrs}, _alias, loc, type_) : @@ -418,38 +428,30 @@ let modified_binding ~binding_loc ~binding_pat_loc ~fn_name binding = (* TODO: there is a long-tail of unsupported features inside of blocks - Pexp_letmodule , Pexp_letexception , Pexp_ifthenelse *) let rec spelunk_for_fun_expression expression = match expression with - (* let make = (~prop) => ... with no final unit *) - | { - pexp_desc = - Pexp_fun - ({ - arg_label = Labelled _ | Optional _; - rhs = {pexp_desc = Pexp_fun _} as internal_expression; - } as f); - } -> - let wrap, has_forward_ref, exp = - spelunk_for_fun_expression internal_expression - in - ( wrap, - has_forward_ref, - {expression with pexp_desc = Pexp_fun {f with rhs = exp}} ) (* let make = (()) => ... *) (* let make = (_) => ... *) | { pexp_desc = Pexp_fun { - arg_label = Nolabel; - lhs = - {ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any}; + params = + { + p_lbl = Nolabel; + p_pat = + { + ppat_desc = Ppat_construct ({txt = Lident "()"}, _) | Ppat_any; + }; + } + :: _; }; } -> ((fun a -> a), false, expression) (* let make = (~prop) => ... *) - | {pexp_desc = Pexp_fun {arg_label = Labelled _ | Optional _}} -> + | {pexp_desc = Pexp_fun {params = {p_lbl = Labelled _ | Optional _} :: _}} + -> ((fun a -> a), false, expression) (* let make = (prop) => ... *) - | {pexp_desc = Pexp_fun {lhs = pattern}} -> + | {pexp_desc = Pexp_fun {params = {p_pat = pattern} :: _}} -> if !has_application then ((fun a -> a), false, expression) else Location.raise_errorf ~loc:pattern.ppat_loc @@ -544,10 +546,10 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name binding = Exp.constraint_ expr (jsx_element_type config ~loc:expr.pexp_loc) in match expr.pexp_desc with - | Pexp_fun ({rhs} as desc) -> + | Pexp_fun ({body} as desc) -> { expr with - pexp_desc = Pexp_fun {desc with rhs = constrain_jsx_return rhs}; + pexp_desc = Pexp_fun {desc with body = constrain_jsx_return body}; } | Pexp_newtype (param, inner) -> {expr with pexp_desc = Pexp_newtype (param, constrain_jsx_return inner)} @@ -627,17 +629,21 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name binding = (* let make = React.forwardRef({ let \"App" = (props, ref) => make({...props, ref: @optional (Stdlib.Nullable.toOption(ref))}) })*) - let total_arity = if has_forward_ref then 2 else 1 in - Exp.fun_ ~arity:(Some total_arity) Nolabel None - (match core_type_of_attr with - | None -> make_props_pattern named_type_list - | Some _ -> make_props_pattern typ_vars_of_core_type) - (if has_forward_ref then - Exp.fun_ ~arity:None Nolabel None - (Pat.var @@ Location.mknoloc "ref") - inner_expression - else inner_expression) - ~attrs:binding.pvb_expr.pexp_attributes + let props_param = + Exp.fun_param Nolabel + (match core_type_of_attr with + | None -> make_props_pattern named_type_list + | Some _ -> make_props_pattern typ_vars_of_core_type) + in + let params = + if has_forward_ref then + [ + props_param; + Exp.fun_param Nolabel (Pat.var @@ Location.mknoloc "ref"); + ] + else [props_param] + in + Exp.fun_ ~attrs:binding.pvb_expr.pexp_attributes params inner_expression in let full_expression = match full_module_name with @@ -675,19 +681,28 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name binding = returned_expression patterns_with_label patterns_with_nolabel expr | Pexp_constraint (expr, _) -> returned_expression patterns_with_label patterns_with_nolabel expr - | Pexp_fun - { - lhs = {ppat_desc = Ppat_construct ({txt = Lident "()"}, _)}; - rhs = expr; - } -> - (patterns_with_label, patterns_with_nolabel, expr) - | Pexp_fun - { - arg_label; - default; - lhs = {ppat_loc; ppat_desc} as pattern; - rhs = expr; - } -> ( + | Pexp_fun {params; body} -> + returned_expression_params patterns_with_label patterns_with_nolabel + params body + | _ -> (patterns_with_label, patterns_with_nolabel, expr) + and returned_expression_params patterns_with_label patterns_with_nolabel + params body = + match params with + | [] -> returned_expression patterns_with_label patterns_with_nolabel body + | {p_pat = {ppat_desc = Ppat_construct ({txt = Lident "()"}, _)}} :: rest + -> + let remainder = + match rest with + | [] -> body + | _ -> Ast_helper.Exp.fun_ rest body + in + (patterns_with_label, patterns_with_nolabel, remainder) + | { + p_lbl = arg_label; + p_default = default; + p_pat = {ppat_loc; ppat_desc} as pattern; + } + :: rest -> ( let pattern_without_constraint = strip_constraint_unpack pattern in (* If prop has the default value as Ident, it will get a build error @@ -705,7 +720,7 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name binding = | _ -> pattern_without_constraint in if is_labelled arg_label || is_optional arg_label then - returned_expression + returned_expression_params ({ lid = {loc = ppat_loc; txt = Lident (get_label arg_label)}; x = @@ -716,22 +731,22 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name binding = opt = is_optional arg_label; } :: patterns_with_label) - patterns_with_nolabel expr + patterns_with_nolabel rest body else (* Special case of nolabel arg "ref" in forwardRef fn *) (* let make = React.forwardRef(ref => body) *) match ppat_desc with | Ppat_var {txt} | Ppat_constraint ({ppat_desc = Ppat_var {txt}}, _) -> - returned_expression patterns_with_label + returned_expression_params patterns_with_label (( {loc = ppat_loc; txt = Lident txt}, {pattern with ppat_attributes = pattern.ppat_attributes}, true ) :: patterns_with_nolabel) - expr + rest body | _ -> - returned_expression patterns_with_label patterns_with_nolabel expr) - | _ -> (patterns_with_label, patterns_with_nolabel, expr) + returned_expression_params patterns_with_label patterns_with_nolabel + rest body) in let patterns_with_label, patterns_with_nolabel, expression = returned_expression [] [] expression @@ -744,17 +759,16 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name binding = in let expression = constrain_jsx_return expression in (* (ref) => expr *) - let expression = - List.fold_left - (fun expr (_, pattern, _opt) -> - let pattern = - match pattern.ppat_desc with - | Ppat_var {txt} when txt = "ref" -> - Pat.constraint_ pattern (ref_type Location.none) - | _ -> pattern - in - Exp.fun_ ~arity:None Nolabel None pattern expr) - expression patterns_with_nolabel + let nolabel_params = + patterns_with_nolabel + |> List.rev_map (fun (_, pattern, _opt) -> + let pattern = + match pattern.ppat_desc with + | Ppat_var {txt} when txt = "ref" -> + Pat.constraint_ pattern (ref_type Location.none) + | _ -> pattern + in + Exp.fun_param Nolabel pattern) in (* ({a, b, _}: props<'a, 'b>) *) let record_pattern = @@ -764,21 +778,22 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name binding = in let expression = (* Shape internal implementation to match wrapper: uncurried when using forwardRef. *) - let total_arity = if has_forward_ref then 2 else 1 in - Exp.fun_ ~arity:(Some total_arity) ~async:is_async Nolabel None - (Pat.constraint_ record_pattern - (Typ.constr ~loc:empty_loc - {txt = Lident "props"; loc = empty_loc} - (match core_type_of_attr with - | None -> - make_props_type_params ~strip_explicit_option:true - ~strip_explicit_nullable_of_ref:has_forward_ref - named_type_list - | Some _ -> ( - match typ_vars_of_core_type with - | [] -> [] - | _ -> [Typ.any ()])))) - expression + let props_param = + Exp.fun_param Nolabel + (Pat.constraint_ record_pattern + (Typ.constr ~loc:empty_loc + {txt = Lident "props"; loc = empty_loc} + (match core_type_of_attr with + | None -> + make_props_type_params ~strip_explicit_option:true + ~strip_explicit_nullable_of_ref:has_forward_ref + named_type_list + | Some _ -> ( + match typ_vars_of_core_type with + | [] -> [] + | _ -> [Typ.any ()])))) + in + Exp.fun_ ~async:is_async (props_param :: nolabel_params) expression in let expression = (* Add new tupes (type a,b,c) to make's definition *) @@ -823,18 +838,28 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name binding = (* Case when using React.forwardRef *) let rec check_invalid_forward_ref expr = match expr.pexp_desc with - | Pexp_fun {arg_label = Labelled _ | Optional _} -> - Location.raise_errorf ~loc:expr.pexp_loc - "Components using React.forwardRef cannot use \ - @react.componentWithProps. Use @react.component instead." - | Pexp_fun {arg_label = Nolabel; rhs = body} -> - check_invalid_forward_ref body + | Pexp_fun {params; body} -> + if + List.exists + (fun {p_lbl} -> + match p_lbl with + | Labelled _ | Optional _ -> true + | Nolabel -> false) + params + then + Location.raise_errorf ~loc:expr.pexp_loc + "Components using React.forwardRef cannot use \ + @react.componentWithProps. Use @react.component instead." + else check_invalid_forward_ref body | _ -> () in check_invalid_forward_ref func_expr; Pat.var {txt = "props"; loc} - | {pexp_desc = Pexp_fun {lhs = {ppat_desc = Ppat_constraint (_, typ)}}} - -> ( + | { + pexp_desc = + Pexp_fun + {params = {p_pat = {ppat_desc = Ppat_constraint (_, typ)}} :: _}; + } -> ( match typ with | {ptyp_desc = Ptyp_constr ({txt = Lident "props"}, args)} -> (* props<_> *) @@ -860,8 +885,9 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name binding = in let applied_expression = constrain_jsx_return applied_expression in let wrapper_expr = - Exp.fun_ ~arity:(Some 1) Nolabel None props_pattern - ~attrs:binding.pvb_expr.pexp_attributes applied_expression + Exp.fun_ ~attrs:binding.pvb_expr.pexp_attributes + [Exp.fun_param Nolabel props_pattern] + applied_expression in let internal_expression = Exp.let_ Nonrecursive @@ -896,15 +922,27 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name binding = new_binding ) else (None, binding, None) -let rec collect_prop_types types {ptyp_loc; ptyp_desc} = +let rec collect_prop_types types {ptyp_desc} = match ptyp_desc with - | Ptyp_arrow {arg; ret = {ptyp_desc = Ptyp_arrow _} as rest} - when is_labelled arg.lbl || is_optional arg.lbl -> - collect_prop_types ((arg.lbl, arg.attrs, ptyp_loc, arg.typ) :: types) rest - | Ptyp_arrow {arg = {lbl = Nolabel}; ret} -> collect_prop_types types ret - | Ptyp_arrow {arg; ret = return_value} - when is_labelled arg.lbl || is_optional arg.lbl -> - (arg.lbl, arg.attrs, return_value.ptyp_loc, arg.typ) :: types + | Ptyp_arrow {params; ret} -> + let ret_is_arrow = + match ret.ptyp_desc with + | Ptyp_arrow _ -> true + | _ -> false + in + let rec go types = function + | [] -> if ret_is_arrow then collect_prop_types types ret else types + | ({lbl; attrs; typ} : Parsetree.arg) :: rest + when is_labelled lbl || is_optional lbl -> + let loc = + match (rest, ret_is_arrow) with + | [], false -> ret.ptyp_loc + | _ -> typ.ptyp_loc + in + go ((lbl, attrs, loc, typ) :: types) rest + | _ :: rest -> go types rest + in + go types params | _ -> types let transform_structure_item ~config item = diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index ab18be2a1df..dbc5e70f35f 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -558,17 +558,24 @@ module Sexp_ast = struct Sexp.list (map_empty ~f:value_binding vbs); expression expr; ] - | Pexp_fun - {arg_label = arg_lbl; default = expr_opt; lhs = pat; rhs = expr} -> + | Pexp_fun {params; body} -> Sexp.list [ Sexp.atom "Pexp_fun"; - arg_label_loc arg_lbl; - (match expr_opt with - | None -> Sexp.atom "None" - | Some expr -> Sexp.list [Sexp.atom "Some"; expression expr]); - pattern pat; - expression expr; + Sexp.list + (map_empty + ~f:(fun {p_lbl; p_default; p_pat} -> + Sexp.list + [ + arg_label_loc p_lbl; + (match p_default with + | None -> Sexp.atom "None" + | Some expr -> + Sexp.list [Sexp.atom "Some"; expression expr]); + pattern p_pat; + ]) + params); + expression body; ] | Pexp_apply {funct = expr; args} -> Sexp.list @@ -897,12 +904,15 @@ module Sexp_ast = struct match typexpr.ptyp_desc with | Ptyp_any -> Sexp.atom "Ptyp_any" | Ptyp_var var -> Sexp.list [Sexp.atom "Ptyp_var"; string var] - | Ptyp_arrow {arg; ret} -> + | Ptyp_arrow {params; ret} -> Sexp.list [ Sexp.atom "Ptyp_arrow"; - arg_label_loc arg.lbl; - core_type arg.typ; + Sexp.list + (map_empty + ~f:(fun (p : Parsetree.arg) -> + Sexp.list [arg_label_loc p.lbl; core_type p.typ]) + params); core_type ret; ] | Ptyp_tuple types -> diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index 1d0a470e52a..81cfe3b971d 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -316,33 +316,10 @@ let rec collect_list_exprs acc expr = (* TODO: use ParsetreeViewer *) let arrow_type ct = let open Parsetree in - let rec process attrs_before acc typ = - match typ with - | { - ptyp_desc = Ptyp_arrow {arg = {lbl = Nolabel} as arg; ret}; - ptyp_attributes = []; - } -> - let arg = ([], arg.lbl, arg.typ) in - process attrs_before (arg :: acc) ret - | { - ptyp_desc = Ptyp_arrow {arg = {lbl = Nolabel} as arg; ret}; - ptyp_attributes = [({txt = "bs"}, _)] as attrs; - } -> - let arg = (attrs, arg.lbl, arg.typ) in - process attrs_before (arg :: acc) ret - | {ptyp_desc = Ptyp_arrow {arg = {lbl = Nolabel}}} as return_type -> - let args = List.rev acc in - (attrs_before, args, return_type) - | {ptyp_desc = Ptyp_arrow {arg; ret}; ptyp_attributes = attrs} -> - let arg = (attrs, arg.lbl, arg.typ) in - process attrs_before (arg :: acc) ret - | typ -> (attrs_before, List.rev acc, typ) - in match ct with - | {ptyp_desc = Ptyp_arrow {arg = {lbl = Nolabel}}; ptyp_attributes = attrs} as - typ -> - process attrs [] {typ with ptyp_attributes = []} - | typ -> process [] [] typ + | {ptyp_desc = Ptyp_arrow {params; ret}; ptyp_attributes = attrs} -> + (attrs, params |> List.map (fun (p : arg) -> (p.attrs, p.lbl, p.typ)), ret) + | typ -> ([], [], typ) (* TODO: avoiding the dependency on ParsetreeViewer here, is this a good idea? *) let mod_expr_apply mod_expr = @@ -408,63 +385,24 @@ let fun_expr expr = * | NewType(...) * This complicates printing with an extra variant/boxing/allocation for a code-path * that is not often used. Lets just keep it simple for now *) - let rec collect attrs_before acc expr = - match expr with - | { - pexp_desc = - Pexp_fun - { - arg_label = lbl; - default = default_expr; - lhs = pattern; - rhs = return_expr; - }; - pexp_attributes = []; - } -> - let parameter = ([], lbl, default_expr, pattern) in - collect attrs_before (parameter :: acc) return_expr - | {pexp_desc = Pexp_newtype (string_loc, rest); pexp_attributes = attrs} -> - let var, return_expr = collect_new_types [string_loc] rest in - let parameter = - ( attrs, - Asttypes.Nolabel, - None, - Ast_helper.Pat.var ~loc:string_loc.loc var ) - in - collect attrs_before (parameter :: acc) return_expr - | { - pexp_desc = - Pexp_fun - { - arg_label = lbl; - default = default_expr; - lhs = pattern; - rhs = return_expr; - }; - pexp_attributes = [({txt = "bs"}, _)] as attrs; - } -> - let parameter = (attrs, lbl, default_expr, pattern) in - collect attrs_before (parameter :: acc) return_expr - | { - pexp_desc = - Pexp_fun - { - arg_label = (Labelled _ | Optional _) as lbl; - default = default_expr; - lhs = pattern; - rhs = return_expr; - }; - pexp_attributes = attrs; - } -> - let parameter = (attrs, lbl, default_expr, pattern) in - collect attrs_before (parameter :: acc) return_expr - | expr -> (attrs_before, List.rev acc, expr) + let params_of params = + params + |> List.map (fun {p_attrs; p_lbl; p_default; p_pat} -> + (p_attrs, p_lbl, p_default, p_pat)) in match expr with - | {pexp_desc = Pexp_fun {arg_label = Nolabel}; pexp_attributes = attrs} as - expr -> - collect attrs [] {expr with pexp_attributes = []} - | expr -> collect [] [] expr + | {pexp_desc = Pexp_newtype (string_loc, rest); pexp_attributes = attrs} -> ( + let var, return_expr = collect_new_types [string_loc] rest in + let newtype_param = + (attrs, Asttypes.Nolabel, None, Ast_helper.Pat.var ~loc:string_loc.loc var) + in + match return_expr with + | {pexp_desc = Pexp_fun {params; body}} -> + ([], newtype_param :: params_of params, body) + | return_expr -> ([], [newtype_param], return_expr)) + | {pexp_desc = Pexp_fun {params; body}; pexp_attributes = attrs} -> + (attrs, params_of params, body) + | expr -> ([], [], expr) let rec is_block_expr expr = let open Parsetree in diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 4d0e319940b..6221d9ad1fa 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -676,7 +676,9 @@ let process_underscore_application args = (Ppat_var (Location.mkloc hidden_var loc)) ~loc:Location.none in - Ast_helper.Exp.fun_ ~loc ~arity:(Some 1) Nolabel None pattern exp_apply + Ast_helper.Exp.fun_ ~loc + [Ast_helper.Exp.fun_param Nolabel pattern] + exp_apply | None -> exp_apply in (args, wrap) @@ -1898,21 +1900,29 @@ and parse_es6_arrow_expression ?(arrow_attrs = []) ?(arrow_start_pos = None) Parser.eat_breadcrumb p; let end_pos = p.prev_end_pos in let type_param_opt, term_parameters = parameters in - let arrow_expr = - List.fold_right - (fun parameter expr -> - let {attrs; p_label = lbl; expr = default_expr; pat; p_pos = start_pos} - = - parameter - in - let loc = mk_loc start_pos end_pos in - Ast_helper.Exp.fun_ ~loc ~attrs ~arity:None lbl default_expr pat expr) - term_parameters body + (* In-parens attributes are already attached to the parameter patterns by + [parse_parameter]; the [attrs] field of a term parameter carries + arrow-level attributes (merged into the first parameter above), which + belong on the function node itself. *) + let fun_params = + List.map + (fun {p_label = lbl; expr = default_expr; pat} -> + { + Parsetree.p_attrs = []; + p_lbl = lbl; + p_default = default_expr; + p_pat = pat; + }) + term_parameters + in + let fun_attrs = List.concat_map (fun {attrs} -> attrs) term_parameters in + let loc = + match term_parameters with + | {p_pos = start_pos} :: _ -> mk_loc start_pos end_pos + | [] -> mk_loc start_pos end_pos in let arrow_expr = - Ast_uncurried.uncurried_fun - ~arity:(List.length term_parameters) - ~async arrow_expr + Ast_helper.Exp.fun_ ~loc ~attrs:fun_attrs ~async fun_params body in let arrow_expr = match type_param_opt with @@ -2694,7 +2704,7 @@ and over_parse_constrained_or_coerced_or_arrow_expression p expr = let arrow1 = Ast_helper.Exp.fun_ ~loc:(mk_loc expr.pexp_loc.loc_start body.pexp_loc.loc_end) - ~arity:None Asttypes.Nolabel None pat + [Ast_helper.Exp.fun_param Asttypes.Nolabel pat] (Ast_helper.Exp.constraint_ body typ) in (* When the "expr" was `()`, the colon must apply to the return type, so @@ -2704,8 +2714,10 @@ and over_parse_constrained_or_coerced_or_arrow_expression p expr = let arrow2 = Ast_helper.Exp.fun_ ~loc:(mk_loc expr.pexp_loc.loc_start body.pexp_loc.loc_end) - ~arity:None Asttypes.Nolabel None - (Ast_helper.Pat.constraint_ pat typ) + [ + Ast_helper.Exp.fun_param Asttypes.Nolabel + (Ast_helper.Pat.constraint_ pat typ); + ] body in let msg = @@ -4634,9 +4646,7 @@ and parse_poly_type_expr ?current_type_name_path ?inline_types_context p = let typ = Ast_helper.Typ.var ~loc:var.loc var.txt in let return_type = parse_typ_expr ~alias:false p in let loc = mk_loc typ.Parsetree.ptyp_loc.loc_start p.prev_end_pos in - Ast_helper.Typ.arrow ~loc ~arity:(Some 1) - {attrs = []; lbl = Nolabel; typ} - return_type + Ast_helper.Typ.arrow ~loc [{attrs = []; lbl = Nolabel; typ}] return_type | _ -> Ast_helper.Typ.var ~loc:var.loc var.txt) | _ -> assert false) | _ -> parse_typ_expr ?current_type_name_path ?inline_types_context p @@ -5059,9 +5069,9 @@ and parse_es6_arrow_type ?current_type_name_path ?inline_types_context ~attrs p arrow, exactly like its parenthesized form [(~x: t) => u]; it must carry the same arity or the two spellings produce types that print identically but do not unify. *) - Ast_helper.Typ.arrow ~loc ~arity:(Some 1) {attrs; lbl; typ} return_type + Ast_helper.Typ.arrow ~loc [{attrs; lbl; typ}] return_type | DocComment _ -> assert false - | _ -> + | _ -> ( let parameters = parse_type_parameters ?current_type_name_path ?inline_types_context p in @@ -5074,26 +5084,22 @@ and parse_es6_arrow_type ?current_type_name_path ?inline_types_context ~attrs p parse_typ_expr ~alias:false ?current_type_name_path:return_path ?inline_types_context p in - let end_pos = p.prev_end_pos in - let arity = List.length parameters in - let _paramNum, typ = - List.fold_right - (fun {attrs; label = arg_lbl; typ; start_pos} (param_num, t) -> - let loc = mk_loc start_pos end_pos in - let t_arg = - Ast_helper.Typ.arrow ~loc ~arity:None {attrs; lbl = arg_lbl; typ} t - in - if param_num = 1 then - (param_num - 1, Ast_uncurried.uncurried_type ~arity t_arg) - else (param_num - 1, t_arg)) + let params = + List.map + (fun {attrs; label = arg_lbl; typ; start_pos = _} -> + {Parsetree.attrs; lbl = arg_lbl; typ}) parameters - (List.length parameters, return_type) in - { - typ with - ptyp_attributes = List.concat [typ.ptyp_attributes; attrs]; - ptyp_loc = mk_loc start_pos p.prev_end_pos; - } + let loc = mk_loc start_pos p.prev_end_pos in + match params with + | [] -> + (* can happen in error recovery *) + { + return_type with + ptyp_attributes = List.concat [return_type.ptyp_attributes; attrs]; + ptyp_loc = loc; + } + | _ -> Ast_helper.Typ.arrow ~loc ~attrs params return_type) (* * typexpr ::= @@ -5156,9 +5162,7 @@ and parse_arrow_type_rest ?current_type_name_path ?inline_types_context ?inline_types_context p in let loc = mk_loc start_pos p.prev_end_pos in - Ast_helper.Typ.arrow ~loc ~arity:(Some 1) - {attrs = []; lbl = Nolabel; typ} - return_type + Ast_helper.Typ.arrow ~loc [{attrs = []; lbl = Nolabel; typ}] return_type | _ -> typ and parse_typ_expr_region p = @@ -5934,8 +5938,8 @@ and parse_type_equation_or_constr_decl p = let return_type = parse_typ_expr ~alias:false p in let loc = mk_loc uident_start_pos p.prev_end_pos in let arrow_type = - Ast_helper.Typ.arrow ~loc ~arity:(Some 1) - {attrs = []; lbl = Nolabel; typ} + Ast_helper.Typ.arrow ~loc + [{attrs = []; lbl = Nolabel; typ}] return_type in let typ = parse_type_alias p arrow_type in diff --git a/compiler/syntax/src/res_parens.ml b/compiler/syntax/src/res_parens.ml index 49e6c298624..a72080ab253 100644 --- a/compiler/syntax/src/res_parens.ml +++ b/compiler/syntax/src/res_parens.ml @@ -55,7 +55,11 @@ let call_expr expr = | Pexp_for_of _ | Pexp_for_await_of _ | Pexp_ifthenelse _ ); } -> Parenthesized - | _ when Ast_uncurried.expr_is_uncurried_fun expr -> Parenthesized + | _ + when match expr.pexp_desc with + | Pexp_fun _ -> true + | _ -> false -> + Parenthesized | _ when Parsetree_viewer.expr_is_await expr -> Parenthesized | _ -> Nothing) @@ -126,7 +130,11 @@ let binary_expr_operand ~is_lhs expr = Nothing | {pexp_desc = Pexp_constraint _ | Pexp_fun _ | Pexp_newtype _} -> Parenthesized - | _ when Ast_uncurried.expr_is_uncurried_fun expr -> Parenthesized + | _ + when match expr.pexp_desc with + | Pexp_fun _ -> true + | _ -> false -> + Parenthesized | expr when Parsetree_viewer.is_binary_expression expr -> Parenthesized | expr when Parsetree_viewer.is_ternary_expr expr -> Parenthesized | {pexp_desc = Pexp_assert _} when is_lhs -> Parenthesized @@ -181,7 +189,8 @@ let flatten_operand_rhs parent_operator rhs = prec_parent >= prec_child || rhs.pexp_attributes <> [] | Pexp_constraint ({pexp_desc = Pexp_pack _}, {ptyp_desc = Ptyp_package _}) -> false - | Pexp_fun {lhs = {ppat_desc = Ppat_var {txt = "__x"}}} -> false + | Pexp_fun {params = {p_pat = {ppat_desc = Ppat_var {txt = "__x"}}} :: _} -> + false | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ | Pexp_constraint _ -> true | _ when Parsetree_viewer.is_ternary_expr rhs -> true | _ -> false diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index 23da01e468c..8cc876ed90c 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -1,36 +1,10 @@ open Parsetree -let arrow_type ?(max_arity = max_int) ct = - let rec process attrs_before acc typ max_arity = - match typ with - | _ when max_arity < 0 -> (attrs_before, List.rev acc, typ) - | {ptyp_desc = Ptyp_arrow {arity = Some _; arg = {attrs = []}}} - when acc <> [] -> - (attrs_before, List.rev acc, typ) - | {ptyp_desc = Ptyp_arrow {arg = {lbl = Nolabel; attrs = []} as arg; ret}} - -> - process attrs_before (arg :: acc) ret (max_arity - 1) - | {ptyp_desc = Ptyp_arrow {arg = {lbl = Nolabel} as arg; ret}} when acc = [] - -> - (* The head argument is always consumed, attributes or not: returning - the input node itself as the "return type" would make the printer - recurse forever. *) - process attrs_before (arg :: acc) ret (max_arity - 1) - | {ptyp_desc = Ptyp_arrow {arg = {lbl = Nolabel}}; ptyp_attributes = _attrs} - as return_type -> - let args = List.rev acc in - (attrs_before, args, return_type) - | { - ptyp_desc = Ptyp_arrow {arg = {lbl = Labelled _ | Optional _} as arg; ret}; - ptyp_attributes = _attrs; - } -> - process attrs_before (arg :: acc) ret (max_arity - 1) - | typ -> (attrs_before, List.rev acc, typ) - in +let arrow_type ct = match ct with - | {ptyp_desc = Ptyp_arrow _; ptyp_attributes = attrs1} as typ -> - process attrs1 [] {typ with ptyp_attributes = []} max_arity - | typ -> process [] [] typ max_arity + | {ptyp_desc = Ptyp_arrow {params; ret}; ptyp_attributes = attrs} -> + (attrs, params, ret) + | typ -> ([], [], typ) let functor_type modtype = let rec process acc modtype = @@ -109,10 +83,15 @@ let rewrite_underscore_apply expr = match expr.pexp_desc with | Pexp_fun { - arg_label = Nolabel; - default = None; - lhs = {ppat_desc = Ppat_var {txt = "__x"}}; - rhs = {pexp_desc = Pexp_apply {funct = call_expr; args}} as e; + params = + [ + { + p_lbl = Nolabel; + p_default = None; + p_pat = {ppat_desc = Ppat_var {txt = "__x"}}; + }; + ]; + body = {pexp_desc = Pexp_apply {funct = call_expr; args}} as e; } -> let new_args = List.map @@ -166,10 +145,15 @@ let rewrite_underscore_apply_in_pipe expr = match expr.pexp_desc with | Pexp_fun { - arg_label = Nolabel; - default = None; - lhs = {ppat_desc = Ppat_var {txt = "__x"}}; - rhs = {pexp_desc = Pexp_apply {funct; args}} as e; + params = + [ + { + p_lbl = Nolabel; + p_default = None; + p_pat = {ppat_desc = Ppat_var {txt = "__x"}}; + }; + ]; + body = {pexp_desc = Pexp_apply {funct; args}} as e; } -> ( match args with | first_arg :: rest_args when is_underscore_arg first_arg -> @@ -202,26 +186,12 @@ type fun_param_kind = | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} let fun_expr expr_ = - let async = Ast_async.dig_async_payload_from_function expr_ in - let rec collect_params ~n_fun ~params expr = - match expr with - | { - pexp_desc = - Pexp_fun - { - arg_label = lbl; - default = default_expr; - lhs = pattern; - rhs = return_expr; - arity; - }; - pexp_attributes = attrs; - } - when arity = None || n_fun = 0 -> - let parameter = Parameter {attrs; lbl; default_expr; pat = pattern} in - collect_params ~n_fun:(n_fun + 1) ~params:(parameter :: params) - return_expr - | _ -> (async, List.rev params, expr) + let params_of_fun params = + List.map + (fun {p_attrs; p_lbl; p_default; p_pat} -> + Parameter + {attrs = p_attrs; lbl = p_lbl; default_expr = p_default; pat = p_pat}) + params in (* Turns (type t, type u, type z) into "type t u z" *) let rec collect_new_types acc return_expr = @@ -231,11 +201,16 @@ let fun_expr expr_ = | return_expr -> (List.rev acc, return_expr) in match expr_ with - | {pexp_desc = Pexp_newtype (string_loc, rest)} -> + | {pexp_desc = Pexp_newtype (string_loc, rest)} -> ( let string_locs, return_expr = collect_new_types [string_loc] rest in - let param = NewTypes {attrs = []; locs = string_locs} in - collect_params ~n_fun:0 ~params:[param] return_expr - | _ -> collect_params ~n_fun:0 ~params:[] {expr_ with pexp_attributes = []} + let newtype_param = NewTypes {attrs = []; locs = string_locs} in + match return_expr with + | {pexp_desc = Pexp_fun {params; body; async}} -> + (async, newtype_param :: params_of_fun params, body) + | _ -> (false, [newtype_param], return_expr)) + | {pexp_desc = Pexp_fun {params; body; async}} -> + (async, params_of_fun params, body) + | _ -> (false, [], expr_) let process_braces_attr expr = match expr.pexp_attributes with @@ -847,10 +822,15 @@ let is_underscore_apply_sugar expr = match expr.pexp_desc with | Pexp_fun { - arg_label = Nolabel; - default = None; - lhs = {ppat_desc = Ppat_var {txt = "__x"}}; - rhs = {pexp_desc = Pexp_apply _}; + params = + [ + { + p_lbl = Nolabel; + p_default = None; + p_pat = {ppat_desc = Ppat_var {txt = "__x"}}; + }; + ]; + body = {pexp_desc = Pexp_apply _}; } -> true | _ -> false diff --git a/compiler/syntax/src/res_parsetree_viewer.mli b/compiler/syntax/src/res_parsetree_viewer.mli index 8d4536717fe..7558c9954e5 100644 --- a/compiler/syntax/src/res_parsetree_viewer.mli +++ b/compiler/syntax/src/res_parsetree_viewer.mli @@ -2,7 +2,6 @@ * The parsetree contains: a => b => c => d, for printing purposes * we restructure the tree into (a, b, c) and its returnType d *) val arrow_type : - ?max_arity:int -> Parsetree.core_type -> Parsetree.attributes * Parsetree.arg list * Parsetree.core_type diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index da48b02561e..266da5412dc 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -1880,14 +1880,9 @@ and print_label_declaration ?inline_record_definitions ~state and print_typ_expr ?inline_record_definitions ~(state : State.t) (typ_expr : Parsetree.core_type) cmt_tbl = - let print_arrow ~arity typ_expr = - let max_arity = - match arity with - | Some arity -> arity - | None -> max_int - in + let print_arrow typ_expr = let attrs_before, args, return_type = - Parsetree_viewer.arrow_type ~max_arity typ_expr + Parsetree_viewer.arrow_type typ_expr in let return_type_needs_parens = match return_type.ptyp_desc with @@ -1991,7 +1986,7 @@ and print_typ_expr ?inline_record_definitions ~(state : State.t) (* object printings *) | Ptyp_object (fields, open_flag) -> print_object ~state ~inline:false fields open_flag cmt_tbl - | Ptyp_arrow {arity} -> print_arrow ~arity typ_expr + | Ptyp_arrow _ -> print_arrow typ_expr | Ptyp_constr ({txt = Lident inline_record_name}, _) when inline_record_definitions |> find_inline_record_definition inline_record_name @@ -3178,10 +3173,15 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = match e.pexp_desc with | Pexp_fun { - arg_label = Nolabel; - default = None; - lhs = {ppat_desc = Ppat_var {txt = "__x"}}; - rhs = {pexp_desc = Pexp_apply _}; + params = + [ + { + p_lbl = Nolabel; + p_default = None; + p_pat = {ppat_desc = Ppat_var {txt = "__x"}}; + }; + ]; + body = {pexp_desc = Pexp_apply _}; } -> (* (__x) => f(a, __x, c) -----> f(a, _, c) *) print_expression_with_comments ~state diff --git a/tests/analysis_tests/tests-reanalyze/deadcode/expected/deadcode.txt b/tests/analysis_tests/tests-reanalyze/deadcode/expected/deadcode.txt index 79e44acd7af..5f7386a2377 100644 --- a/tests/analysis_tests/tests-reanalyze/deadcode/expected/deadcode.txt +++ b/tests/analysis_tests/tests-reanalyze/deadcode/expected/deadcode.txt @@ -964,16 +964,16 @@ addValueDeclaration +make ImportHookDefault.res:6:0 path:+ImportHookDefault addRecordLabelDeclaration name ImportHookDefault.res:2:2 path:+ImportHookDefault.person addRecordLabelDeclaration age ImportHookDefault.res:3:2 path:+ImportHookDefault.person - addRecordLabelDeclaration person ImportHookDefault.res:7:15 path:+ImportHookDefault.props - addRecordLabelDeclaration children ImportHookDefault.res:9:2 path:+ImportHookDefault.props + addRecordLabelDeclaration person ImportHookDefault.res:8:11 path:+ImportHookDefault.props + addRecordLabelDeclaration children ImportHookDefault.res:9:13 path:+ImportHookDefault.props addRecordLabelDeclaration renderMe ImportHookDefault.res:11:5 path:+ImportHookDefault.props Scanning ImportHooks.cmt Source:ImportHooks.res addValueDeclaration +make ImportHooks.res:13:0 path:+ImportHooks addValueDeclaration +foo ImportHooks.res:20:0 path:+ImportHooks addRecordLabelDeclaration name ImportHooks.res:3:2 path:+ImportHooks.person addRecordLabelDeclaration age ImportHooks.res:4:2 path:+ImportHooks.person - addRecordLabelDeclaration person ImportHooks.res:14:15 path:+ImportHooks.props - addRecordLabelDeclaration children ImportHooks.res:16:2 path:+ImportHooks.props + addRecordLabelDeclaration person ImportHooks.res:15:11 path:+ImportHooks.props + addRecordLabelDeclaration children ImportHooks.res:16:13 path:+ImportHooks.props addRecordLabelDeclaration renderMe ImportHooks.res:18:5 path:+ImportHooks.props Scanning ImportIndex.cmt Source:ImportIndex.res addValueDeclaration +make ImportIndex.res:2:0 path:+ImportIndex @@ -2140,6 +2140,7 @@ Forward Liveness Analysis Root (external ref): Value +OptionalArgsLiveDead.+liveCaller Root (annotated): Value +Types.+testInstantiateTypeParameter Root (annotated): RecordLabel +ImportHookDefault.props.renderMe + Root (annotated): RecordLabel +ImportHookDefault.props.children Root (annotated): Value +TypeParams3.+test Root (annotated): Value +Types.+optFunction Root (annotated): Value +Variants.+sunday @@ -2210,6 +2211,7 @@ Forward Liveness Analysis Root (external ref): VariantCase DeadTypeTest.deadType.OnlyInInterface Root (annotated): Value +ImportJsValue.+higherOrder Root (annotated): Value +Variants.+restResult3 + Root (annotated): RecordLabel +ImportHooks.props.person Root (external ref): Value +FirstClassModules.M.InnerModule3.+k3 Root (annotated): Value +DeadTest.+fortyTwoButExported Root (external ref): Value +ContextOptionalArgs.ComponentNotUsingAction.+dispatchNotification @@ -2302,7 +2304,6 @@ Forward Liveness Analysis Root (external ref): VariantCase +DeadTest.inlineRecord.IR Root (annotated): Value +Records.+getPayloadRecordPlusOne Root (annotated): Value +Types.+swap - Root (annotated): RecordLabel +ImportHookDefault.props.person Root (annotated): Value +Variants.+saturday Root (external ref): VariantCase +Docstrings.t.A Root (annotated): Value +OcamlWarningSuppressToplevel.M.+suppressed3 @@ -2335,6 +2336,7 @@ Forward Liveness Analysis Root (external ref): Value +ContextOptionalArgs.ComponentNotUsingAction.+make Root (external ref): RecordLabel +Records.myRec.type_ Root (external ref): Value +DeadTest.+make + Root (annotated): RecordLabel +ImportHooks.props.children Root (annotated): Value NestedModulesInSignature.Universe.+theAnswer Root (annotated): Value +Docstrings.+unitArgWithoutConversion Root (annotated): Value +ContextOptionalArgs.+make @@ -2356,7 +2358,6 @@ Forward Liveness Analysis Root (annotated): Value +TestFirstClassModules.+convertInterface Root (external ref): RecordLabel +VariantsWithPayload.payload.x Root (annotated): RecordLabel +DeadTest.inlineRecord.IR.e - Root (annotated): RecordLabel +ImportHooks.props.children Root (external ref): RecordLabel +DeadTest.props.s Root (external ref): VariantCase +DeadTypeTest.t.A Root (annotated): Value +Docstrings.+oneU @@ -2367,6 +2368,7 @@ Forward Liveness Analysis Root (external ref): RecordLabel +Records.business2.address2 Root (external ref): VariantCase DeadTypeTest.deadType.InBoth Root (annotated): Value +ScopedAnnotationsOverride.M.+live2 + Root (annotated): RecordLabel +ImportHookDefault.props.person Root (annotated): Value +FirstClassModules.+someFunctorAsFunction Root (annotated): Value +Variants.+fortytwoBAD Root (external ref): RecordLabel +Unison.t.break_ @@ -2395,7 +2397,6 @@ Forward Liveness Analysis Root (external ref): RecordLabel +Uncurried.authU.loginU Root (external ref): RecordLabel +Tuples.person.name Root (annotated): Value +ModuleAliases.+testInner2 - Root (annotated): RecordLabel +ImportHooks.props.person Root (external ref): Value DeadValueTest.+valueAlive Root (external ref): Value +DeadTest.+ira Root (external ref): RecordLabel +Hooks.RenderPropRequiresConversion.props.renderVehicle @@ -2453,7 +2454,6 @@ Forward Liveness Analysis Root (external ref): VariantCase +DeadTypeTest.deadType.InBoth Root (external ref): RecordLabel +Records.business.address Root (external ref): RecordLabel +VariantsWithPayload.payload.y - Root (annotated): RecordLabel +ImportHookDefault.props.children Root (annotated): Value +Records.+testMyRec2 Root (annotated): Value +TestModuleAliases.+testInner1 Root (annotated): Value +ForAwaitOf.+keep diff --git a/tests/analysis_tests/tests/src/expected/CompletionInferValues.res.txt b/tests/analysis_tests/tests/src/expected/CompletionInferValues.res.txt index 881ae2ea386..861e4a00de0 100644 --- a/tests/analysis_tests/tests/src/expected/CompletionInferValues.res.txt +++ b/tests/analysis_tests/tests/src/expected/CompletionInferValues.res.txt @@ -214,8 +214,6 @@ Complete src/CompletionInferValues.res 24:63 posCursor:[24:63] posNoWhite:[24:62] Found expr:[24:3->24:64] Pexp_apply ...[24:3->24:21] (...[24:22->24:63]) posCursor:[24:63] posNoWhite:[24:62] Found expr:[24:22->24:63] -posCursor:[24:63] posNoWhite:[24:62] Found expr:[24:36->24:63] -posCursor:[24:63] posNoWhite:[24:62] Found expr:[24:42->24:63] posCursor:[24:63] posNoWhite:[24:62] Found expr:[24:52->24:63] Pexp_field [24:52->24:62] _:[24:63->24:63] Completable: Cpath Value[someRecord]."" @@ -265,8 +263,6 @@ Complete src/CompletionInferValues.res 27:90 posCursor:[27:90] posNoWhite:[27:89] Found expr:[27:39->27:91] Pexp_apply ...[27:39->27:48] (...[27:49->27:90]) posCursor:[27:90] posNoWhite:[27:89] Found expr:[27:49->27:90] -posCursor:[27:90] posNoWhite:[27:89] Found expr:[27:56->27:90] -posCursor:[27:90] posNoWhite:[27:89] Found expr:[27:69->27:90] posCursor:[27:90] posNoWhite:[27:89] Found expr:[27:79->27:90] Pexp_field [27:79->27:89] _:[27:90->27:90] Completable: Cpath Value[someRecord]."" diff --git a/tests/analysis_tests/tests/src/expected/FirstClassModules.res.txt b/tests/analysis_tests/tests/src/expected/FirstClassModules.res.txt index 34efeb08337..d27859bf96c 100644 --- a/tests/analysis_tests/tests/src/expected/FirstClassModules.res.txt +++ b/tests/analysis_tests/tests/src/expected/FirstClassModules.res.txt @@ -201,7 +201,6 @@ Path SomeModule. Complete src/FirstClassModules.res 65:17 posCursor:[65:17] posNoWhite:[65:16] Found expr:[58:16->69:1] -posCursor:[65:17] posNoWhite:[65:16] Found expr:[60:2->69:1] posCursor:[65:17] posNoWhite:[65:16] Found expr:[62:2->68:3] posCursor:[65:17] posNoWhite:[65:16] Found expr:[64:4->67:6] posCursor:[65:17] posNoWhite:[65:16] Found expr:[65:6->67:6] diff --git a/tests/analysis_tests/tests/src/expected/SignatureHelp.res.txt b/tests/analysis_tests/tests/src/expected/SignatureHelp.res.txt index b30ae0c7e3b..eca9ac35ec1 100644 --- a/tests/analysis_tests/tests/src/expected/SignatureHelp.res.txt +++ b/tests/analysis_tests/tests/src/expected/SignatureHelp.res.txt @@ -10,8 +10,7 @@ ContextPath Value[someFunc] Path someFunc argAtCursor: unlabelled<0> extracted params: -[( - int, ~two: string=?, ~three: unit => unit, ~four: someVariant, unit] +[int, two: string=?, three: unit => unit, four: someVariant, unit] { "activeParameter": 0, "activeSignature": 0, @@ -23,22 +22,22 @@ extracted params: "parameters": [ { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 0, 7 ] + "label": [ 4, 7 ] }, { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 11, 25 ] + "label": [ 12, 25 ] }, { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 29, 49 ] + "label": [ 30, 49 ] }, { "documentation": { "kind": "markdown", "value": "```rescript\ntype someVariant = One | Two | Three\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22SignatureHelp.res%22%2C0%2C0%5D)" }, - "label": [ 53, 71 ] + "label": [ 54, 71 ] }, { "documentation": { "kind": "markdown", "value": "" }, @@ -61,8 +60,7 @@ ContextPath Value[someFunc] Path someFunc argAtCursor: unlabelled<0> extracted params: -[( - int, ~two: string=?, ~three: unit => unit, ~four: someVariant, unit] +[int, two: string=?, three: unit => unit, four: someVariant, unit] { "activeParameter": 0, "activeSignature": 0, @@ -74,22 +72,22 @@ extracted params: "parameters": [ { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 0, 7 ] + "label": [ 4, 7 ] }, { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 11, 25 ] + "label": [ 12, 25 ] }, { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 29, 49 ] + "label": [ 30, 49 ] }, { "documentation": { "kind": "markdown", "value": "```rescript\ntype someVariant = One | Two | Three\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22SignatureHelp.res%22%2C0%2C0%5D)" }, - "label": [ 53, 71 ] + "label": [ 54, 71 ] }, { "documentation": { "kind": "markdown", "value": "" }, @@ -112,8 +110,7 @@ ContextPath Value[someFunc] Path someFunc argAtCursor: ~two extracted params: -[( - int, ~two: string=?, ~three: unit => unit, ~four: someVariant, unit] +[int, two: string=?, three: unit => unit, four: someVariant, unit] { "activeParameter": 1, "activeSignature": 0, @@ -125,22 +122,22 @@ extracted params: "parameters": [ { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 0, 7 ] + "label": [ 4, 7 ] }, { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 11, 25 ] + "label": [ 12, 25 ] }, { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 29, 49 ] + "label": [ 30, 49 ] }, { "documentation": { "kind": "markdown", "value": "```rescript\ntype someVariant = One | Two | Three\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22SignatureHelp.res%22%2C0%2C0%5D)" }, - "label": [ 53, 71 ] + "label": [ 54, 71 ] }, { "documentation": { "kind": "markdown", "value": "" }, @@ -163,8 +160,7 @@ ContextPath Value[someFunc] Path someFunc argAtCursor: ~two extracted params: -[( - int, ~two: string=?, ~three: unit => unit, ~four: someVariant, unit] +[int, two: string=?, three: unit => unit, four: someVariant, unit] { "activeParameter": 1, "activeSignature": 0, @@ -176,22 +172,22 @@ extracted params: "parameters": [ { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 0, 7 ] + "label": [ 4, 7 ] }, { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 11, 25 ] + "label": [ 12, 25 ] }, { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 29, 49 ] + "label": [ 30, 49 ] }, { "documentation": { "kind": "markdown", "value": "```rescript\ntype someVariant = One | Two | Three\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22SignatureHelp.res%22%2C0%2C0%5D)" }, - "label": [ 53, 71 ] + "label": [ 54, 71 ] }, { "documentation": { "kind": "markdown", "value": "" }, @@ -214,8 +210,7 @@ ContextPath Value[someFunc] Path someFunc argAtCursor: ~four extracted params: -[( - int, ~two: string=?, ~three: unit => unit, ~four: someVariant, unit] +[int, two: string=?, three: unit => unit, four: someVariant, unit] { "activeParameter": 3, "activeSignature": 0, @@ -227,22 +222,22 @@ extracted params: "parameters": [ { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 0, 7 ] + "label": [ 4, 7 ] }, { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 11, 25 ] + "label": [ 12, 25 ] }, { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 29, 49 ] + "label": [ 30, 49 ] }, { "documentation": { "kind": "markdown", "value": "```rescript\ntype someVariant = One | Two | Three\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22SignatureHelp.res%22%2C0%2C0%5D)" }, - "label": [ 53, 71 ] + "label": [ 54, 71 ] }, { "documentation": { "kind": "markdown", "value": "" }, @@ -265,8 +260,7 @@ ContextPath Value[someFunc] Path someFunc argAtCursor: ~four extracted params: -[( - int, ~two: string=?, ~three: unit => unit, ~four: someVariant, unit] +[int, two: string=?, three: unit => unit, four: someVariant, unit] { "activeParameter": 3, "activeSignature": 0, @@ -278,22 +272,22 @@ extracted params: "parameters": [ { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 0, 7 ] + "label": [ 4, 7 ] }, { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 11, 25 ] + "label": [ 12, 25 ] }, { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 29, 49 ] + "label": [ 30, 49 ] }, { "documentation": { "kind": "markdown", "value": "```rescript\ntype someVariant = One | Two | Three\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22SignatureHelp.res%22%2C0%2C0%5D)" }, - "label": [ 53, 71 ] + "label": [ 54, 71 ] }, { "documentation": { "kind": "markdown", "value": "" }, @@ -316,7 +310,7 @@ ContextPath Value[otherFunc] Path otherFunc argAtCursor: unlabelled<0> extracted params: -[(string, int, float] +[string, int, float] { "activeParameter": 0, "activeSignature": 0, @@ -327,7 +321,7 @@ extracted params: "parameters": [ { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 0, 7 ] + "label": [ 1, 7 ] }, { "documentation": { "kind": "markdown", "value": "" }, @@ -354,7 +348,7 @@ ContextPath Value[otherFunc] Path otherFunc argAtCursor: unlabelled<0> extracted params: -[(string, int, float] +[string, int, float] { "activeParameter": 0, "activeSignature": 0, @@ -365,7 +359,7 @@ extracted params: "parameters": [ { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 0, 7 ] + "label": [ 1, 7 ] }, { "documentation": { "kind": "markdown", "value": "" }, @@ -392,7 +386,7 @@ ContextPath Value[otherFunc] Path otherFunc argAtCursor: unlabelled<2> extracted params: -[(string, int, float] +[string, int, float] { "activeParameter": 2, "activeSignature": 0, @@ -403,7 +397,7 @@ extracted params: "parameters": [ { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 0, 7 ] + "label": [ 1, 7 ] }, { "documentation": { "kind": "markdown", "value": "" }, @@ -430,7 +424,7 @@ ContextPath Value[Completion, Lib, foo] Path Completion.Lib.foo argAtCursor: ~age extracted params: -[(~age: int, ~name: string] +[age: int, name: string] { "activeParameter": 0, "activeSignature": 0, @@ -441,11 +435,11 @@ extracted params: "parameters": [ { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 0, 10 ] + "label": [ 2, 10 ] }, { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 12, 25 ] + "label": [ 13, 25 ] } ] } @@ -495,7 +489,7 @@ ContextPath Value[otherFunc] Path otherFunc argAtCursor: unlabelled<1> extracted params: -[(string, int, float] +[string, int, float] { "activeParameter": 1, "activeSignature": 0, @@ -506,7 +500,7 @@ extracted params: "parameters": [ { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 0, 7 ] + "label": [ 1, 7 ] }, { "documentation": { "kind": "markdown", "value": "" }, @@ -533,7 +527,7 @@ ContextPath Value[fn] Path fn argAtCursor: unlabelled<1> extracted params: -[(int, string, int] +[int, string, int] { "activeParameter": 1, "activeSignature": 0, @@ -544,7 +538,7 @@ extracted params: "parameters": [ { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 0, 4 ] + "label": [ 1, 4 ] }, { "documentation": { "kind": "markdown", "value": "" }, @@ -571,7 +565,7 @@ ContextPath Value[fn] Path fn argAtCursor: unlabelled<1> extracted params: -[(int, string, int] +[int, string, int] { "activeParameter": 1, "activeSignature": 0, @@ -582,7 +576,7 @@ extracted params: "parameters": [ { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 0, 4 ] + "label": [ 1, 4 ] }, { "documentation": { "kind": "markdown", "value": "" }, @@ -609,7 +603,7 @@ ContextPath Value[fn] Path fn argAtCursor: unlabelled<2> extracted params: -[(int, string, int] +[int, string, int] { "activeParameter": 2, "activeSignature": 0, @@ -620,7 +614,7 @@ extracted params: "parameters": [ { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 0, 4 ] + "label": [ 1, 4 ] }, { "documentation": { "kind": "markdown", "value": "" }, @@ -683,8 +677,7 @@ ContextPath Value[someFunc] Path someFunc argAtCursor: unlabelled<0> extracted params: -[( - int, ~two: string=?, ~three: unit => unit, ~four: someVariant, unit] +[int, two: string=?, three: unit => unit, four: someVariant, unit] { "activeParameter": 0, "activeSignature": 0, @@ -696,22 +689,22 @@ extracted params: "parameters": [ { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 0, 7 ] + "label": [ 4, 7 ] }, { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 11, 25 ] + "label": [ 12, 25 ] }, { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 29, 49 ] + "label": [ 30, 49 ] }, { "documentation": { "kind": "markdown", "value": "```rescript\ntype someVariant = One | Two | Three\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22SignatureHelp.res%22%2C0%2C0%5D)" }, - "label": [ 53, 71 ] + "label": [ 54, 71 ] }, { "documentation": { "kind": "markdown", "value": "" }, @@ -923,7 +916,7 @@ Signature help src/SignatureHelp.res 105:9 Signature help src/SignatureHelp.res 113:42 argAtCursor: unlabelled<1> extracted params: -[(array, int => int] +[array, int => int] { "activeParameter": 1, "activeSignature": 0, @@ -938,7 +931,7 @@ extracted params: "parameters": [ { "documentation": { "kind": "markdown", "value": "" }, - "label": [ 0, 11 ] + "label": [ 1, 11 ] }, { "documentation": { "kind": "markdown", "value": "" }, @@ -952,7 +945,7 @@ extracted params: Signature help src/SignatureHelp.res 132:18 argAtCursor: unlabelled<0> extracted params: -[(x, tt] +[x, tt] { "activeParameter": 0, "activeSignature": 0, @@ -967,7 +960,7 @@ extracted params: "kind": "markdown", "value": "```rescript\ntype x = {age?: int, name?: string}\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22SignatureHelp.res%22%2C117%2C0%5D)" }, - "label": [ 0, 2 ] + "label": [ 1, 2 ] }, { "documentation": { @@ -984,7 +977,7 @@ extracted params: Signature help src/SignatureHelp.res 135:22 argAtCursor: unlabelled<1> extracted params: -[(x, tt] +[x, tt] { "activeParameter": 1, "activeSignature": 0, @@ -999,7 +992,7 @@ extracted params: "kind": "markdown", "value": "```rescript\ntype x = {age?: int, name?: string}\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22SignatureHelp.res%22%2C117%2C0%5D)" }, - "label": [ 0, 2 ] + "label": [ 1, 2 ] }, { "documentation": { diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index 450d6197406..9d330f0a7a2 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -85,10 +85,15 @@ let test_function_cases_desugar_to_fun_match _ = match expr.pexp_desc with | Parsetree.Pexp_fun { - arg_label = Nolabel; - default = None; - lhs = {ppat_desc = Ppat_var {txt = param}}; - rhs = + params = + [ + { + p_lbl = Nolabel; + p_default = None; + p_pat = {ppat_desc = Ppat_var {txt = param}}; + }; + ]; + body = { pexp_desc = Pexp_match ({pexp_desc = Pexp_ident {txt = Lident scrutinee}}, [_]); diff --git a/tests/syntax_tests/data/parsing/errors/expressions/expected/ambiguousArrow.res.txt b/tests/syntax_tests/data/parsing/errors/expressions/expected/ambiguousArrow.res.txt index abb53217fea..93790c5f7d1 100644 --- a/tests/syntax_tests/data/parsing/errors/expressions/expected/ambiguousArrow.res.txt +++ b/tests/syntax_tests/data/parsing/errors/expressions/expected/ambiguousArrow.res.txt @@ -24,6 +24,7 @@ 1) (pattern): int => "test" 2) (pattern: int) => "test" -let a b = ({js|hi|js} : int) -let x = ((let a = 1 in let b = 2 in fun pattern -> ({js|test|js} : int)) +let a [arity:1]b = ({js|hi|js} : int) +let x = + ((let a = 1 in let b = 2 in fun [arity:1]pattern -> ({js|test|js} : int)) [@res.braces ]) \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/errors/expressions/expected/arrow.res.txt b/tests/syntax_tests/data/parsing/errors/expressions/expected/arrow.res.txt index 1cf97a8773d..2195fb842b7 100644 --- a/tests/syntax_tests/data/parsing/errors/expressions/expected/arrow.res.txt +++ b/tests/syntax_tests/data/parsing/errors/expressions/expected/arrow.res.txt @@ -9,5 +9,5 @@ Did you forget a `,` here? ;;(Object.keys providers).reduce - (fun [arity:2]elements -> - fun providerId -> ((let x = 1 in let b = 2 in x + b)[@res.braces ])) \ No newline at end of file + (fun [arity:2]elements providerId -> ((let x = 1 in let b = 2 in x + b) + [@res.braces ])) \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/errors/expressions/expected/block.res.txt b/tests/syntax_tests/data/parsing/errors/expressions/expected/block.res.txt index 60633e7eb93..772ed2be8f3 100644 --- a/tests/syntax_tests/data/parsing/errors/expressions/expected/block.res.txt +++ b/tests/syntax_tests/data/parsing/errors/expressions/expected/block.res.txt @@ -65,17 +65,16 @@ let findThreadByIdLinearScan [arity:2]~threads ~id = ((Array.findWithIndex ThreadsModel.threads - (fun [arity:2]thread -> - fun i -> - ((let thisId = - match thread with - | ServerData.OneToOne { otherPersonIDWhichIsAlsoThreadID } -> - otherPersonIDWhichIsAlsoThreadID - | Group { id } -> id - | Unknown { id } -> - (unknown.id -> String.make) -> FBID.ofStringUnsafe in - thisId === id) - [@res.braces ]))) + (fun [arity:2]thread i -> + ((let thisId = + match thread with + | ServerData.OneToOne { otherPersonIDWhichIsAlsoThreadID } -> + otherPersonIDWhichIsAlsoThreadID + | Group { id } -> id + | Unknown { id } -> + (unknown.id -> String.make) -> FBID.ofStringUnsafe in + thisId === id) + [@res.braces ]))) [@res.braces ]) let x = ((loop 0 (Nil -> (push doc)))[@res.braces ]) ;;match stack with diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/UncurriedByDefault.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/UncurriedByDefault.res.txt index 069776547b2..3fa7799d94c 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/UncurriedByDefault.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/UncurriedByDefault.res.txt @@ -9,10 +9,8 @@ let uFun2 [arity:2]x y = 3 type nonrec cTyp = string -> int (a:1) type nonrec uTyp = string -> int (a:1) type nonrec mixTyp = - string -> - string -> - string -> - string -> string -> string -> string -> string -> int (a:2) (a:3) (a:3) + string -> string -> string -> + string -> string -> string -> string -> string -> int (a:2) (a:3) (a:3) type nonrec bTyp = string -> string -> int (a:1) (a:1) type nonrec cTyp2 = string -> string -> int (a:2) type nonrec uTyp2 = string -> string -> int (a:2) @@ -67,9 +65,8 @@ type nonrec cTyp = string -> int (a:1) type nonrec uTyp = string -> int (a:1) type nonrec mixTyp = string -> - string -> - string -> - string -> string -> string -> string -> string -> int (a:1) (a:4) (a:2) (a:1) + string -> string -> + string -> string -> string -> string -> string -> int (a:1) (a:4) (a:2) (a:1) type nonrec bTyp = string -> string -> int (a:1) (a:1) type nonrec cTyp2 = string -> string -> int (a:2) type nonrec uTyp2 = string -> string -> int (a:2) diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/apply.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/apply.res.txt index b913ec585f5..b257b430a02 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/apply.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/apply.res.txt @@ -3,7 +3,7 @@ ;;foo (fun [arity:1]_ -> bla) blaz ;;foo (fun [arity:1]_ -> bla) (fun [arity:1]_ -> blaz) ;;List.map (fun [arity:1]x -> x + 1) myList -;;List.reduce (fun [arity:2]acc -> fun curr -> acc + curr) 0 myList +;;List.reduce (fun [arity:2]acc curr -> acc + curr) 0 myList let unitUncurried = apply () ;;call ~a:(a : int) ;;call (~~~ a) diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/async.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/async.res.txt index 1680c2c3ccf..0c04ab839d4 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/async.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/async.res.txt @@ -18,8 +18,8 @@ let async = [@res.braces ]) let f = ((if isPositive - then async fun [arity:2]a -> fun b -> (a + b : int) - else (async fun [arity:2]c -> fun d -> (c - d : int))) + then async fun [arity:2]a b -> (a + b : int) + else (async fun [arity:2]c d -> (c - d : int))) [@res.ternary ]) let foo = async ~a:34 let bar async [arity:1]~a = a + 1 diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/jsx.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/jsx.res.txt index a78936133f7..b4eb70195f7 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/jsx.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/jsx.res.txt @@ -72,22 +72,18 @@ let _ = < let _ = > let y = - fun _oldUrl -> - fun newUrl -> - updater - (fun [arity:2]latestComponentBag -> - fun _ -> - ((let currentActualPath = Routes.hashOfUri newUrl in - let pathFromState = - Routes.stateToPath latestComponentBag.state in - ((if currentActualPath == pathFromState - then None - else - dispatchEventless (State.UriNavigated currentActualPath) - latestComponentBag ()) - [@res.ternary ])) - [@res.braces ])) ()) + fun [arity:3]_oldPath _oldUrl newUrl -> + updater + (fun [arity:2]latestComponentBag _ -> + ((let currentActualPath = Routes.hashOfUri newUrl in + let pathFromState = Routes.stateToPath latestComponentBag.state in + ((if currentActualPath == pathFromState + then None + else + dispatchEventless (State.UriNavigated currentActualPath) + latestComponentBag ()) + [@res.ternary ])) + [@res.braces ])) ()) [@res.braces ]) /> let z =
let _ = - - fun bar -> - fun baz -> - fun lineBreak -> - fun identifier -> - ((doStuff foo bar baz; - bar lineBreak identifier) - [@res.braces ])) + + ((doStuff foo bar baz; bar lineBreak identifier) + [@res.braces ])) [@res.braces ]) /> let _ = handleChange event) [@res.braces ][@bar ]) /> @@ -192,38 +183,26 @@ let _ = handleChange eventLongIdentifier) [@res.braces ][@bar ]) /> let _ = - - fun ~bar -> - fun ~baz -> - fun ~lineBreak -> - fun ~identifier -> - fun () -> bar lineBreak identifier) + bar lineBreak identifier) [@res.braces ]) /> let _ =
(((doStuff (); bar foo) [@res.braces ]) : event)) [@res.braces ]) /> let _ = -
- fun e2 -> (((doStuff (); bar foo)[@res.braces ]) : event)) +
(((doStuff (); bar foo) + [@res.braces ]) : event)) [@res.braces ]) /> let _ = -
- fun bar -> - fun baz -> - fun superLongIdent -> - fun breakLine -> (((doStuff (); bar foo) - [@res.braces ]) : (event * event2 * event3 * - event4 * event5))) +
+ (((doStuff (); bar foo) + [@res.braces ]) : (event * event2 * event3 * event4 * + event5))) [@res.braces ]) /> let _ = -
- fun bar -> - fun baz -> - fun superLongIdent -> - fun breakLine -> - (doStuff () : (event * event2 * event3 * event4 * - event5))) +
+ (doStuff () : (event * event2 * event3 * event4 * event5))) [@res.braces ]) /> let _ =
((match color with diff --git a/tests/syntax_tests/data/parsing/grammar/expressions/expected/locallyAbstractTypes.res.txt b/tests/syntax_tests/data/parsing/grammar/expressions/expected/locallyAbstractTypes.res.txt index 58f56be1748..24693d89e30 100644 --- a/tests/syntax_tests/data/parsing/grammar/expressions/expected/locallyAbstractTypes.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/expressions/expected/locallyAbstractTypes.res.txt @@ -5,15 +5,14 @@ let f (type t) (type u) (type v) (type s) (type w) (type z) [arity:2](xs : (t * u * v) list) (ys : (s * w * z) list) = () let f = ((fun (type t) -> fun (type u) -> fun (type v) -> fun (type s) -> fun (type w) -> fun (type z) -> - fun [arity:2](xs : (t * u * v) list) -> fun (ys : (s * w * z) list) -> ()) + fun [arity:2](xs : (t * u * v) list) (ys : (s * w * z) list) -> ()) [@attr ][@attr2 ]) let f = ((fun (type t) -> fun (type s) -> fun (type u) -> fun (type v) -> fun - (type w) -> - fun [arity:2](xs : (t * s) list) -> fun (ys : (u * v * w) list) -> ()) + (type w) -> fun [arity:2](xs : (t * s) list) (ys : (u * v * w) list) -> ()) [@attr ][@attr ][@attr ][@attr ]) let cancel_and_collect_callbacks : 'a 'u 'c . - packed_callbacks list -> - ('a, 'u, 'c) promise -> packed_callbacks list (a:2) + packed_callbacks list -> ('a, 'u, 'c) promise -> + packed_callbacks list (a:2) = fun (type x) -> - fun [arity:2]callbacks_accumulator -> fun (p : (_, _, c) promise) -> () \ No newline at end of file + fun [arity:2]callbacks_accumulator (p : (_, _, c) promise) -> () \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/es6Arrow.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/es6Arrow.res.txt index de16403398b..81b963709aa 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/es6Arrow.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/es6Arrow.res.txt @@ -22,8 +22,8 @@ type nonrec t = f:(int -> string (a:1)) -> float (a:1) type nonrec t = f:(int -> string (a:1)) -> float (a:1) type nonrec t = f:int -> string -> float (a:1) (a:1) type nonrec t = - a:int[@attrBeforeLblA ] -> - b:int[@attrBeforeLblB ] -> ((float)[@attr ]) -> unit (a:3) + a:int[@attrBeforeLblA ] -> b:int[@attrBeforeLblB ] -> ((float)[@attr ]) -> + unit (a:3) type nonrec t = ((a:int -> ((b:int -> ((float)[@attr ]) -> unit (a:1) (a:1))[@attrBeforeLblB ]) (a:1)) diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/poly.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/poly.res.txt index cca42fdbb72..90c895ac38a 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/poly.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/poly.res.txt @@ -2,7 +2,8 @@ external getLogger : unit -> < log: 'a -> unit (a:1) ;log2: 'a . int -> int (a:1) ;log3: 'a 'b . - 'a -> - 'b -> int (a:2) + 'a -> 'b + -> + int (a:2) > (a:1) = "./src/logger.mock.js" \ No newline at end of file diff --git a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/uncurried.res.txt b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/uncurried.res.txt index 94510d96563..f2718cf008f 100644 --- a/tests/syntax_tests/data/parsing/grammar/typexpr/expected/uncurried.res.txt +++ b/tests/syntax_tests/data/parsing/grammar/typexpr/expected/uncurried.res.txt @@ -2,16 +2,16 @@ type nonrec t = { mutable field: float -> int -> bool -> unit (a:3) } type nonrec t = float -> int -> bool -> unit (a:3) type nonrec t = - ((float)[@attr ]) -> - ((int)[@attr2 ]) -> ((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit (a:4) + ((float)[@attr ]) -> ((int)[@attr2 ]) -> ((bool)[@attr3 ]) -> + ((string)[@attr4 ]) -> unit (a:4) type nonrec t = ((float -> ((int)[@attr2 ]) -> ((bool -> ((string)[@attr4 ]) -> unit (a:1) (a:1))[@attr3 ]) (a:1) (a:1)) [@attr ]) type nonrec t = - ((float)[@attr ]) -> - ((int)[@attr2 ]) -> ((bool)[@attr3 ]) -> ((string)[@attr4 ]) -> unit (a:4) + ((float)[@attr ]) -> ((int)[@attr2 ]) -> ((bool)[@attr3 ]) -> + ((string)[@attr4 ]) -> unit (a:4) external setTimeout : (unit -> unit (a:1)) -> int -> timerId (a:2) = "setTimeout"[@@val ] external setTimeout : diff --git a/tests/tests/src/UncurriedExternals.mjs b/tests/tests/src/UncurriedExternals.mjs index a1525f2caf2..4a0e3ca6584 100644 --- a/tests/tests/src/UncurriedExternals.mjs +++ b/tests/tests/src/UncurriedExternals.mjs @@ -64,9 +64,9 @@ let StandardNotation = { set: StandardNotation_set }; -function methodWithAsync(param) { +function methodWithAsync() { let $$this = this ; - return (async arg => $$this + arg | 0)(param); + return async arg => $$this + arg | 0; } let p1 = { diff --git a/tools/src/transforms.ml b/tools/src/transforms.ml index e4b549c5e95..901cc9c2154 100644 --- a/tools/src/transforms.ml +++ b/tools/src/transforms.ml @@ -3,29 +3,20 @@ let labelled_to_unlabelled_arguments_in_fn_definition (e : Parsetree.expression) (* `(~a, ~b, ~c) => ...` to `(a, b, c) => ...` *) let rec drop_labels (e : Parsetree.expression) : Parsetree.expression = match e.pexp_desc with - | Pexp_fun - {arg_label = Labelled _ | Optional _; default; lhs; rhs; arity; async} - -> + | Pexp_fun {params; body; async} -> { e with pexp_desc = Pexp_fun { - arg_label = Nolabel; - default; - lhs; - rhs = drop_labels rhs; - arity; + params = + List.map + (fun (p : Parsetree.fun_param) -> {p with p_lbl = Nolabel}) + params; + body = drop_labels body; async; }; } - | Pexp_fun {arg_label; default; lhs; rhs; arity; async} -> - { - e with - pexp_desc = - Pexp_fun - {arg_label; default; lhs; rhs = drop_labels rhs; arity; async}; - } | _ -> e in drop_labels e From d5cf39ca9f69d51685de01dd32e2688058da5fa6 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Fri, 14 Aug 2026 19:07:09 +0200 Subject: [PATCH 05/10] Make the typed layers n-ary: Tarrow params and Texp_function params Types.Tarrow carries a parameter list (Tarrow of arg list * type_expr); Texp_function carries typed parameters {fp_lbl; fp_param; fp_pat; fp_partial} and a body; Ttyp_arrow and Otyp_arrow follow. The arity annotation and its int-option phantom state are gone from the compiler. Type relations compare parameters pairwise; a length mismatch is structural incompatibility (which also makes mcomp's arrow verdict sound: arrows of different lengths can never unify). filter_arrow becomes filter_arrow_n. type_function types all parameters against one arrow, checking expected labels up front to preserve the dedicated Abstract_wrong_label diagnostics; optional-parameter defaults desugar to uniquified *opt_