From 403b094bd649b3539d798c8212bc344b1635aafa Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 17 Aug 2026 14:19:00 +0200 Subject: [PATCH] Make locally abstract value constraints structural in the parsetree Replace the desugared encoding of [let f: type a. t = e] - a Ptyp_poly pattern constraint plus a Pexp_newtype chain over a Pexp_constraint, with the type stored twice and no AST invariant ensuring that the copies agree - with a structural field on the binding: pvb_constraint: {pvc_newtypes: string loc list; pvc_type: core_type} Only the [type a.] form uses the field; plain constraints and explicit polymorphic annotations keep their existing representation. The type is stored once, and [varify_constructors] now runs in exactly one place, inside the type checker. With functions already carrying their locally abstract type parameters in Pexp_fun.newtypes, this removes the last place where the parser constructs Pexp_newtype. Delete the constructor from the current parsetree, along with the Texp_newtype exp_extra, which had no consumer beyond no-op iterators and the debug printer. The CMT magic number is bumped to Caml1999T024; the CMI format is unchanged. Type checking follows the same design as the function case (and OCaml 5.x): type_let introduces the locally abstract types into scope via type_newtype, types the body against the constraint, and unifies with the pattern's polymorphic type. This preserves the semantics of the former desugaring. The frozen v0 PPX bridge expands the field back into the historical wrapper-chain encoding and recognizes well-formed instances of that encoding on the way in, verified by unit tests. A v0 Pexp_newtype chain that cannot be represented - such as one that does not enclose ReScript's Function$ encoding, or one whose structure was changed by a PPX - now becomes a located ocaml.error extension with an explicit message. This is the only intentional reduction in accepted v0 PPX output. Formatter bug fix covered by syntax fixtures: a trailing comment between the constraint type and [=] is no longer dropped. An end-to-end GADT test checks that refinement still works with the new binding field. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Fable 5 --- CHANGELOG.md | 2 + analysis/src/completion_front_end.ml | 14 +- analysis/src/dump_ast.ml | 16 +- analysis/src/hint.ml | 2 + analysis/src/utils.ml | 1 - analysis/src/xform.ml | 11 +- compiler/ext/config.ml | 2 +- .../frontend/ast_tuple_pattern_flatten.ml | 35 +++- compiler/frontend/ast_uncurry_gen.ml | 4 +- compiler/frontend/ast_uncurry_gen.mli | 1 + compiler/frontend/bs_ast_mapper.ml | 17 +- compiler/frontend/bs_builtin_ppx.ml | 27 ++- compiler/ml/ast_async.ml | 3 +- compiler/ml/ast_helper.ml | 11 +- compiler/ml/ast_helper.mli | 9 +- compiler/ml/ast_iterator.ml | 8 +- compiler/ml/ast_mapper.ml | 17 +- compiler/ml/ast_mapper_from0.ml | 81 ++++++-- compiler/ml/ast_mapper_to0.ml | 33 +++- compiler/ml/depend.ml | 1 - compiler/ml/parsetree.ml | 8 +- compiler/ml/pprintast.ml | 69 ++++--- compiler/ml/printast.ml | 11 +- compiler/ml/printtyped.ml | 3 - compiler/ml/tast_iterator.ml | 1 - compiler/ml/tast_mapper.ml | 1 - compiler/ml/typecore.ml | 83 ++++---- compiler/ml/typedtree.ml | 1 - compiler/ml/typedtree.mli | 1 - compiler/ml/typedtree_iter.ml | 3 +- compiler/syntax/src/jsx_v4.ml | 18 +- compiler/syntax/src/res_ast_debugger.ml | 15 +- compiler/syntax/src/res_comments_table.ml | 183 ++++++++---------- compiler/syntax/src/res_core.ml | 34 +--- compiler/syntax/src/res_parens.ml | 29 ++- compiler/syntax/src/res_parsetree_viewer.ml | 38 +--- compiler/syntax/src/res_parsetree_viewer.mli | 2 +- compiler/syntax/src/res_printer.ml | 44 ++++- tests/ounit_tests/ounit_ast_mapper0_tests.ml | 107 ++++++---- .../data/ast-mapping/FunctionsAndArrows.res | 3 + .../expected/FunctionsAndArrows.res.txt | 3 + .../expected/valueBindingSugar.res.txt | 4 +- .../printer/comments/valueBindingSugar.res | 5 + tests/tests/src/value_binding_constraint.mjs | 21 ++ tests/tests/src/value_binding_constraint.res | 14 ++ 45 files changed, 608 insertions(+), 388 deletions(-) create mode 100644 tests/tests/src/value_binding_constraint.mjs create mode 100644 tests/tests/src/value_binding_constraint.res diff --git a/CHANGELOG.md b/CHANGELOG.md index 81c8720b6b1..d1c3012c010 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -30,6 +30,7 @@ - Fix argument evaluation order when a function call is inlined: the beta reducer stacked argument bindings in reverse parameter order, so the last argument was evaluated first when arguments could not be substituted directly. https://github.com/rescript-lang/rescript/pull/8572 - Preserve parentheses around multiplication, division, and modulo expressions used as exponents. https://github.com/rescript-lang/rescript/pull/8550 - Make a function's locally abstract types (`(type t, x) => ...`) part of the function AST node instead of a chain of wrapper nodes. Fixes the formatter dropping the association of attributes with their `type` group (`(@attr type t, x, @attr2 type s, y)` used to print as `@attr @attr2` on the function) and comments written next to a type parameter migrating onto the following value parameter. https://github.com/rescript-lang/rescript/pull/8574 +- Preserve trailing comments between the type and `=` in locally abstract value constraints (`let f: type a. t /* comment */ = value`). https://github.com/rescript-lang/rescript/pull/8575 - 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. https://github.com/rescript-lang/rescript/pull/8559 - Fix termination-analysis false positives for functions whose progress flows through un-annotated helpers: collecting the callees of a function binding was accidentally disabled in 2024 (the collection guard required a node shape that uncurried code never produces), so helpers calling `@progress` functions were no longer added to the function table. https://github.com/rescript-lang/rescript/pull/8568 - Fix default values of optional parameters being computed at the wrong time for curried functions: in `(~x=default, y) => (~z=default, w) => ...`, `x`'s default was only computed when the *inner* function was applied. Each default is now computed when its own parameter group is applied. https://github.com/rescript-lang/rescript/pull/8568 @@ -49,6 +50,7 @@ - Sync the platform npm package's compiler binaries (`packages/@rescript//bin`) via dune promotion on every `dune build`, instead of Makefile/CI copy steps that only ran when make did: a plain `dune build` can no longer leave `cli/*.js` and the test harnesses running a stale compiler. https://github.com/rescript-lang/rescript/pull/8560 - 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 locally abstract value constraints (`let f: type a. t = value`) structural in the parsetree, remove the obsolete `Pexp_newtype` and `Texp_newtype` wrapper metadata, and keep the old encoding confined to the frozen external-PPX bridge. The CMT magic number is bumped to `Caml1999T024`. https://github.com/rescript-lang/rescript/pull/8575 - Eliminate the `Pjs_fn_make`/`Pjs_fn_make_unit` arity-adjustment primitives and the `unsafe_adjust_to_arity` machinery: with structural arity, functions are constructed at their final arity, so the enforcement layer (and the active-pattern currying split it compensated for) is deleted. Generated code improves: no adapter closures for patterns on mutable fields, better constant propagation and name preservation, and recursive modules whose members are plain functions compile statically without the runtime bootstrap. https://github.com/rescript-lang/rescript/pull/8570 - Cleanups enabled by structural arity: remove the unreachable `Too_many_arguments` error and the `?in_function` threading through the type checker that existed only to decorate it; remove the dead `function$`-vs-arrow unification bridge, `Ctype.arity`, and the unused parsetree arity helpers; deduplicate the analysis arrow-flattening helpers. https://github.com/rescript-lang/rescript/pull/8569 diff --git a/analysis/src/completion_front_end.ml b/analysis/src/completion_front_end.ml index c9e656a3ade..42115a593b5 100644 --- a/analysis/src/completion_front_end.ml +++ b/analysis/src/completion_front_end.ml @@ -769,7 +769,8 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file let old_in_jsx_context = !in_jsx_context in if Utils.is_jsx_component value_binding then in_jsx_context := true; (match value_binding with - | {pvb_pat = {ppat_desc = Ppat_constraint (_pat, core_type)}; pvb_expr} + | {pvb_pat = {ppat_desc = Ppat_constraint (_, core_type)}; pvb_expr} + | {pvb_constraint = Some {pvc_type = core_type}; pvb_expr} when loc_has_cursor pvb_expr.pexp_loc -> ( (* Expression with derivable type annotation. E.g: let x: someRecord = {} *) @@ -806,9 +807,14 @@ let completion_with_parser1 ~debug ~offset ~pos_cursor ~kind_file {context_path = CTypeAtPos loc; prefix; nested = List.rev nested}) | _ -> ()) | { - pvb_pat = {ppat_desc = Ppat_constraint (_pat, core_type); ppat_loc}; - pvb_expr; - } + pvb_pat = {ppat_desc = Ppat_constraint (_, core_type); ppat_loc}; + pvb_expr; + } + | { + pvb_pat = {ppat_loc}; + pvb_expr; + pvb_constraint = Some {pvc_type = core_type}; + } when loc_has_cursor value_binding.pvb_loc && loc_has_cursor ppat_loc = false && loc_has_cursor pvb_expr.pexp_loc = false diff --git a/analysis/src/dump_ast.ml b/analysis/src/dump_ast.ml index 14c4215e1c0..6c8fd4ed377 100644 --- a/analysis/src/dump_ast.ml +++ b/analysis/src/dump_ast.ml @@ -298,11 +298,25 @@ and print_expr_item expr ~pos ~indentation = | v -> Printf.sprintf "" (Utils.identify_pexp v) let print_value_binding value ~pos ~indentation = + let constraint_ = + match value.Parsetree.pvb_constraint with + | None -> "" + | Some {pvc_newtypes; pvc_type} -> + "\n" + ^ add_indentation indentation + ^ "constraint: type " + ^ (pvc_newtypes + |> List.map (fun ({Location.txt} as name) -> + (name |> print_loc_denominator_loc ~pos) ^ txt) + |> String.concat " ") + ^ ". " + ^ print_core_type pvc_type ~pos + in print_attributes value.Parsetree.pvb_attributes ^ "value" ^ ":\n" ^ add_indentation (indentation + 1) ^ (value.pvb_pat |> print_pattern ~pos ~indentation:(indentation + 1)) - ^ "\n" + ^ constraint_ ^ "\n" ^ add_indentation indentation ^ "expr:\n" ^ add_indentation (indentation + 1) diff --git a/analysis/src/hint.ml b/analysis/src/hint.ml index 9f696668eb4..6f0b87a34b6 100644 --- a/analysis/src/hint.ml +++ b/analysis/src/hint.ml @@ -56,6 +56,7 @@ let inlay ~source ~kind_file ~pos ~max_length ~full ~state ~debug = (match vb with | { pvb_pat = {ppat_desc = Ppat_var _}; + pvb_constraint = None; pvb_expr = { pexp_desc = @@ -125,6 +126,7 @@ let code_lens ~source ~kind_file ~full ~debug = (match vb with | { pvb_pat = {ppat_desc = Ppat_var _; ppat_loc}; + pvb_constraint = None; pvb_expr = {pexp_desc = Pexp_fun _}; } -> push ppat_loc diff --git a/analysis/src/utils.ml b/analysis/src/utils.ml index 94736c41c27..afaa4ae04fa 100644 --- a/analysis/src/utils.ml +++ b/analysis/src/utils.ml @@ -111,7 +111,6 @@ let identify_pexp pexp = | Pexp_letmodule _ -> "Pexp_letmodule" | Pexp_letexception _ -> "Pexp_letexception" | Pexp_assert _ -> "Pexp_assert" - | Pexp_newtype _ -> "Pexp_newtype" | Pexp_pack _ -> "Pexp_pack" | Pexp_extension _ -> "Pexp_extension" | Pexp_open _ -> "Pexp_open" diff --git a/analysis/src/xform.ml b/analysis/src/xform.ml index bb8fbcb04e3..3a7e4d0d483 100644 --- a/analysis/src/xform.ml +++ b/analysis/src/xform.ml @@ -322,10 +322,13 @@ module Add_type_annotation = struct match si.pstr_desc with | Pstr_value (_recFlag, bindings) -> let process_binding (vb : Parsetree.value_binding) = - (* Can't add a type annotation to a jsx component, or the compiler crashes *) - let is_jsx_component = Utils.is_jsx_component vb in - if not is_jsx_component then process_pattern vb.pvb_pat; - process_function vb.pvb_expr + match vb.pvb_constraint with + | Some _ -> () + | None -> + (* Can't add a type annotation to a jsx component, or the compiler crashes *) + let is_jsx_component = Utils.is_jsx_component vb in + if not is_jsx_component then process_pattern vb.pvb_pat; + process_function vb.pvb_expr in bindings |> List.iter process_binding; Ast_iterator.default_iterator.structure_item iterator si diff --git a/compiler/ext/config.ml b/compiler/ext/config.ml index efda9e29ae8..c44aa8392d3 100644 --- a/compiler/ext/config.ml +++ b/compiler/ext/config.ml @@ -13,6 +13,6 @@ and ast0_impl_magic_number = "Caml1999M022" and ast0_intf_magic_number = "Caml1999N022" -and cmt_magic_number = "Caml1999T023" +and cmt_magic_number = "Caml1999T024" let load_path = ref ([] : string list) diff --git a/compiler/frontend/ast_tuple_pattern_flatten.ml b/compiler/frontend/ast_tuple_pattern_flatten.ml index 165dede4478..626a4c543d2 100644 --- a/compiler/frontend/ast_tuple_pattern_flatten.ml +++ b/compiler/frontend/ast_tuple_pattern_flatten.ml @@ -45,10 +45,26 @@ let flattern_tuple_pattern_vb (self : Bs_ast_mapper.mapper) (vb : Parsetree.value_binding) (acc : Parsetree.value_binding list) : Parsetree.value_binding list = let pvb_pat = self.pat self vb.pvb_pat in + let pvb_constraint = + Option.map + (fun {Parsetree.pvc_newtypes; pvc_type} -> + { + Parsetree.pvc_newtypes = + List.map + (fun (name : string Asttypes.loc) -> + {name with loc = self.location self name.loc}) + pvc_newtypes; + pvc_type = self.typ self pvc_type; + }) + vb.pvb_constraint + in let pvb_expr = self.expr self vb.pvb_expr in let pvb_attributes = self.attributes self vb.pvb_attributes in - match (pvb_pat.ppat_desc, pvb_expr.pexp_desc) with - | Ppat_tuple xs, _ when List.for_all is_simple_pattern xs -> ( + match (pvb_constraint, pvb_pat.ppat_desc, pvb_expr.pexp_desc) with + | Some _, _, _ -> + {pvb_pat; pvb_expr; pvb_constraint; pvb_loc = vb.pvb_loc; pvb_attributes} + :: acc + | None, Ppat_tuple xs, _ when List.for_all is_simple_pattern xs -> ( match Ast_open_cxt.destruct_open_tuple pvb_expr [] with | Some (wholes, es, tuple_attributes) when Ext_list.for_all xs is_simple_pattern && Ext_list.same_length es xs @@ -59,16 +75,20 @@ let flattern_tuple_pattern_vb (self : Bs_ast_mapper.mapper) { pvb_pat = pat; pvb_expr = Ast_open_cxt.restore_exp exp wholes; + pvb_constraint = None; pvb_attributes; pvb_loc = vb.pvb_loc; } :: acc) - | _ -> {pvb_pat; pvb_expr; pvb_loc = vb.pvb_loc; pvb_attributes} :: acc) - | Ppat_record (_, _, Some rest), Pexp_pack {pmod_desc = Pmod_ident _} -> + | _ -> + {pvb_pat; pvb_expr; pvb_constraint; pvb_loc = vb.pvb_loc; pvb_attributes} + :: acc) + | None, Ppat_record (_, _, Some rest), Pexp_pack {pmod_desc = Pmod_ident _} -> Location.raise_errorf ~loc:rest.rest_loc "Record rest patterns are not supported when destructuring modules. Bind \ the module fields explicitly." - | Ppat_record (lid_pats, _, None), Pexp_pack {pmod_desc = Pmod_ident id} -> + | None, Ppat_record (lid_pats, _, None), Pexp_pack {pmod_desc = Pmod_ident id} + -> Ext_list.map_append lid_pats acc (fun {lid; x = pat} -> match lid.txt with | Lident s -> @@ -77,13 +97,16 @@ let flattern_tuple_pattern_vb (self : Bs_ast_mapper.mapper) pvb_expr = Ast_helper.Exp.ident ~loc:lid.loc {lid with txt = Ldot (id.txt, s)}; + pvb_constraint = None; pvb_attributes = []; pvb_loc = pat.ppat_loc; } | _ -> Location.raise_errorf ~loc:lid.loc "Not supported pattern match on modules") - | _ -> {pvb_pat; pvb_expr; pvb_loc = vb.pvb_loc; pvb_attributes} :: acc + | _ -> + {pvb_pat; pvb_expr; pvb_constraint; pvb_loc = vb.pvb_loc; pvb_attributes} + :: acc let value_bindings_mapper (self : Bs_ast_mapper.mapper) (vbs : Parsetree.value_binding list) = diff --git a/compiler/frontend/ast_uncurry_gen.ml b/compiler/frontend/ast_uncurry_gen.ml index 217cc313d27..44ff3790968 100644 --- a/compiler/frontend/ast_uncurry_gen.ml +++ b/compiler/frontend/ast_uncurry_gen.ml @@ -25,7 +25,7 @@ open Ast_helper (* Handling `fun [@this]` used in `object [@bs] end` *) -let to_method_callback ~async loc (self : Bs_ast_mapper.mapper) +let to_method_callback ~async ~newtypes loc (self : Bs_ast_mapper.mapper) (params : Parsetree.fun_param list) body : Parsetree.expression_desc = match params with | [] -> assert false @@ -53,7 +53,7 @@ let to_method_callback ~async loc (self : Bs_ast_mapper.mapper) let arity = List.length mapped_params in let body = Ast_async.make_function_async ~async - (Ast_helper.Exp.fun_ ~loc ~async mapped_params result) + (Ast_helper.Exp.fun_ ~loc ~async ~newtypes mapped_params result) in let arity_s = string_of_int arity in Stack.pop Js_config.self_stack |> ignore; diff --git a/compiler/frontend/ast_uncurry_gen.mli b/compiler/frontend/ast_uncurry_gen.mli index 2e7ea41c8fd..362a7133c4a 100644 --- a/compiler/frontend/ast_uncurry_gen.mli +++ b/compiler/frontend/ast_uncurry_gen.mli @@ -24,6 +24,7 @@ val to_method_callback : async:bool -> + newtypes:(string Asttypes.loc * Parsetree.attributes) list -> Location.t -> Bs_ast_mapper.mapper -> Parsetree.fun_param list -> diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml index 07287bfdedc..d8c6498c085 100644 --- a/compiler/frontend/bs_ast_mapper.ml +++ b/compiler/frontend/bs_ast_mapper.ml @@ -388,8 +388,6 @@ module E = struct (sub.extension_constructor sub cd) (sub.expr sub e) | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) | Pexp_open (ovf, lid, e) -> open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) @@ -538,8 +536,19 @@ let default_mapper = ~loc:(this.location this pincl_loc) ~attrs:(this.attributes this pincl_attributes)); value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk (this.pat this pvb_pat) (this.expr this pvb_expr) + (fun this {pvb_pat; pvb_expr; pvb_constraint; pvb_attributes; pvb_loc} -> + let pvb_pat = this.pat this pvb_pat in + let constraint_ = + Option.map + (fun {pvc_newtypes; pvc_type} -> + { + pvc_newtypes = List.map (map_loc this) pvc_newtypes; + pvc_type = this.typ this pvc_type; + }) + pvb_constraint + in + let pvb_expr = this.expr this pvb_expr in + Vb.mk pvb_pat pvb_expr ?constraint_ ~loc:(this.location this pvb_loc) ~attrs:(this.attributes this pvb_attributes)); (* #if true then *) diff --git a/compiler/frontend/bs_builtin_ppx.ml b/compiler/frontend/bs_builtin_ppx.ml index 24a8d7adb71..b71c3d2524c 100644 --- a/compiler/frontend/bs_builtin_ppx.ml +++ b/compiler/frontend/bs_builtin_ppx.ml @@ -92,9 +92,6 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) | Pexp_constant (Pconst_integer (s, Some 'l')) -> {e with pexp_desc = Pexp_constant (Pconst_integer (s, None))} (* End rewriting *) - | Pexp_newtype (s, body) -> - let res = self.expr self body in - {e with pexp_desc = Pexp_newtype (s, res)} | Pexp_fun {newtypes; params; body; async} -> ( match Ast_attributes.process_attributes_rev e.pexp_attributes with | Nothing, _ -> @@ -131,14 +128,12 @@ 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 params - body; + Ast_uncurry_gen.to_method_callback ~async ~newtypes e.pexp_loc self + params body; pexp_attributes; } in - (* Keep the locally abstract types in scope around the callback. *) - Ext_list.fold_right newtypes callback (fun (name, nt_attrs) acc -> - Ast_helper.Exp.newtype ~loc:e.pexp_loc ~attrs:nt_attrs name acc)) + callback) | Pexp_apply _ -> Ast_exp_apply.app_exp_mapper e self | Pexp_match ( b, @@ -193,6 +188,7 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) ({txt = Lident ("None" as variant_name)}, None) ); } as pvb_pat; pvb_expr; + pvb_constraint = None; pvb_attributes; }; ], @@ -305,6 +301,7 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) ( {ppat_desc = Ppat_record _} | {ppat_desc = Ppat_alias ({ppat_desc = Ppat_record _}, _)} ) as p; pvb_expr; + pvb_constraint = None; pvb_attributes; pvb_loc = _; }; @@ -519,6 +516,7 @@ let structure_item_mapper (self : mapper) (str : Parsetree.structure_item) : { pvb_pat = {ppat_desc = Ppat_var pval_name} as pvb_pat; pvb_expr; + pvb_constraint = None; pvb_attributes; pvb_loc; }; @@ -592,7 +590,16 @@ let structure_item_mapper (self : mapper) (str : Parsetree.structure_item) : str with pstr_desc = Pstr_value - (Nonrecursive, [{pvb_pat; pvb_expr; pvb_attributes; pvb_loc}]); + ( Nonrecursive, + [ + { + pvb_pat; + pvb_expr; + pvb_constraint = None; + pvb_attributes; + pvb_loc; + }; + ] ); }) | Pstr_attribute ({txt = "config"}, _) -> str | _ -> default_mapper.structure_item self str @@ -742,7 +749,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 {body = expr} | Pexp_newtype (_, expr) -> aux expr + | Pexp_fun {body = 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 1764c89d000..9ed8e1b4522 100644 --- a/compiler/ml/ast_async.ml +++ b/compiler/ml/ast_async.ml @@ -1,7 +1,6 @@ -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 | _ -> false let add_promise_type ?(loc = Location.none) ~async diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index bb19e9b1e1b..6173f084bb4 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -191,7 +191,6 @@ module Exp = struct let letmodule ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_letmodule (a, b, c)) let letexception ?loc ?attrs a b = mk ?loc ?attrs (Pexp_letexception (a, b)) let assert_ ?loc ?attrs a = mk ?loc ?attrs (Pexp_assert a) - let newtype ?loc ?attrs a b = mk ?loc ?attrs (Pexp_newtype (a, b)) let pack ?loc ?attrs a = mk ?loc ?attrs (Pexp_pack a) let open_ ?loc ?attrs a b c = mk ?loc ?attrs (Pexp_open (a, b, c)) let extension ?loc ?attrs a = mk ?loc ?attrs (Pexp_extension a) @@ -358,8 +357,14 @@ module Incl = struct end module Vb = struct - let mk ?(loc = !default_loc) ?(attrs = []) pat expr = - {pvb_pat = pat; pvb_expr = expr; pvb_attributes = attrs; pvb_loc = loc} + let mk ?(loc = !default_loc) ?(attrs = []) ?constraint_ pat expr = + { + pvb_pat = pat; + pvb_expr = expr; + pvb_constraint = constraint_; + pvb_attributes = attrs; + pvb_loc = loc; + } end module Type = struct diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index 652d248ab5e..5edb575003e 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -215,7 +215,6 @@ module Exp : sig expression -> expression val assert_ : ?loc:loc -> ?attrs:attrs -> expression -> expression - val newtype : ?loc:loc -> ?attrs:attrs -> str -> expression -> expression val pack : ?loc:loc -> ?attrs:attrs -> module_expr -> expression val open_ : ?loc:loc -> ?attrs:attrs -> override_flag -> lid -> expression -> expression @@ -446,5 +445,11 @@ end (** Value bindings *) module Vb : sig - val mk : ?loc:loc -> ?attrs:attrs -> pattern -> expression -> value_binding + val mk : + ?loc:loc -> + ?attrs:attrs -> + ?constraint_:value_constraint -> + pattern -> + expression -> + value_binding end diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index 46777f25df4..710a4bcedb4 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -369,7 +369,6 @@ module E = struct sub.extension_constructor sub cd; sub.expr sub e | Pexp_assert e -> sub.expr sub e - | Pexp_newtype (_s, e) -> sub.expr sub e | Pexp_pack me -> sub.module_expr sub me | Pexp_open (_ovf, lid, e) -> iter_loc sub lid; @@ -504,8 +503,13 @@ let default_iterator = this.location this pincl_loc; this.attributes this pincl_attributes); value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> + (fun this {pvb_pat; pvb_expr; pvb_constraint; pvb_attributes; pvb_loc} -> this.pat this pvb_pat; + Option.iter + (fun {pvc_newtypes; pvc_type} -> + List.iter (iter_loc this) pvc_newtypes; + this.typ this pvc_type) + pvb_constraint; this.expr this pvb_expr; this.location this pvb_loc; this.attributes this pvb_attributes); diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index cde7ccfa34d..e48752fb429 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -357,8 +357,6 @@ module E = struct (sub.extension_constructor sub cd) (sub.expr sub e) | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) | Pexp_open (ovf, lid, e) -> open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) @@ -499,8 +497,19 @@ let default_mapper = ~loc:(this.location this pincl_loc) ~attrs:(this.attributes this pincl_attributes)); value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk (this.pat this pvb_pat) (this.expr this pvb_expr) + (fun this {pvb_pat; pvb_expr; pvb_constraint; pvb_attributes; pvb_loc} -> + let pvb_pat = this.pat this pvb_pat in + let constraint_ = + Option.map + (fun {pvc_newtypes; pvc_type} -> + { + pvc_newtypes = List.map (map_loc this) pvc_newtypes; + pvc_type = this.typ this pvc_type; + }) + pvb_constraint + in + let pvb_expr = this.expr this pvb_expr in + Vb.mk pvb_pat pvb_expr ?constraint_ ~loc:(this.location this pvb_loc) ~attrs:(this.attributes this pvb_attributes)); constructor_declaration = diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index 2f4166b86ac..2ea1792a856 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -786,9 +786,8 @@ module E = struct newtype's attributes, except on this outermost wrapper: attributes before the internal [_res.newtype_attrs] marker (or all of them, when there is no marker) are function-node - attributes, the ones after the marker belong to the first - newtype. Chains over anything else (e.g. the - [let f: type t. ...] sugar) keep their [Pexp_newtype] nodes. *) + attributes, and those after the marker belong to the first + newtype. *) let node_attrs, first_nt_attrs = let rec split acc = function | ({txt = "_res.newtype_attrs"}, _) :: rest -> (List.rev acc, rest) @@ -807,6 +806,14 @@ module E = struct Some (List.rev acc, e0) | _ -> None in + let unsupported () = + extension ~loc ~attrs + (Ast_mapper.extension_of_error + (Location.errorf ~loc + "A PPX returned a locally abstract type wrapper that does not \ + enclose a ReScript function. This v0 AST form is not \ + supported.")) + in match gather [(map_loc sub s, first_nt_attrs)] e with | Some (newtypes, base) -> ( let base1 = sub.expr sub base in @@ -817,18 +824,8 @@ module E = struct pexp_attributes = base1.pexp_attributes @ node_attrs; pexp_loc = loc; } - | _ -> ( - (* PPX-mangled Function$: keep the wrapper chain as-is. *) - match newtypes with - | [] -> assert false - | (n0, _) :: rest -> - let inner = - List.fold_right - (fun (n, a) acc -> newtype ~loc ~attrs:a n acc) - rest base1 - in - newtype ~loc ~attrs n0 inner)) - | None -> newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e)) + | _ -> unsupported ()) + | None -> unsupported ()) | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) | Pexp_open (ovf, lid, e) -> open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) @@ -944,9 +941,57 @@ let default_mapper = ~attrs:(this.attributes this pincl_attributes)); value_binding = (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk (this.pat this pvb_pat) (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes)); + let decoded = + match pvb_pat with + | { + ppat_desc = + Ppat_constraint + ( pat, + { + ptyp_desc = Ptyp_poly (poly_newtypes, poly_type); + ptyp_attributes = []; + } ); + ppat_attributes = []; + } + when poly_newtypes <> [] -> ( + let rec gather_newtypes acc (expr : Parsetree0.expression) = + match expr with + | {pexp_desc = Pexp_newtype (newtype, rest); pexp_attributes = []} + -> + gather_newtypes (newtype :: acc) rest + | {pexp_desc = Pexp_constraint (expr, typ); pexp_attributes = []} + -> + Some (List.rev acc, expr, typ) + | _ -> None + in + match gather_newtypes [] pvb_expr with + | Some (newtypes, expr, typ) + when List.map (fun {txt} -> txt) newtypes + = List.map (fun {txt} -> txt) poly_newtypes + && + try + Ast_helper0.Typ.varify_constructors newtypes typ + = poly_type + with Syntaxerr.Error _ -> false -> + Some (pat, expr, newtypes, typ) + | _ -> None) + | _ -> None + in + match decoded with + | Some (pat, expr, newtypes, typ) -> + let constraint_ = + { + Pt.pvc_newtypes = List.map (map_loc this) newtypes; + pvc_type = this.typ this typ; + } + in + Vb.mk (this.pat this pat) (this.expr this expr) ~constraint_ + ~loc:(this.location this pvb_loc) + ~attrs:(this.attributes this pvb_attributes) + | None -> + Vb.mk (this.pat this pvb_pat) (this.expr this pvb_expr) + ~loc:(this.location this pvb_loc) + ~attrs:(this.attributes this pvb_attributes)); constructor_declaration = (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> Type.constructor (map_loc this pcd_name) diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 649cae98c61..fa5c3c16dcb 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -602,8 +602,6 @@ module E = struct (sub.extension_constructor sub cd) (sub.expr sub e) | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) - | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) | Pexp_open (ovf, lid, e) -> open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) @@ -792,10 +790,33 @@ let default_mapper = ~loc:(this.location this pincl_loc) ~attrs:(this.attributes this pincl_attributes)); value_binding = - (fun this {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} -> - Vb.mk (this.pat this pvb_pat) (this.expr this pvb_expr) - ~loc:(this.location this pvb_loc) - ~attrs:(this.attributes this pvb_attributes)); + (fun this {pvb_pat; pvb_expr; pvb_constraint; pvb_attributes; pvb_loc} -> + let loc = this.location this pvb_loc in + let pvb_pat, pvb_expr = + match pvb_constraint with + | None -> (this.pat this pvb_pat, this.expr this pvb_expr) + | Some {pvc_newtypes; pvc_type} -> + let poly = + Ast_helper.Typ.poly ~loc:pvb_loc pvc_newtypes + (Ast_helper.Typ.varify_constructors pvc_newtypes pvc_type) + in + let pat = + Ast_helper0.Pat.constraint_ ~loc (this.pat this pvb_pat) + (this.typ this poly) + in + let expr = + Ast_helper0.Exp.constraint_ ~loc (this.expr this pvb_expr) + (this.typ this pvc_type) + in + let expr = + List.fold_right + (fun newtype expr -> + Ast_helper0.Exp.newtype ~loc (map_loc this newtype) expr) + pvc_newtypes expr + in + (pat, expr) + in + Vb.mk pvb_pat pvb_expr ~loc ~attrs:(this.attributes this pvb_attributes)); constructor_declaration = (fun this {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} -> Type.constructor (map_loc this pcd_name) diff --git a/compiler/ml/depend.ml b/compiler/ml/depend.ml index 4ebf8950d1b..cf826136c71 100644 --- a/compiler/ml/depend.ml +++ b/compiler/ml/depend.ml @@ -285,7 +285,6 @@ let rec add_expr bv exp = add_expr (String_map.add id.txt b bv) e | Pexp_letexception (_, e) -> add_expr bv e | Pexp_assert e -> add_expr bv e - | Pexp_newtype (_, e) -> add_expr bv e | Pexp_pack m -> add_module bv m | Pexp_open (_ovf, m, e) -> let bv = open_module bv m.txt in diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index 7a41fc196e8..3cf05f79e94 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -311,7 +311,6 @@ and expression_desc = (* assert E Note: "assert false" is treated in a special way by the type-checker. *) - | Pexp_newtype of string loc * expression (* fun (type t) -> E *) | Pexp_pack of module_expr (* (module ME) @@ -670,9 +669,16 @@ and structure_item_desc = | Pstr_extension of extension * attributes (* [%%id] *) +and value_constraint = { + pvc_newtypes: string loc list; + (* Nonempty for parser-produced [let x: type a. t = e] bindings. *) + pvc_type: core_type; +} + and value_binding = { pvb_pat: pattern; pvb_expr: expression; + pvb_constraint: value_constraint option; pvb_attributes: attributes; pvb_loc: Location.t; } diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml index df2599b1bef..9077976d88c 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -780,8 +780,6 @@ and simple_expr ctxt f x = (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *) | Pexp_constant c -> constant f c | Pexp_pack me -> pp f "(module@;%a)" (module_expr ctxt) me - | Pexp_newtype (lid, e) -> - pp f "fun@;(type@;%s)@;->@;%a" lid.txt (expression ctxt) e | Pexp_tuple l -> pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l | Pexp_constraint (e, ct) -> @@ -1062,7 +1060,7 @@ and payload ctxt f = function expression ctxt f e (* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) -and binding ctxt f {pvb_pat = p; pvb_expr = x; _} = +and binding ctxt f {pvb_pat = p; pvb_expr = x; pvb_constraint; _} = (* .pvb_attributes have already been printed by the caller, #bindings *) let rec pp_print_pexp_function f x = if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x @@ -1089,8 +1087,6 @@ and binding ctxt f {pvb_pat = p; pvb_expr = x; _} = in pp f "%s%a%s%a%a" async_str pp_newtypes newtypes 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 in let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in @@ -1107,15 +1103,12 @@ and binding ctxt f {pvb_pat = p; pvb_expr = x; _} = Some (pat, args_tyvars, rt) | _ -> None in - let rec gadt_exp tyvars e = + let gadt_exp = match e with - | {pexp_desc = Pexp_newtype (tyvar, e); pexp_attributes = []} -> - gadt_exp (tyvar :: tyvars) e | {pexp_desc = Pexp_constraint (e, ct); pexp_attributes = []} -> - Some (List.rev tyvars, e, ct) + Some ([], e, ct) | _ -> None in - let gadt_exp = gadt_exp [] e in match (gadt_pattern, gadt_exp) with | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct) when tyvars_str pt_tyvars = tyvars_str e_tyvars -> @@ -1123,31 +1116,37 @@ and binding ctxt f {pvb_pat = p; pvb_expr = x; _} = if ety = pt_ct then Some (p, pt_tyvars, e_ct, e) else None | _ -> None in - if x.pexp_attributes <> [] then - pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x - else - match is_desugared_gadt p x with - | Some (p, [], ct, e) -> - pp f "%a@;: %a@;=@;%a" (simple_pattern ctxt) p (core_type ctxt) ct - (expression ctxt) e - | Some (p, tyvars, ct, e) -> - pp f "%a@;: type@;%a.@;%a@;=@;%a" (simple_pattern ctxt) p - (list pp_print_string ~sep:"@;") - (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e - | None -> ( - match p with - | {ppat_desc = Ppat_constraint (p, ty); ppat_attributes = []} -> ( - (* special case for the first*) - match ty with - | {ptyp_desc = Ptyp_poly _; ptyp_attributes = []} -> - pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p (core_type ctxt) ty - (expression ctxt) x - | _ -> - pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p (core_type ctxt) ty - (expression ctxt) x) - | {ppat_desc = Ppat_var _; ppat_attributes = []} -> - pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x - | _ -> pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x) + match pvb_constraint with + | Some {pvc_newtypes; pvc_type} -> + pp f "%a@;: type@;%a.@;%a@;=@;%a" (simple_pattern ctxt) p + (list pp_print_string ~sep:"@;") + (tyvars_str pvc_newtypes) (core_type ctxt) pvc_type (expression ctxt) x + | None -> ( + if x.pexp_attributes <> [] then + pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x + else + match is_desugared_gadt p x with + | Some (p, [], ct, e) -> + pp f "%a@;: %a@;=@;%a" (simple_pattern ctxt) p (core_type ctxt) ct + (expression ctxt) e + | Some (p, tyvars, ct, e) -> + pp f "%a@;: type@;%a.@;%a@;=@;%a" (simple_pattern ctxt) p + (list pp_print_string ~sep:"@;") + (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e + | None -> ( + match p with + | {ppat_desc = Ppat_constraint (p, ty); ppat_attributes = []} -> ( + (* special case for the first*) + match ty with + | {ptyp_desc = Ptyp_poly _; ptyp_attributes = []} -> + pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p (core_type ctxt) ty + (expression ctxt) x + | _ -> + pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p (core_type ctxt) + ty (expression ctxt) x) + | {ppat_desc = Ppat_var _; ppat_attributes = []} -> + pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x + | _ -> pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x)) (* [in] is not printed *) and bindings ctxt f (rf, l) = diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index a92f386eee3..3051e794853 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -358,9 +358,6 @@ and expression i ppf x = | Pexp_assert e -> line i ppf "Pexp_assert\n"; expression i ppf e - | Pexp_newtype (s, e) -> - line i ppf "Pexp_newtype \"%s\"\n" s.txt; - expression i ppf e | Pexp_pack me -> line i ppf "Pexp_pack\n"; module_expr i ppf me @@ -726,6 +723,14 @@ and value_binding i ppf x = line i ppf "\n"; attributes (i + 1) ppf x.pvb_attributes; pattern (i + 1) ppf x.pvb_pat; + (match x.pvb_constraint with + | None -> () + | Some {pvc_newtypes; pvc_type} -> + line (i + 1) ppf "\n"; + List.iter + (fun {txt} -> line (i + 2) ppf "newtype \"%s\"\n" txt) + pvc_newtypes; + core_type (i + 2) ppf pvc_type); expression (i + 1) ppf x.pvb_expr and longident_x_expression i ppf {lid = li; x = e; opt} = diff --git a/compiler/ml/printtyped.ml b/compiler/ml/printtyped.ml index 529b2de39c4..e5ae95b81c0 100644 --- a/compiler/ml/printtyped.ml +++ b/compiler/ml/printtyped.ml @@ -263,9 +263,6 @@ and expression_extra i ppf x attrs = | Texp_open (ovf, m, _, _) -> line i ppf "Texp_open %a \"%a\"\n" fmt_override_flag ovf fmt_path m; attributes i ppf attrs - | Texp_newtype s -> - line i ppf "Texp_newtype \"%s\"\n" s; - attributes i ppf attrs and expression i ppf x = line i ppf "expression %a\n" fmt_location x.exp_loc; diff --git a/compiler/ml/tast_iterator.ml b/compiler/ml/tast_iterator.ml index 9c8441fb986..fcc25510d7c 100644 --- a/compiler/ml/tast_iterator.ml +++ b/compiler/ml/tast_iterator.ml @@ -140,7 +140,6 @@ let expr sub {exp_extra; exp_desc; exp_env; _} = let extra = function | Texp_constraint cty -> sub.typ sub cty | Texp_coerce cty2 -> sub.typ sub cty2 - | Texp_newtype _ -> () | Texp_open (_, _, _, _) -> () in List.iter (fun (e, _, _) -> extra e) exp_extra; diff --git a/compiler/ml/tast_mapper.ml b/compiler/ml/tast_mapper.ml index 0cfdc3e86cc..cbf0c45b5fa 100644 --- a/compiler/ml/tast_mapper.ml +++ b/compiler/ml/tast_mapper.ml @@ -185,7 +185,6 @@ let expr sub x = | Texp_coerce cty2 -> Texp_coerce (sub.typ sub cty2) | Texp_open (ovf, path, loc, env) -> Texp_open (ovf, path, loc, sub.env sub env) - | Texp_newtype _ as d -> d in let exp_extra = List.map (tuple3 extra id id) x.exp_extra in let exp_env = sub.env sub x.exp_env in diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index cdc0913255d..d80d100e2b2 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -182,7 +182,6 @@ let iter_expression f e = may expr eo; List.iter (fun {x = e} -> expr e) iel | Pexp_open (_, _, e) - | Pexp_newtype (_, e) | Pexp_assert e | Pexp_send (e, _) | Pexp_constraint (e, _) @@ -2468,12 +2467,10 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp } | Pexp_fun {newtypes = _ :: _ as newtypes; params; body = sfun_body; async} -> (* Bring the function's locally abstract types into scope, innermost - last, typing the newtype-free function inside all of them - the same - nesting a chain of [Pexp_newtype] wrappers produced. Each group's - attributes open a warning scope over everything within its scope, - as the attributes on the former wrapper nodes did. The function - node's own attributes stay on the inner dispatch only, so its - warning scope is entered once, not once per newtype. *) + last, typing the newtype-free function inside all of them. Each + group's attributes open a warning scope over everything within its + scope. The function node's own attributes stay on the inner call + only, so its warning scope is entered once, not once per newtype. *) let rec peel env = function | [] -> (* The newtype-free function, typed directly against a fresh @@ -2484,8 +2481,8 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp sfun_body | (name, nt_attrs) :: rest -> Builtin_attributes.warning_scope nt_attrs (fun () -> - type_newtype ~loc ~env ~name:name.Asttypes.txt ~attrs:nt_attrs - (fun new_env -> peel new_env rest)) + type_newtype ~loc ~env ~name:name.Asttypes.txt (fun new_env -> + peel new_env rest)) in rue (peel env newtypes) | Pexp_fun {newtypes = []; params; body = sfun_body; async} -> @@ -3415,10 +3412,6 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp exp_attributes = sexp.pexp_attributes; exp_env = env; } - | Pexp_newtype ({txt = name}, sbody) -> - rue - (type_newtype ~loc ~env ~name ~attrs:sexp.pexp_attributes (fun new_env -> - type_exp ~context:None new_env sbody)) | Pexp_pack m -> let p, nl = match Ctype.expand_head env (instance env ty_expected) with @@ -3480,11 +3473,10 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp (* Type [type_body] with the locally abstract type [name] in scope: a fresh abstract type constructor is entered into the environment, and every occurrence of it in the result type is replaced by a type - variable afterwards. Used both for [Pexp_newtype] nodes and for the - [newtypes] of a function. The result still needs to be unified with - the expected type by the caller. *) -and type_newtype ~loc ~env ~name ~attrs - (type_body : Env.t -> Typedtree.expression) = + variable afterwards. Used for structurally represented locally abstract + type binders. The result still needs to be unified with the expected type + by the caller. *) +and type_newtype ~loc ~env ~name (type_body : Env.t -> Typedtree.expression) = let ty = newvar () in (* remember original level *) begin_def (); @@ -3530,14 +3522,9 @@ and type_newtype ~loc ~env ~name ~attrs (* lower the levels of the result type *) (* unify_var env ty ety; *) - (* non-expansive if the body is non-expansive, so we don't introduce - any new extra node in the typed AST. *) - { - body with - exp_loc = loc; - exp_type = ety; - exp_extra = (Texp_newtype name, loc, attrs) :: body.exp_extra; - } + (* Locally abstract type binders affect typing only; they do not introduce + an expression node in the typed tree. *) + {body with exp_loc = loc; exp_type = ety} and type_function ~async loc attrs env ty_expected_ (sparams : Parsetree.fun_param list) sbody = @@ -4513,6 +4500,20 @@ and type_cases ~(call_context : [`LetUnwrap | `Switch | `Function | `Try]) env and type_let ~context ?(check = fun s -> Warnings.Unused_var s) ?(check_strict = fun s -> Warnings.Unused_var_strict s) env rec_flag spat_sexp_list scope allow = + let spat_sexp_list = + List.map + (fun (vb : Parsetree.value_binding) -> + match vb.pvb_constraint with + | None -> vb + | Some {pvc_newtypes; pvc_type} -> + let loc = vb.pvb_loc in + let poly = + Ast_helper.Typ.poly ~loc pvc_newtypes + (Ast_helper.Typ.varify_constructors pvc_newtypes pvc_type) + in + {vb with pvb_pat = Ast_helper.Pat.constraint_ ~loc vb.pvb_pat poly}) + spat_sexp_list + in begin_def (); let is_fake_let = match spat_sexp_list with @@ -4632,25 +4633,39 @@ and type_let ~context ?(check = fun s -> Warnings.Unused_var s) in let exp_list = List.map2 - (fun {pvb_expr = sexp; pvb_attributes; _} (pat, slot) -> + (fun {pvb_expr = sexp; pvb_constraint; pvb_attributes; pvb_loc; _} + (pat, slot) -> let sexp = if rec_flag = Recursive then wrap_unpacks sexp unpacks else sexp in if is_recursive then current_slot := slot; + let type_expression expected = + Builtin_attributes.warning_scope pvb_attributes (fun () -> + match pvb_constraint with + | None -> type_expect ~context exp_env sexp expected + | Some {pvc_newtypes; pvc_type} -> + let constrained = + Ast_helper.Exp.constraint_ ~loc:pvb_loc sexp pvc_type + in + let rec scope env = function + | [] -> type_exp ~context env constrained + | {txt = name} :: rest -> + type_newtype ~loc:pvb_loc ~env ~name (fun env -> + scope env rest) + in + let exp = scope exp_env pvc_newtypes in + unify_exp ~context exp_env exp (instance exp_env expected); + exp) + in match pat.pat_type.desc with | Tpoly (ty, tl) -> begin_def (); let vars, ty' = instance_poly ~keep_names:true true tl ty in - let exp = - Builtin_attributes.warning_scope pvb_attributes (fun () -> - type_expect ~context exp_env sexp ty') - in + let exp = type_expression ty' in end_def (); check_univars env true "definition" exp pat.pat_type vars; {exp with exp_type = instance env exp.exp_type} - | _ -> - Builtin_attributes.warning_scope pvb_attributes (fun () -> - type_expect ~context exp_env sexp pat.pat_type)) + | _ -> type_expression pat.pat_type) spat_sexp_list pat_slot_list in current_slot := None; diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index 91cd31774e3..a220dccb36c 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -76,7 +76,6 @@ and exp_extra = | Texp_constraint of core_type | Texp_coerce of core_type | Texp_open of override_flag * Path.t * Longident.t loc * Env.t - | Texp_newtype of string and expression_desc = | Texp_ident of Path.t * Longident.t loc * Types.value_description diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index f4d4b6cb7a7..74e20acb956 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -123,7 +123,6 @@ and exp_extra = (** let open[!] M in [Texp_open (!, P, M, env)] where [env] is the environment after opening [P] *) - | Texp_newtype of string (** fun (type t) -> *) and expression_desc = | Texp_ident of Path.t * Longident.t loc * Types.value_description diff --git a/compiler/ml/typedtree_iter.ml b/compiler/ml/typedtree_iter.ml index 6ad85a37e06..378891ce04e 100644 --- a/compiler/ml/typedtree_iter.ml +++ b/compiler/ml/typedtree_iter.ml @@ -217,8 +217,7 @@ end = struct match cstr with | Texp_constraint ct -> iter_core_type ct | Texp_coerce cty2 -> iter_core_type cty2 - | Texp_open _ -> () - | Texp_newtype _ -> ())) + | Texp_open _ -> ())) exp.exp_extra; (match exp.exp_desc with | Texp_ident _ -> () diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index a71a03073d6..ccc31703642 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -245,9 +245,6 @@ let rec recursively_transform_named_args_for_make expr args newtypes core_type = (* Collected newtypes are accumulated in reverse source order. *) let newtypes = List.rev_append fun_newtypes newtypes in 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) @@ -397,7 +394,7 @@ let modified_binding_old binding = let rec spelunk_for_fun_expression expression = match expression with (* let make = (~prop) => ... *) - | {pexp_desc = Pexp_fun _} | {pexp_desc = Pexp_newtype _} -> expression + | {pexp_desc = Pexp_fun _} -> expression (* let make = {let foo = bar in (~prop) => ...} *) | {pexp_desc = Pexp_let (_recursive, _vbs, return_expression)} -> (* here's where we spelunk! *) @@ -553,8 +550,6 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name binding = expr with 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)} | Pexp_constraint (inner, _) -> let constrained_inner = constrain_jsx_return inner in jsx_element_constraint constrained_inner @@ -569,6 +564,12 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name binding = in if Jsx_common.has_attr_on_binding Jsx_common.has_attr binding then ( check_multiple_components ~config ~loc:pstr_loc; + let binding_newtypes, binding_core_type = + match binding.pvb_constraint with + | None -> ([], None) + | Some {pvc_newtypes; pvc_type} -> + (List.rev_map (fun name -> (name, [])) pvc_newtypes, Some pvc_type) + in let core_type_of_attr = Jsx_common.core_type_of_attrs binding.pvb_attributes in @@ -583,6 +584,7 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name binding = { binding with pvb_pat = {binding.pvb_pat with ppat_loc = empty_loc}; + pvb_constraint = None; pvb_loc = empty_loc; pvb_attributes = binding.pvb_attributes |> List.filter other_attrs_pure; } @@ -598,7 +600,7 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name binding = let named_arg_list, newtypes, _typeConstraints = recursively_transform_named_args_for_make (modified_binding_old binding) - [] [] None + [] binding_newtypes binding_core_type in let named_type_list = List.fold_left arg_to_type [] named_arg_list in (* type props = { ... } *) @@ -679,8 +681,6 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name binding = let rec returned_expression patterns_with_label patterns_with_nolabel ({pexp_desc} as expr) = match pexp_desc with - | Pexp_newtype (_, expr) -> - returned_expression patterns_with_label patterns_with_nolabel expr | Pexp_constraint (expr, _) -> returned_expression patterns_with_label patterns_with_nolabel expr | Pexp_fun {params; body} -> diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index 3f2eb9a949e..2b64cdecf0a 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -392,6 +392,18 @@ module Sexp_ast = struct [ Sexp.atom "value_binding"; pattern vb.pvb_pat; + (match vb.pvb_constraint with + | None -> Sexp.atom "None" + | Some {pvc_newtypes; pvc_type} -> + Sexp.list + [ + Sexp.atom "Some"; + Sexp.list + (map_empty + ~f:(fun ({txt} : string Asttypes.loc) -> string txt) + pvc_newtypes); + core_type pvc_type; + ]); expression vb.pvb_expr; attributes vb.pvb_attributes; ] @@ -721,9 +733,6 @@ module Sexp_ast = struct expression expr; ] | Pexp_assert expr -> Sexp.list [Sexp.atom "Pexp_assert"; expression expr] - | Pexp_newtype (lbl, expr) -> - Sexp.list - [Sexp.atom "Pexp_newtype"; string lbl.Asttypes.txt; expression expr] | Pexp_pack mod_expr -> Sexp.list [Sexp.atom "Pexp_pack"; module_expression mod_expr] | Pexp_open (flag, longident_loc, expr) -> diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index 841640bb01e..3d8c0c6e9e4 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -374,26 +374,6 @@ let fun_expr expr = |> List.map (fun ((name : string Location.loc), attrs) -> (attrs, Asttypes.Nolabel, None, Ast_helper.Pat.var ~loc:name.loc name)) in - (* Turns (type t, type u, type z) into "type t u z" *) - let rec collect_new_types acc return_expr = - match return_expr with - | {pexp_desc = Pexp_newtype (string_loc, return_expr); pexp_attributes = []} - -> - collect_new_types (string_loc :: acc) return_expr - | return_expr -> - let loc = - match (acc, List.rev acc) with - | _startLoc :: _, end_loc :: _ -> - {end_loc.loc with loc_end = end_loc.loc.loc_end} - | _ -> Location.none - in - let txt = - List.fold_right - (fun curr acc -> acc ^ " " ^ curr.Location.txt) - acc "type" - in - (Location.mkloc txt loc, return_expr) - in let params_of params = params |> List.map (fun {p_attrs; p_lbl; p_default; p_pat} -> @@ -408,18 +388,6 @@ let fun_expr expr = params in match expr with - | {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 {newtypes; params; body}; pexp_attributes = []} -> - ( [], - newtype_param - :: in_source_order (newtype_params newtypes @ params_of params), - body ) - | return_expr -> ([], [newtype_param], return_expr)) | {pexp_desc = Pexp_fun {newtypes; params; body}; pexp_attributes = attrs} -> (attrs, in_source_order (newtype_params newtypes @ params_of params), body) | expr -> ([], [], expr) @@ -912,80 +880,85 @@ and walk_constructor_arguments args t comments = and walk_value_binding vb t comments = let open Location in - let vb = - let open Parsetree in - match (vb.pvb_pat, vb.pvb_expr) with - | ( {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly ([], t)})}, - {pexp_desc = Pexp_constraint (expr, _typ)} ) -> - { - vb with - pvb_pat = - Ast_helper.Pat.constraint_ - ~loc:{pat.ppat_loc with loc_end = t.Parsetree.ptyp_loc.loc_end} - pat t; - pvb_expr = expr; - } - | ( {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly (_ :: _, t)})}, - {pexp_desc = Pexp_fun _} ) -> - { - vb with - pvb_pat = - { - vb.pvb_pat with - ppat_loc = {pat.ppat_loc with loc_end = t.ptyp_loc.loc_end}; - }; - } - | ( ({ - ppat_desc = - Ppat_constraint (pat, ({ptyp_desc = Ptyp_poly (_ :: _, t)} as typ)); - } as constrained_pattern), - {pexp_desc = Pexp_newtype (_, {pexp_desc = Pexp_constraint (expr, _)})} - ) -> - (* - * The location of the Ptyp_poly on the pattern is the whole thing. - * let x: - * type t. (int, int) => int = - * (a, b) => { - * // comment - * a + b - * } - *) - { - vb with - pvb_pat = - { - constrained_pattern with - ppat_desc = Ppat_constraint (pat, typ); - ppat_loc = - {constrained_pattern.ppat_loc with loc_end = t.ptyp_loc.loc_end}; - }; - pvb_expr = expr; - } - | _ -> vb + let walk_expression_after previous_loc expr comments = + let after_previous, surrounding_expr = + partition_adjacent_trailing previous_loc comments + in + attach t.trailing previous_loc after_previous; + let before_expr, inside_expr, after_expr = + partition_by_loc surrounding_expr expr.Parsetree.pexp_loc + in + if is_block_expr expr then + walk_expression expr t + (List.concat [before_expr; inside_expr; after_expr]) + else ( + attach t.leading expr.pexp_loc before_expr; + walk_expression expr t inside_expr; + attach t.trailing expr.pexp_loc after_expr) in - let pattern_loc = vb.Parsetree.pvb_pat.ppat_loc in - let expr_loc = vb.Parsetree.pvb_expr.pexp_loc in - let expr = vb.pvb_expr in - - let leading, inside, trailing = partition_by_loc comments pattern_loc in - - (* everything before start of pattern can only be leading on the pattern: - * let |* before *| a = 1 *) - attach t.leading pattern_loc leading; - walk_pattern vb.Parsetree.pvb_pat t inside; - let after_pat, surrounding_expr = - partition_adjacent_trailing pattern_loc trailing - in - attach t.trailing pattern_loc after_pat; - let before_expr, inside_expr, after_expr = - partition_by_loc surrounding_expr expr_loc + let walk_pattern pattern comments = + let leading, inside, trailing = + partition_by_loc comments pattern.Parsetree.ppat_loc + in + attach t.leading pattern.ppat_loc leading; + walk_pattern pattern t inside; + let after_pattern, rest = + partition_adjacent_trailing pattern.ppat_loc trailing + in + attach t.trailing pattern.ppat_loc after_pattern; + rest in - if is_block_expr expr then - walk_expression expr t (List.concat [before_expr; inside_expr; after_expr]) - else ( - attach t.leading expr_loc before_expr; - walk_expression expr t inside_expr; - attach t.trailing expr_loc after_expr) + match vb.Parsetree.pvb_constraint with + | Some {pvc_newtypes; pvc_type} -> + let comments = walk_pattern vb.pvb_pat comments in + let comments = + visit_list_but_continue_with_remaining_comments + ~get_loc:(fun (newtype : string loc) -> newtype.loc) + ~walk_node:(fun (newtype : string loc) t comments -> + let leading, trailing = + partition_leading_trailing comments newtype.loc + in + attach t.leading newtype.loc leading; + attach t.trailing newtype.loc trailing) + ~newline_delimited:false pvc_newtypes t comments + in + let before_type, inside_type, after_type = + partition_by_loc comments pvc_type.ptyp_loc + in + attach t.leading pvc_type.ptyp_loc before_type; + walk_core_type pvc_type t inside_type; + walk_expression_after pvc_type.ptyp_loc vb.pvb_expr after_type + | None -> + let vb = + let open Parsetree in + match (vb.pvb_pat, vb.pvb_expr) with + | ( {ppat_desc = Ppat_constraint (pat, {ptyp_desc = Ptyp_poly ([], t)})}, + {pexp_desc = Pexp_constraint (expr, _typ)} ) -> + { + vb with + pvb_pat = + Ast_helper.Pat.constraint_ + ~loc:{pat.ppat_loc with loc_end = t.Parsetree.ptyp_loc.loc_end} + pat t; + pvb_expr = expr; + } + | ( { + ppat_desc = + Ppat_constraint (pat, {ptyp_desc = Ptyp_poly (_ :: _, t)}); + }, + {pexp_desc = Pexp_fun _} ) -> + { + vb with + pvb_pat = + { + vb.pvb_pat with + ppat_loc = {pat.ppat_loc with loc_end = t.ptyp_loc.loc_end}; + }; + } + | _ -> vb + in + let comments = walk_pattern vb.pvb_pat comments in + walk_expression_after vb.pvb_pat.ppat_loc vb.pvb_expr comments and walk_expression expr t comments = let open Location in @@ -1574,7 +1547,7 @@ and walk_expression expr t comments = | _ -> (* Regular apply handling *) walk_apply_expr call_expr arguments t comments) - | Pexp_fun _ | Pexp_newtype _ -> ( + | Pexp_fun _ -> ( let _, parameters, return_expr = fun_expr expr in let comments = visit_list_but_continue_with_remaining_comments ~newline_delimited:false diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 8e99345b19c..5d6acf97ee4 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -611,27 +611,6 @@ let lident_of_path longident = | [] -> "" | ident :: _ -> ident -let make_newtypes ~loc newtypes exp = - List.fold_right - (fun newtype exp -> Ast_helper.Exp.mk ~loc (Pexp_newtype (newtype, exp))) - newtypes exp - -(* locally abstract types syntax sugar - * Transforms - * let f: type t u v. = (foo : list) => ... - * into - * let f = (type t u v. foo : list) => ... - *) -let wrap_type_annotation ~loc newtypes core_type body = - let exp = - make_newtypes ~loc newtypes (Ast_helper.Exp.constraint_ ~loc body core_type) - in - let typ = - Ast_helper.Typ.poly ~loc newtypes - (Ast_helper.Typ.varify_constructors newtypes core_type) - in - (exp, typ) - (** * process the occurrence of _ in the arguments of a function application * replace _ with a new variable, currently __x, in the arguments @@ -2711,7 +2690,7 @@ and over_parse_constrained_or_coerced_or_arrow_expression p expr = and parse_let_binding_body ~start_pos ~attrs p = Parser.begin_region p; Parser.leave_breadcrumb p Grammar.LetBinding; - let pat, exp = + let pat, exp, constraint_ = Parser.leave_breadcrumb p Grammar.Pattern; let pat = parse_pattern p in Parser.eat_breadcrumb p; @@ -2727,10 +2706,7 @@ and parse_let_binding_body ~start_pos ~attrs p = let typ = parse_typ_expr p in Parser.expect Equal p; let expr = parse_expr p in - let loc = mk_loc start_pos p.prev_end_pos in - let exp, poly = wrap_type_annotation ~loc newtypes typ expr in - let pat = Ast_helper.Pat.constraint_ ~loc pat poly in - (pat, exp) + (pat, expr, Some {Parsetree.pvc_newtypes = newtypes; pvc_type = typ}) | _ -> let poly_type = parse_poly_type_expr p in let loc = @@ -2740,16 +2716,16 @@ and parse_let_binding_body ~start_pos ~attrs p = Parser.expect Token.Equal p; let exp = parse_expr p in let exp = over_parse_constrained_or_coerced_or_arrow_expression p exp in - (pat, exp)) + (pat, exp, None)) | _ -> Parser.expect Token.Equal p; let exp = over_parse_constrained_or_coerced_or_arrow_expression p (parse_expr p) in - (pat, exp) + (pat, exp, None) in let loc = mk_loc start_pos p.prev_end_pos in - let vb = Ast_helper.Vb.mk ~loc ~attrs pat exp in + let vb = Ast_helper.Vb.mk ~loc ~attrs ?constraint_ pat exp in Parser.eat_breadcrumb p; Parser.end_region p; vb diff --git a/compiler/syntax/src/res_parens.ml b/compiler/syntax/src/res_parens.ml index 2316399f3f7..d35777628b4 100644 --- a/compiler/syntax/src/res_parens.ml +++ b/compiler/syntax/src/res_parens.ml @@ -50,9 +50,9 @@ let call_expr expr = Nothing | { pexp_desc = - ( Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ | Pexp_constraint _ - | Pexp_setfield _ | Pexp_match _ | Pexp_try _ | Pexp_while _ | Pexp_for _ - | Pexp_for_of _ | Pexp_for_await_of _ | Pexp_ifthenelse _ ); + ( Pexp_assert _ | Pexp_fun _ | Pexp_constraint _ | Pexp_setfield _ + | Pexp_match _ | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_for_of _ + | Pexp_for_await_of _ | Pexp_ifthenelse _ ); } -> Parenthesized | _ when Parsetree_viewer.expr_is_await expr -> Parenthesized @@ -100,9 +100,9 @@ let unary_expr_operand expr = Nothing | { pexp_desc = - ( Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ | Pexp_constraint _ - | Pexp_setfield _ | Pexp_extension _ (* readability? maybe remove *) - | Pexp_match _ | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_for_of _ + ( Pexp_assert _ | Pexp_fun _ | Pexp_constraint _ | Pexp_setfield _ + | Pexp_extension _ (* readability? maybe remove *) | Pexp_match _ + | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_for_of _ | Pexp_for_await_of _ | Pexp_ifthenelse _ ); } -> Parenthesized @@ -123,8 +123,7 @@ let binary_expr_operand ~is_lhs expr = | {pexp_desc = Pexp_fun _} when Parsetree_viewer.is_underscore_apply_sugar expr -> Nothing - | {pexp_desc = Pexp_constraint _ | Pexp_fun _ | Pexp_newtype _} -> - Parenthesized + | {pexp_desc = Pexp_constraint _ | Pexp_fun _} -> 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 +180,7 @@ let flatten_operand_rhs parent_operator rhs = false | Pexp_fun {params = {p_pat = {ppat_desc = Ppat_var {txt = "__x"}}} :: _} -> false - | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ | Pexp_constraint _ -> true + | Pexp_fun _ | Pexp_setfield _ | Pexp_constraint _ -> true | _ when Parsetree_viewer.is_ternary_expr rhs -> true | _ -> false @@ -219,9 +218,9 @@ let assert_or_await_expr_rhs ?(in_await = false) expr = Nothing | { pexp_desc = - ( Pexp_assert _ | Pexp_fun _ | Pexp_newtype _ | Pexp_constraint _ - | Pexp_setfield _ | Pexp_match _ | Pexp_try _ | Pexp_while _ | Pexp_for _ - | Pexp_for_of _ | Pexp_for_await_of _ | Pexp_ifthenelse _ ); + ( Pexp_assert _ | Pexp_fun _ | Pexp_constraint _ | Pexp_setfield _ + | Pexp_match _ | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_for_of _ + | Pexp_for_await_of _ | Pexp_ifthenelse _ ); } -> Parenthesized | _ when (not in_await) && Parsetree_viewer.expr_is_await expr -> @@ -265,8 +264,8 @@ let field_expr expr = | { pexp_desc = ( Pexp_assert _ | Pexp_extension _ (* %extension.x vs (%extension).x *) - | Pexp_fun _ | Pexp_newtype _ | Pexp_constraint _ | Pexp_setfield _ - | Pexp_match _ | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_for_of _ + | Pexp_fun _ | Pexp_constraint _ | Pexp_setfield _ | Pexp_match _ + | Pexp_try _ | Pexp_while _ | Pexp_for _ | Pexp_for_of _ | Pexp_for_await_of _ | Pexp_ifthenelse _ ); } -> Parenthesized @@ -299,7 +298,7 @@ let ternary_operand expr = } -> Nothing | {pexp_desc = Pexp_constraint _} -> Parenthesized - | _ when Res_parsetree_viewer.is_fun_newtype expr -> ( + | _ when Res_parsetree_viewer.is_fun_expr expr -> ( let _, _parameters, return_expr = Parsetree_viewer.fun_expr expr in match return_expr.pexp_desc with | Pexp_constraint _ -> Parenthesized diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index fe63d5b9889..083c8b3a4e2 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -210,31 +210,7 @@ let fun_expr expr_ = group_newtypes newtypes |> List.map (fun (attrs, locs) -> NewTypes {attrs; locs}) in - (* Turns (type t, type u, type z) into "type t u z". An attribute on a - nested node (only constructible via PPX) stops the merge so the - attribute is printed on the node carrying it instead of dropped. *) - let rec collect_new_types acc return_expr = - match return_expr with - | {pexp_desc = Pexp_newtype (string_loc, return_expr); pexp_attributes = []} - -> - collect_new_types (string_loc :: acc) return_expr - | return_expr -> (List.rev acc, return_expr) - in match expr_ with - | {pexp_desc = Pexp_newtype (string_loc, rest)} -> ( - (* PPX-authored wrapper chains; the parser puts a function's newtypes - in the [newtypes] field instead. *) - let string_locs, return_expr = collect_new_types [string_loc] rest in - let newtype_param = NewTypes {attrs = []; locs = string_locs} in - match return_expr with - | { - pexp_desc = Pexp_fun {newtypes; params; body; async}; - pexp_attributes = []; - } -> - ( async, - (newtype_param :: newtype_params newtypes) @ params_of_fun params, - body ) - | _ -> (false, [newtype_param], return_expr)) | {pexp_desc = Pexp_fun {newtypes; params; body; async}} -> (async, newtype_params newtypes @ params_of_fun params, body) | _ -> (false, [], expr_) @@ -619,17 +595,17 @@ let partition_doc_comment_attributes attrs = | _ -> false) attrs -let is_fun_newtype expr = +let is_fun_expr expr = match expr.pexp_desc with - | Pexp_fun _ | Pexp_newtype _ -> true + | Pexp_fun _ -> true | _ -> false let requires_special_callback_printing_last_arg args = let rec loop args = match args with | [] -> false - | [(_, expr)] when is_fun_newtype expr -> true - | (_, expr) :: _ when is_fun_newtype expr -> false + | [(_, expr)] when is_fun_expr expr -> true + | (_, expr) :: _ when is_fun_expr expr -> false | _ :: rest -> loop rest in loop args @@ -638,12 +614,12 @@ let requires_special_callback_printing_first_arg args = let rec loop args = match args with | [] -> true - | (_, expr) :: _ when is_fun_newtype expr -> false + | (_, expr) :: _ when is_fun_expr expr -> false | _ :: rest -> loop rest in match args with - | [(_, expr)] when is_fun_newtype expr -> false - | (_, expr) :: rest when is_fun_newtype expr -> loop rest + | [(_, expr)] when is_fun_expr expr -> false + | (_, expr) :: rest when is_fun_expr expr -> loop rest | _ -> false let mod_expr_apply mod_expr = diff --git a/compiler/syntax/src/res_parsetree_viewer.mli b/compiler/syntax/src/res_parsetree_viewer.mli index e546abfa074..d95ad69a4d7 100644 --- a/compiler/syntax/src/res_parsetree_viewer.mli +++ b/compiler/syntax/src/res_parsetree_viewer.mli @@ -169,7 +169,7 @@ val has_if_let_attribute : Parsetree.attributes -> bool val is_rewritten_underscore_apply_sugar : Parsetree.expression -> bool -val is_fun_newtype : Parsetree.expression -> bool +val is_fun_expr : Parsetree.expression -> bool val is_tuple_array : Parsetree.expression -> bool diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 0ed2a1724bf..cadab56f4de 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -2349,14 +2349,46 @@ and print_value_binding ~state ~rec_flag (vb : Parsetree.value_binding) cmt_tbl else Doc.text "and " in match vb with + | { + pvb_pat = pattern; + pvb_expr = expr; + pvb_constraint = Some {pvc_newtypes; pvc_type}; + } -> + let newtypes = + Doc.join ~sep:Doc.space + (List.map + (fun ({Asttypes.txt; loc} : string Asttypes.loc) -> + print_comments (print_ident_like txt) cmt_tbl loc) + pvc_newtypes) + in + Doc.group + (Doc.concat + [ + attrs; + header; + print_pattern ~state pattern cmt_tbl; + Doc.text ":"; + Doc.indent + (Doc.concat + [ + Doc.line; + Doc.text "type "; + newtypes; + Doc.dot; + Doc.space; + print_typ_expr ~state pvc_type cmt_tbl; + Doc.text " ="; + Doc.line; + print_expression_with_comments ~state expr cmt_tbl; + ]); + ]) | { pvb_pat = { ppat_desc = Ppat_constraint (pattern, ({ptyp_desc = Ptyp_poly _} as pat_typ)); }; - pvb_expr = - {pexp_desc = Pexp_newtype _ | Pexp_fun {newtypes = _ :: _}} as expr; + pvb_expr = {pexp_desc = Pexp_fun {newtypes = _ :: _}} as expr; } -> ( let _, parameters, return_expr = Parsetree_viewer.fun_expr expr in let abstract_type = @@ -2482,7 +2514,6 @@ and print_value_binding ~state ~rec_flag (vb : Parsetree.value_binding) cmt_tbl } -> Parsetree_viewer.is_binary_expression if_expr || Parsetree_viewer.has_attributes if_expr.pexp_attributes - | {pexp_desc = Pexp_newtype _} -> false | {pexp_attributes = [({Location.txt = "res.taggedTemplate"}, _)]} -> false | {pexp_desc = Pexp_jsx_element _} -> true @@ -3188,7 +3219,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = print_expression_with_comments ~state (Parsetree_viewer.rewrite_underscore_apply e) cmt_tbl - | Pexp_fun _ | Pexp_newtype _ -> print_arrow e + | Pexp_fun _ -> print_arrow e | Parsetree.Pexp_constant c -> print_constant ~template_literal:(Parsetree_viewer.is_template_literal e) @@ -3877,9 +3908,7 @@ and print_expression ~state (e : Parsetree.expression) cmt_tbl = in let should_print_its_own_attributes = match e.pexp_desc with - | Pexp_apply _ | Pexp_fun _ | Pexp_newtype _ | Pexp_setfield _ - | Pexp_ifthenelse _ -> - true + | Pexp_apply _ | Pexp_fun _ | Pexp_setfield _ | Pexp_ifthenelse _ -> true | Pexp_match _ when Parsetree_viewer.is_if_let_expr e -> true | Pexp_jsx_element _ -> true | _ -> false @@ -4687,7 +4716,6 @@ and print_pexp_apply ~state expr cmt_tbl = } -> Parsetree_viewer.is_binary_expression if_expr || Parsetree_viewer.has_attributes if_expr.pexp_attributes - | {pexp_desc = Pexp_newtype _} -> false | e -> Parsetree_viewer.has_attributes e.pexp_attributes || Parsetree_viewer.is_array_access e diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index 2ec2ed9f7b0..f4fc2070edc 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -70,6 +70,78 @@ let test_record_rest_roundtrips_through_ast0 _ = let map_expr0 e = Ast_mapper_from0.default_mapper.expr Ast_mapper_from0.default_mapper e +let map_value_binding0 vb = + Ast_mapper_from0.default_mapper.value_binding Ast_mapper_from0.default_mapper + vb + +let to_value_binding0 vb = + Ast_mapper_to0.default_mapper.value_binding Ast_mapper_to0.default_mapper vb + +let test_value_constraint_roundtrips_through_ast0 _ = + let newtype = Location.mknoloc "a" in + let typ = + Ast_helper.Typ.constr ~loc (Location.mknoloc (Longident.Lident "a")) [] + in + let constraint_ = {Parsetree.pvc_newtypes = [newtype]; pvc_type = typ} in + let vb = + Ast_helper.Vb.mk ~loc ~constraint_ + (Ast_helper.Pat.var ~loc (Location.mknoloc "f")) + (Ast_helper.Exp.ident ~loc (Location.mknoloc (Longident.Lident "x"))) + in + let vb0 = to_value_binding0 vb in + (match (vb0.pvb_pat.ppat_desc, vb0.pvb_expr.pexp_desc) with + | ( Parsetree0.Ppat_constraint + (_, {ptyp_desc = Ptyp_poly ([{txt = "a"}], {ptyp_desc = Ptyp_var "a"})}), + Pexp_newtype + ( {txt = "a"}, + { + pexp_desc = + Pexp_constraint + (_, {ptyp_desc = Ptyp_constr ({txt = Lident "a"}, [])}); + } ) ) -> + () + | _ -> + assert_failure + "Expected the locally abstract value constraint's v0 wrapper encoding"); + let mismatched_vb0 = + match vb0.pvb_expr.pexp_desc with + | Pexp_newtype (name, expr) -> + { + vb0 with + pvb_expr = + { + vb0.pvb_expr with + pexp_desc = Pexp_newtype ({name with txt = "b"}, expr); + }; + } + | _ -> assert_failure "Expected a leading legacy newtype" + in + let mismatched_vb = map_value_binding0 mismatched_vb0 in + (match + ( mismatched_vb.pvb_pat.ppat_desc, + mismatched_vb.pvb_expr.pexp_desc, + mismatched_vb.pvb_constraint ) + with + | Ppat_constraint _, Pexp_extension extension, None -> + let error = Builtin_attributes.error_of_extension extension in + OUnit.assert_equal + "A PPX returned a locally abstract type wrapper that does not enclose a \ + ReScript function. This v0 AST form is not supported." + error.msg + | _ -> assert_failure "A mismatched v0 wrapper structure must become an error"); + let vb = map_value_binding0 vb0 in + match (vb.pvb_pat.ppat_desc, vb.pvb_expr.pexp_desc, vb.pvb_constraint) with + | ( Ppat_var {txt = "f"}, + Pexp_ident {txt = Lident "x"}, + Some + { + pvc_newtypes = [{txt = "a"}]; + pvc_type = {ptyp_desc = Ptyp_constr ({txt = Lident "a"}, [])}; + } ) -> + () + | _ -> + assert_failure "Expected the structural value constraint after roundtrip" + (* 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 _ = @@ -103,37 +175,6 @@ let test_function_cases_desugar_to_fun_match _ = scrutinee | _ -> assert_failure "Expected fun x -> match x with ... after desugaring" -(* Only a PPX can put an attribute on the function nested under a newtype - (the parser attaches source attributes to the outer node), and the bridge - deliberately preserves such attributes. The printer must not drop them - when merging the newtype and the function into one parameter list. *) -let test_attributed_fun_under_newtype_prints_attribute _ = - let fun_expr = - Ast_helper.Exp.fun_ ~loc - ~attrs:[attr "foo" (Parsetree.PStr [])] - [ - Ast_helper.Exp.fun_param Asttypes.Nolabel - (Ast_helper.Pat.var ~loc (Location.mknoloc "x")); - ] - (Ast_helper.Exp.ident ~loc (Location.mknoloc (Longident.Lident "x"))) - in - let expr = Ast_helper.Exp.newtype ~loc (Location.mknoloc "t") fun_expr in - let structure = - [ - Ast_helper.Str.value ~loc Asttypes.Nonrecursive - [ - Ast_helper.Vb.mk ~loc - (Ast_helper.Pat.var ~loc (Location.mknoloc "f")) - expr; - ]; - ] - in - let printed = - Res_printer.print_implementation ~width:80 structure ~comments:[] - in - OUnit.assert_bool "attribute on the fun under a newtype is printed" - (Ext_string.contain_substring printed "@foo") - let map_expr_to0 e = Ast_mapper_to0.default_mapper.expr Ast_mapper_to0.default_mapper e @@ -190,8 +231,6 @@ let suites = >::: [ "public_record_rest_attr_is_not_internal" >:: test_public_record_rest_attr_is_not_internal; - "attributed_fun_under_newtype_prints_attribute" - >:: test_attributed_fun_under_newtype_prints_attribute; "fun_node_attrs_roundtrip_through_ast0" >:: test_fun_node_attrs_roundtrip_through_ast0; "fun_param_attrs_roundtrip_through_ast0" @@ -200,6 +239,8 @@ let suites = >:: test_malformed_internal_record_rest_attr_fails; "record_rest_roundtrips_through_ast0" >:: test_record_rest_roundtrips_through_ast0; + "value_constraint_roundtrips_through_ast0" + >:: test_value_constraint_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 index 25936d60424..6645fe2d351 100644 --- a/tests/syntax_tests/data/ast-mapping/FunctionsAndArrows.res +++ b/tests/syntax_tests/data/ast-mapping/FunctionsAndArrows.res @@ -51,3 +51,6 @@ external phantom: (~a: int, @as(json`false`) _, ~c: string) => unit = "phantom" // attributed newtype groups: attribute ownership must survive the v0 bridge let grouped = @fn (@one type a b, x: a, @two type c, y: c) => (x, y) + +// locally abstract value constraints survive v0 AST conversion and re-fuse +let choose: type a b. (a, b) => a = (x, _) => x diff --git a/tests/syntax_tests/data/ast-mapping/expected/FunctionsAndArrows.res.txt b/tests/syntax_tests/data/ast-mapping/expected/FunctionsAndArrows.res.txt index 7605b4147ed..508c2860fb2 100644 --- a/tests/syntax_tests/data/ast-mapping/expected/FunctionsAndArrows.res.txt +++ b/tests/syntax_tests/data/ast-mapping/expected/FunctionsAndArrows.res.txt @@ -51,3 +51,6 @@ external phantom: (~a: int, @as(json`false`) _, ~c: string) => unit = "phantom" // attributed newtype groups: attribute ownership must survive the v0 bridge let grouped = @fn (@one type a b, @two type c, x: a, y: c) => (x, y) + +// locally abstract value constraints survive v0 AST conversion and re-fuse +let choose: type a b. (a, b) => a = (x, _) => x diff --git a/tests/syntax_tests/data/printer/comments/expected/valueBindingSugar.res.txt b/tests/syntax_tests/data/printer/comments/expected/valueBindingSugar.res.txt index 27d5bdb6ad8..cee944d555f 100644 --- a/tests/syntax_tests/data/printer/comments/expected/valueBindingSugar.res.txt +++ b/tests/syntax_tests/data/printer/comments/expected/valueBindingSugar.res.txt @@ -1,6 +1,8 @@ let /* before */ x /* after */: - type t. (/* a */ int /* b */, /* c */ int /* d */) => /* e */ int = + type t. (/* a */ int /* b */, /* c */ int /* d */) => /* e */ int /* f */ = (/* c0 */ a /* c1 */, /* c2 */ b /* c3 */) => { // comment a + b } + +let y: type /* before t */ t /* after t */ /* before u */ u /* after u */. (t, u) => t = (x, _) => x diff --git a/tests/syntax_tests/data/printer/comments/valueBindingSugar.res b/tests/syntax_tests/data/printer/comments/valueBindingSugar.res index ac774ab209d..09dc802b22b 100644 --- a/tests/syntax_tests/data/printer/comments/valueBindingSugar.res +++ b/tests/syntax_tests/data/printer/comments/valueBindingSugar.res @@ -4,3 +4,8 @@ let /* before */ x /* after */: // comment a + b } + +let y: + type /* before t */ t /* after t */ /* before u */ u /* after u */. + (t, u) => t = + (x, _) => x diff --git a/tests/tests/src/value_binding_constraint.mjs b/tests/tests/src/value_binding_constraint.mjs new file mode 100644 index 00000000000..9273bd24a19 --- /dev/null +++ b/tests/tests/src/value_binding_constraint.mjs @@ -0,0 +1,21 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + + +function defaultValue(witness) { + if (witness === "Int") { + return 42; + } else { + return "value"; + } +} + +let intDefault = 42; + +let stringDefault = "value"; + +export { + defaultValue, + intDefault, + stringDefault, +} +/* No side effect */ diff --git a/tests/tests/src/value_binding_constraint.res b/tests/tests/src/value_binding_constraint.res new file mode 100644 index 00000000000..aeba636e5e7 --- /dev/null +++ b/tests/tests/src/value_binding_constraint.res @@ -0,0 +1,14 @@ +type rec witness<'a> = + | Int: witness + | String: witness + +let defaultValue: + type a. witness => a = + witness => + switch witness { + | Int => 42 + | String => "value" + } + +let intDefault: int = defaultValue(Int) +let stringDefault: string = defaultValue(String)