From 1e39b9f0bf9f4d8e2fa3aabebef7db17f335c2ce Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 17 Aug 2026 12:57:52 +0200 Subject: [PATCH 1/3] Make a function's locally abstract types part of the function node Replace the Pexp_newtype wrapper chains that the parser built for (type t, x) => ... arrow syntax with a structural field on the function node: Pexp_fun.newtypes carries each newtype name with its own attributes, hoisted in front of the value parameters as before. Pexp_newtype remains solely as the desugaring of [let f: type a. ...] annotations and for PPX-authored trees. Fidelity fixes visible in the formatter: - Attributes keep their association with their type parameter group: (@attr type t, x, @attr2 type s, y) round-trips as written instead of printing @attr @attr2 on the function. - Comments written next to a type parameter travel with it to the hoisted group instead of migrating onto the following value parameter. - Attributes written in front of the arrow now live on the function node, so built-in attribute processing (e.g. @this) sees them on type-first functions; previously they sat inert on the wrapper node. Typing follows the upstream OCaml 5.x design: the newtype machinery is extracted into a reusable type_newtype helper (mirroring OCaml's helper of the same name) and the function case peels one newtype at a time, mimicking the typing of the former wrapper chain; the typedtree output is bit-identical to before. The v0 PPX bridge expands the field back into a wrapper chain around Function$: each wrapper carries its own newtype's attributes, and the outermost wrapper separates function-node attributes from the first newtype's attributes with an internal _res.newtype_attrs marker (no marker means node attributes only, matching the historical wire). Newtype-free programs are wire byte-identical; for functions with newtypes the deltas are confined to wrapper-node locations and, for the rare attributed groups, per-wrapper attribute placement. Identity-PPX round-trips are AST-exact, verified against the previous compiler. Also: jsx_v4 and bs_builtin_ppx now carry newtypes (and their attributes) through their function rebuilds instead of dropping them, the sexp AST debugger emits the field, and dead parser plumbing (fundef param attrs/p_pos, arrow_start_pos, make_newtypes ~attrs) is removed. Signed-Off-By: Cristiano Calcagno Co-Authored-By: Claude Fable 5 --- CHANGELOG.md | 1 + compiler/frontend/bs_ast_mapper.ml | 6 +- compiler/frontend/bs_builtin_ppx.ml | 26 ++- compiler/ml/ast_helper.ml | 4 +- compiler/ml/ast_helper.mli | 1 + compiler/ml/ast_iterator.ml | 7 +- compiler/ml/ast_mapper.ml | 6 +- compiler/ml/ast_mapper_from0.ml | 54 +++++- compiler/ml/ast_mapper_to0.ml | 50 +++++- compiler/ml/parsetree.ml | 12 +- compiler/ml/pprintast.ml | 24 ++- compiler/ml/printast.ml | 7 +- compiler/ml/typecore.ml | 142 +++++++++------ compiler/syntax/src/jsx_v4.ml | 16 +- compiler/syntax/src/res_ast_debugger.ml | 8 +- compiler/syntax/src/res_comments_table.ml | 40 +++-- compiler/syntax/src/res_core.ml | 166 ++++++------------ compiler/syntax/src/res_parsetree_viewer.ml | 32 +++- compiler/syntax/src/res_parsetree_viewer.mli | 6 + compiler/syntax/src/res_printer.ml | 3 +- .../newtype_fun_ppwarning.res.expected | 17 ++ .../newtype_group_warning_scope.res.expected | 16 ++ .../fixtures/newtype_fun_ppwarning.res | 1 + .../fixtures/newtype_group_warning_scope.res | 8 + .../data/ast-mapping/FunctionsAndArrows.res | 3 + .../expected/FunctionsAndArrows.res.txt | 3 + .../expressions/expected/async.res.txt | 22 +-- .../expected/locallyAbstractTypes.res.txt | 16 +- .../printer/comments/expected/expr.res.txt | 4 +- .../printer/expr/expected/newtype.res.txt | 18 +- .../data/printer/expr/newtype.res | 5 + tools/src/transforms.ml | 3 +- 32 files changed, 473 insertions(+), 254 deletions(-) create mode 100644 tests/build_tests/super_errors/expected/newtype_fun_ppwarning.res.expected create mode 100644 tests/build_tests/super_errors/expected/newtype_group_warning_scope.res.expected create mode 100644 tests/build_tests/super_errors/fixtures/newtype_fun_ppwarning.res create mode 100644 tests/build_tests/super_errors/fixtures/newtype_group_warning_scope.res diff --git a/CHANGELOG.md b/CHANGELOG.md index 3e77acfd55a..81c8720b6b1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -29,6 +29,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 - 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 diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml index 9edf483334c..07287bfdedc 100644 --- a/compiler/frontend/bs_ast_mapper.ml +++ b/compiler/frontend/bs_ast_mapper.ml @@ -325,8 +325,12 @@ module E = struct sub vbs) (sub.expr sub e) (* #end *) - | Pexp_fun {params; body; async} -> + | Pexp_fun {newtypes; params; body; async} -> fun_ ~loc ~attrs ~async + ~newtypes: + (List.map + (fun (name, attrs) -> (map_loc sub name, sub.attributes sub attrs)) + newtypes) (List.map (fun (param : Parsetree.fun_param) -> { diff --git a/compiler/frontend/bs_builtin_ppx.ml b/compiler/frontend/bs_builtin_ppx.ml index 6157cea22a7..24a8d7adb71 100644 --- a/compiler/frontend/bs_builtin_ppx.ml +++ b/compiler/frontend/bs_builtin_ppx.ml @@ -95,7 +95,7 @@ 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 {params; body; async} -> ( + | Pexp_fun {newtypes; params; body; async} -> ( match Ast_attributes.process_attributes_rev e.pexp_attributes with | Nothing, _ -> (* Handle @async x => y => ... is in async context *) @@ -116,19 +116,29 @@ let expr_mapper ~async_context ~in_function_def (self : mapper) mapper did (GH #7974). *) let body = self.expr self body in in_function_def := saved_in_function_def; + let newtypes = + Ext_list.map newtypes (fun (name, nt_attrs) -> + (name, self.attributes self nt_attrs)) + in let mapped = - Ast_helper.Exp.fun_ ~loc:e.pexp_loc ~attrs ~async params body + Ast_helper.Exp.fun_ ~loc:e.pexp_loc ~attrs ~async ~newtypes params body in Ast_async.make_function_async ~async mapped | Meth_callback _, pexp_attributes -> (* FIXME: does it make sense to have a label for [this] ? *) async_context := false; - { - e with - pexp_desc = - Ast_uncurry_gen.to_method_callback ~async e.pexp_loc self params body; - pexp_attributes; - }) + let callback = + { + e with + pexp_desc = + Ast_uncurry_gen.to_method_callback ~async 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)) | Pexp_apply _ -> Ast_exp_apply.app_exp_mapper e self | Pexp_match ( b, diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index ed29a89a785..bb19e9b1e1b 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -158,9 +158,9 @@ 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) params body = + let fun_ ?loc ?attrs ?(async = false) ?(newtypes = []) params body = assert (params <> []); - mk ?loc ?attrs (Pexp_fun {params; body; async}) + mk ?loc ?attrs (Pexp_fun {newtypes; params; body; async}) let fun_param ?(attrs = []) ?default lbl pat = {p_attrs = attrs; p_lbl = lbl; p_default = default; p_pat = pat} diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index 789b3d669ae..652d248ab5e 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -134,6 +134,7 @@ module Exp : sig ?loc:loc -> ?attrs:attrs -> ?async:bool -> + ?newtypes:(str * attrs) list -> fun_param list -> expression -> expression diff --git a/compiler/ml/ast_iterator.ml b/compiler/ml/ast_iterator.ml index 80bd5b78cba..46777f25df4 100644 --- a/compiler/ml/ast_iterator.ml +++ b/compiler/ml/ast_iterator.ml @@ -289,7 +289,12 @@ module E = struct | Pexp_let (_r, vbs, e) -> List.iter (sub.value_binding sub) vbs; sub.expr sub e - | Pexp_fun {params; body} -> + | Pexp_fun {newtypes; params; body} -> + List.iter + (fun (name, attrs) -> + iter_loc sub name; + sub.attributes sub attrs) + newtypes; List.iter (fun {p_default; p_pat} -> iter_opt (sub.expr sub) p_default; diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 5749aa11c8d..cde7ccfa34d 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -288,8 +288,12 @@ 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 {params; body; async} -> + | Pexp_fun {newtypes; params; body; async} -> fun_ ~loc ~attrs ~async + ~newtypes: + (List.map + (fun (name, attrs) -> (map_loc sub name, sub.attributes sub attrs)) + newtypes) (List.map (fun param -> { diff --git a/compiler/ml/ast_mapper_from0.ml b/compiler/ml/ast_mapper_from0.ml index d41715f92c9..2f4166b86ac 100644 --- a/compiler/ml/ast_mapper_from0.ml +++ b/compiler/ml/ast_mapper_from0.ml @@ -706,7 +706,8 @@ module E = struct in { e1 with - pexp_desc = Pexp_fun {params; body; async = f.async}; + pexp_desc = + Pexp_fun {newtypes = []; params; body; async = f.async}; pexp_attributes = e1.pexp_attributes @ node_attrs; }) | _ -> exp1) @@ -779,8 +780,55 @@ module E = struct | Pexp_lazy _ -> failwith "Pexp_lazy is no longer present in ReScript" | Pexp_poly _ -> failwith "Pexp_poly is no longer present in ReScript" | Pexp_object () -> assert false - | Pexp_newtype (s, e) -> - newtype ~loc ~attrs (map_loc sub s) (sub.expr sub e) + | Pexp_newtype (s, e) -> ( + (* Fuse a chain of newtype wrappers over a Function$ node into the + function's [newtypes] field. Each wrapper's attributes are its + 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. *) + let node_attrs, first_nt_attrs = + let rec split acc = function + | ({txt = "_res.newtype_attrs"}, _) :: rest -> (List.rev acc, rest) + | a :: rest -> split (a :: acc) rest + | [] -> (List.rev acc, []) + in + split [] attrs + in + let rec gather acc (e0 : Parsetree0.expression) = + match e0.pexp_desc with + | Pexp_newtype (s1, body) -> + gather + ((map_loc sub s1, sub.attributes sub e0.pexp_attributes) :: acc) + body + | Pexp_construct ({txt = Longident.Lident "Function$"}, Some _) -> + Some (List.rev acc, e0) + | _ -> None + in + match gather [(map_loc sub s, first_nt_attrs)] e with + | Some (newtypes, base) -> ( + let base1 = sub.expr sub base in + match base1.pexp_desc with + | Pexp_fun ({newtypes = []} as f) -> + { + Pt.pexp_desc = Pexp_fun {f with newtypes}; + 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)) | 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) diff --git a/compiler/ml/ast_mapper_to0.ml b/compiler/ml/ast_mapper_to0.ml index 65a7a8ca592..649cae98c61 100644 --- a/compiler/ml/ast_mapper_to0.ml +++ b/compiler/ml/ast_mapper_to0.ml @@ -405,11 +405,12 @@ 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 {params; body; async} -> + | Pexp_fun {newtypes; 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. - The head carries the function node's own attributes (and the - res.async marker), matching what the old parser produced. + Without newtypes the head carries the function node's own + attributes (and the res.async marker), matching what the old parser + produced; with newtypes they travel on the newtype wrapper instead. v0 fun nodes have a single attribute slot for what the current parsetree splits into node attributes and parameter attributes. @@ -433,7 +434,10 @@ module E = struct :: param_attrs in if is_head then - let base = attrs @ marked_param_attrs in + let base = + if newtypes = [] then attrs @ marked_param_attrs + else marked_param_attrs + in if async then ({txt = "res.async"; loc = Location.none}, Pt.PStr []) :: base else base @@ -457,9 +461,41 @@ module E = struct (Pconst_integer (string_of_int arity, None))); ] ) in - Ast_helper0.Exp.construct ~attrs:[arity_attr] - (Location.mkloc (Longident.Lident "Function$") e.pexp_loc) - (Some e) + let fn = + Ast_helper0.Exp.construct ~attrs:[arity_attr] + (Location.mkloc (Longident.Lident "Function$") e.pexp_loc) + (Some e) + in + (* Expand the newtypes back into the v0 wrapper chain around the + Function$ node. Each wrapper carries its own newtype's attributes. + The outermost wrapper is the whole expression in v0, so it also + carries the function node's attributes: when the first newtype has + attributes of its own, an internal [_res.newtype_attrs] marker + separates node attributes (before) from the first newtype's + attributes (after); without a marker every attribute on the + outermost wrapper is a function-node attribute, which is also how + wrapper attributes behaved before newtypes became a field. *) + match newtypes with + | [] -> fn + | (first_name, first_attrs) :: rest_newtypes -> + let inner = + List.fold_right + (fun (name, nt_attrs) acc -> + Ast_helper0.Exp.newtype ~loc + ~attrs:(sub.attributes sub nt_attrs) + (map_loc sub name) acc) + rest_newtypes fn + in + let first_attrs = sub.attributes sub first_attrs in + let outer_attrs = + if first_attrs = [] then attrs + else + attrs + @ ({txt = "_res.newtype_attrs"; loc = Location.none}, Pt.PStr []) + :: first_attrs + in + Ast_helper0.Exp.newtype ~loc ~attrs:outer_attrs (map_loc sub first_name) + inner) | Pexp_apply {funct = e; args; partial} -> let e = match (e.pexp_desc, args) with diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index 8a24070102e..7a41fc196e8 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -232,10 +232,18 @@ 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 {params: fun_param list; body: expression; async: bool} - (* (P1, ~l:P2, ?l:P3=E0) => E n-ary uncurried function. + | Pexp_fun of { + newtypes: (string loc * attributes) list; + params: fun_param list; + body: expression; + async: bool; + } + (* (type t, 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]. + [newtypes] are the function's locally abstract types, each with its + own attributes; the parser hoists them in front of the value + parameters. Notes: - A default expression is only allowed on Optional parameters. diff --git a/compiler/ml/pprintast.ml b/compiler/ml/pprintast.ml index c98a43ef6e4..df2599b1bef 100644 --- a/compiler/ml/pprintast.ml +++ b/compiler/ml/pprintast.ml @@ -627,17 +627,23 @@ 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 {params; body; async} -> + | Pexp_fun {newtypes; params; body; async} -> let arity_str = "[arity:" ^ string_of_int (List.length params) ^ "]" in let async_str = if async then "async " else "" in + let rec pp_newtypes f = function + | [] -> () + | ((name : string Location.loc), nt_attrs) :: rest -> + pp f "%a(type %s)@;" (attributes ctxt) nt_attrs name.txt; + pp_newtypes f rest + in 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 + pp f "@[<2>%sfun@;%a%s%a->@;%a@]" async_str pp_newtypes newtypes 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 @@ -1062,9 +1068,15 @@ 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 {params; body; async} -> + | Pexp_fun {newtypes; params; body; async} -> let arity_str = "[arity:" ^ string_of_int (List.length params) ^ "]" in let async_str = if async then "async " else "" in + let rec pp_newtypes f = function + | [] -> () + | ((name : string Location.loc), nt_attrs) :: rest -> + pp f "%a(type@ %s)@ " (attributes ctxt) nt_attrs name.txt; + pp_newtypes f rest + in 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) @@ -1075,8 +1087,8 @@ and binding ctxt f {pvb_pat = p; pvb_expr = x; _} = 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 + 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 diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index 3d78c884183..a92f386eee3 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -249,10 +249,15 @@ 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 {params; body; async} -> + | Pexp_fun {newtypes; params; body; async} -> line i ppf "Pexp_fun\n"; let () = if async then line i ppf "async\n" in line i ppf "arity:%d\n" (List.length params); + List.iter + (fun ((name : string loc), attrs) -> + attributes i ppf attrs; + line i ppf "newtype \"%s\"\n" name.txt) + newtypes; List.iter (fun {p_attrs; p_lbl; p_default; p_pat} -> attributes i ppf p_attrs; diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index 902dc84281a..cdc0913255d 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -2466,7 +2466,29 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp exp_attributes = sexp.pexp_attributes; exp_env = env; } - | Pexp_fun {params; body = sfun_body; async} -> + | 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. *) + let rec peel env = function + | [] -> + (* The newtype-free function, typed directly against a fresh + expectation (the caller's expected type is unified outside the + newtype scopes, below): dispatching through [type_exp] instead + would enter the node's warning scope a second time. *) + type_function ~async loc sexp.pexp_attributes env (newvar ()) params + 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)) + in + rue (peel env newtypes) + | Pexp_fun {newtypes = []; params; body = sfun_body; async} -> type_function ~async loc sexp.pexp_attributes env ty_expected params sfun_body | Pexp_apply {funct = sfunct; args = sargs; partial; transformed_jsx} -> @@ -3394,61 +3416,9 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp exp_env = env; } | Pexp_newtype ({txt = name}, sbody) -> - let ty = newvar () in - (* remember original level *) - begin_def (); - (* Create a fake abstract type declaration for name. *) - let level = get_current_level () in - let decl = - { - type_params = []; - type_arity = 0; - type_kind = Type_abstract; - type_private = Public; - type_manifest = None; - type_variance = []; - type_newtype_level = Some (level, level); - type_loc = loc; - type_attributes = []; - type_immediate = false; - type_unboxed = unboxed_false_default_false; - type_inlined_types = []; - } - in - Ident.set_current_time ty.level; - let id, new_env = Env.enter_type name decl env in - Ctype.init_def (Ident.current_time ()); - - let body = type_exp ~context:None new_env sbody in - (* Replace every instance of this type constructor in the resulting - type. *) - let seen = Hashtbl.create 8 in - let rec replace t = - if Hashtbl.mem seen t.id then () - else ( - Hashtbl.add seen t.id (); - match t.desc with - | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty - | _ -> Btype.iter_type_expr replace t) - in - let ety = Subst.type_expr Subst.identity body.exp_type in - replace ety; - (* back to original level *) - end_def (); - - (* 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. *) rue - { - body with - exp_loc = loc; - exp_type = ety; - exp_extra = - (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra; - } + (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 @@ -3507,6 +3477,68 @@ and type_expect_ ?deprecated_context ~context ?(recarg = Rejected) env sexp | Pexp_jsx_element _ -> raise (Error (sexp.pexp_loc, Env.empty, Jsx_not_enabled)) +(* 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) = + let ty = newvar () in + (* remember original level *) + begin_def (); + (* Create a fake abstract type declaration for name. *) + let level = get_current_level () in + let decl = + { + type_params = []; + type_arity = 0; + type_kind = Type_abstract; + type_private = Public; + type_manifest = None; + type_variance = []; + type_newtype_level = Some (level, level); + type_loc = loc; + type_attributes = []; + type_immediate = false; + type_unboxed = unboxed_false_default_false; + type_inlined_types = []; + } + in + Ident.set_current_time ty.level; + let id, new_env = Env.enter_type name decl env in + Ctype.init_def (Ident.current_time ()); + + let body = type_body new_env in + (* Replace every instance of this type constructor in the resulting + type. *) + let seen = Hashtbl.create 8 in + let rec replace t = + if Hashtbl.mem seen t.id then () + else ( + Hashtbl.add seen t.id (); + match t.desc with + | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty + | _ -> Btype.iter_type_expr replace t) + in + let ety = Subst.type_expr Subst.identity body.exp_type in + replace ety; + (* back to original level *) + end_def (); + + (* 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; + } + and type_function ~async loc attrs env ty_expected_ (sparams : Parsetree.fun_param list) sbody = (* Desugar optional-parameter defaults: the parameter becomes a fresh diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index f678c56cff7..a71a03073d6 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -241,11 +241,13 @@ 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} -> + | Pexp_fun {newtypes = fun_newtypes; params; body} -> + (* 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 + ((label, []) :: newtypes) core_type | Pexp_constraint (expression, core_type) -> recursively_transform_named_args_for_make expression args newtypes (Some core_type) @@ -793,12 +795,10 @@ let map_binding ~config ~empty_loc ~pstr_loc ~file_name binding = | [] -> [] | _ -> [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 *) - newtypes - |> List.fold_left (fun e newtype -> Exp.newtype newtype e) expression + (* Add the collected newtypes (type a b c) to make's definition *) + Exp.fun_ ~async:is_async ~newtypes:(List.rev newtypes) + (props_param :: nolabel_params) + expression in (* let make = ({id, name, ...}: props<'id, 'name, ...>) => { ... } *) let binding = diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index dbc5e70f35f..3f2eb9a949e 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -558,10 +558,16 @@ module Sexp_ast = struct Sexp.list (map_empty ~f:value_binding vbs); expression expr; ] - | Pexp_fun {params; body} -> + | Pexp_fun {newtypes; params; body} -> Sexp.list [ Sexp.atom "Pexp_fun"; + Sexp.list + (map_empty + ~f:(fun ((name : string Location.loc), attrs) -> + Sexp.list + [Sexp.atom "newtype"; string name.txt; attributes attrs]) + newtypes); Sexp.list (map_empty ~f:(fun {p_lbl; p_default; p_pat} -> diff --git a/compiler/syntax/src/res_comments_table.ml b/compiler/syntax/src/res_comments_table.ml index 40a9633515a..841640bb01e 100644 --- a/compiler/syntax/src/res_comments_table.ml +++ b/compiler/syntax/src/res_comments_table.ml @@ -359,6 +359,21 @@ let functor_type modtype = let fun_expr expr = let open Parsetree in + (* For simplicity reason each newtype gets converted to a Nolabel + * parameter with a fake pattern variable carrying the name's own + * location, otherwise this function would need to return a variant: + * | NormalParamater(...) + * | 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 newtype_params newtypes = + (* One fake parameter per newtype, carrying the name's own location: + comments attach to exactly the identifier locations the printer + looks up when printing a "type a b" group. *) + newtypes + |> 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 @@ -379,17 +394,19 @@ let fun_expr expr = in (Location.mkloc txt loc, return_expr) in - (* For simplicity reason Pexp_newtype gets converted to a Nolabel parameter, - * otherwise this function would need to return a variant: - * | NormalParamater(...) - * | 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 params_of params = params |> List.map (fun {p_attrs; p_lbl; p_default; p_pat} -> (p_attrs, p_lbl, p_default, p_pat)) in + (* Comments are attached by walking the parameters in source order, so + the newtype groups are interleaved back at their original positions. *) + let in_source_order params = + List.stable_sort + (fun (_, _, _, (p1 : Parsetree.pattern)) (_, _, _, p2) -> + compare p1.ppat_loc.loc_start.pos_cnum p2.ppat_loc.loc_start.pos_cnum) + 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 @@ -397,11 +414,14 @@ let fun_expr expr = (attrs, Asttypes.Nolabel, None, Ast_helper.Pat.var ~loc:string_loc.loc var) in match return_expr with - | {pexp_desc = Pexp_fun {params; body}; pexp_attributes = []} -> - ([], newtype_param :: params_of params, body) + | {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 {params; body}; pexp_attributes = attrs} -> - (attrs, params_of params, body) + | {pexp_desc = Pexp_fun {newtypes; params; body}; pexp_attributes = attrs} -> + (attrs, in_source_order (newtype_params newtypes @ params_of params), body) | expr -> ([], [], expr) let rec is_block_expr expr = diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index 708dfd75856..8e99345b19c 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -316,15 +316,12 @@ type typ_def_or_ext = type fundef_type_param = { attrs: Parsetree.attributes; locs: string Location.loc list; - p_pos: Lexing.position; } type fundef_term_param = { - attrs: Parsetree.attributes; p_label: Asttypes.arg_label; expr: Parsetree.expression option; pat: Parsetree.pattern; - p_pos: Lexing.position; } (* Single parameter of a function definition (type a b, x, ~y) *) @@ -339,27 +336,17 @@ type record_pattern_item = type context = OrdinaryExpr | TernaryTrueBranchExpr | WhenExpr -(* Extracts type and term parameters from a list of function definition parameters, combining all type parameters into one *) -let rec extract_fundef_params ~(type_acc : fundef_type_param option) +(* Extracts type and term parameters from a list of function definition + parameters, keeping the type parameter groups in source order *) +let rec extract_fundef_params ~(type_acc : fundef_type_param list) ~(term_acc : fundef_term_param list) (params : fundef_parameter list) : - fundef_type_param option * fundef_term_param list = + fundef_type_param list * fundef_term_param list = match params with | TermParameter tp :: rest -> extract_fundef_params ~type_acc ~term_acc:(tp :: term_acc) rest | TypeParameter tp :: rest -> - let type_acc = - match type_acc with - | Some tpa -> - Some - { - attrs = tpa.attrs @ tp.attrs; - locs = tpa.locs @ tp.locs; - p_pos = tpa.p_pos; - } - | None -> Some tp - in - extract_fundef_params ~type_acc ~term_acc rest - | [] -> (type_acc, List.rev term_acc) + extract_fundef_params ~type_acc:(tp :: type_acc) ~term_acc rest + | [] -> (List.rev type_acc, List.rev term_acc) let get_closing_token = function | Token.Lparen -> Token.Rparen @@ -624,13 +611,10 @@ let lident_of_path longident = | [] -> "" | ident :: _ -> ident -let make_newtypes ~attrs ~loc newtypes exp = - let expr = - List.fold_right - (fun newtype exp -> Ast_helper.Exp.mk ~loc (Pexp_newtype (newtype, exp))) - newtypes exp - in - {expr with pexp_attributes = attrs} +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 @@ -640,8 +624,7 @@ let make_newtypes ~attrs ~loc newtypes exp = *) let wrap_type_annotation ~loc newtypes core_type body = let exp = - make_newtypes ~attrs:[] ~loc newtypes - (Ast_helper.Exp.constraint_ ~loc body core_type) + make_newtypes ~loc newtypes (Ast_helper.Exp.constraint_ ~loc body core_type) in let typ = Ast_helper.Typ.poly ~loc newtypes @@ -1841,8 +1824,8 @@ and parse_ternary_expr left_operand p = true_branch (Some false_branch) | _ -> left_operand -and parse_es6_arrow_expression ?(arrow_attrs = []) ?(arrow_start_pos = None) - ?context ?term_parameters ~async p = +and parse_es6_arrow_expression ?(arrow_attrs = []) ?context ?term_parameters + ~async p = let start_pos = p.Parser.start_pos in Parser.leave_breadcrumb p Grammar.Es6ArrowExpr; (* Parsing function parameters and attributes: @@ -1851,35 +1834,9 @@ and parse_es6_arrow_expression ?(arrow_attrs = []) ?(arrow_start_pos = None) labeled, optional or nolabeled. *) let parameters = match term_parameters with - | Some params -> (None, params) + | Some params -> ([], params) | None -> parse_parameters p in - let parameters = - let update_attrs attrs = arrow_attrs @ attrs in - let update_pos pos = - match arrow_start_pos with - | Some start_pos -> start_pos - | None -> pos - in - match parameters with - | None, termp :: rest -> - ( None, - { - termp with - attrs = update_attrs termp.attrs; - p_pos = update_pos termp.p_pos; - } - :: rest ) - | Some (tpa : fundef_type_param), term_params -> - ( Some - { - tpa with - attrs = update_attrs tpa.attrs; - p_pos = update_pos tpa.p_pos; - }, - term_params ) - | _ -> parameters - in let return_type = match p.Parser.token with | Colon -> @@ -1899,11 +1856,9 @@ and parse_es6_arrow_expression ?(arrow_attrs = []) ?(arrow_start_pos = None) in Parser.eat_breadcrumb p; let end_pos = p.prev_end_pos in - let type_param_opt, term_parameters = parameters in + let type_groups, term_parameters = parameters in (* 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. *) + [parse_parameter]. *) let fun_params = List.map (fun {p_label = lbl; expr = default_expr; pat} -> @@ -1915,22 +1870,24 @@ and parse_es6_arrow_expression ?(arrow_attrs = []) ?(arrow_start_pos = None) }) term_parameters in - let fun_attrs = - List.concat_map (fun (p : fundef_term_param) -> p.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_helper.Exp.fun_ ~loc ~attrs:fun_attrs ~async fun_params body + (* Attributes written in front of the arrow belong to the function node + itself, independently of any type parameter groups. *) + let fun_attrs = arrow_attrs in + let loc = mk_loc start_pos end_pos in + let newtypes = + (* Each type parameter group carries its attributes on its first + newtype; the printer starts a new group at each attribute-bearing + newtype, so grouping and attributes round-trip. *) + List.concat_map + (fun {attrs; locs} -> + match locs with + | [] -> [] + | first :: rest -> + (first, attrs) :: List.map (fun name -> (name, [])) rest) + type_groups in let arrow_expr = - match type_param_opt with - | None -> arrow_expr - | Some {attrs; locs = newtypes; p_pos = start_pos} -> - make_newtypes ~attrs ~loc:(mk_loc start_pos end_pos) newtypes arrow_expr + Ast_helper.Exp.fun_ ~loc ~attrs:fun_attrs ~async ~newtypes fun_params body in {arrow_expr with pexp_loc = {arrow_expr.pexp_loc with loc_start = start_pos}} @@ -1967,9 +1924,9 @@ and parse_parameter p = if p.Parser.token = Typ then ( Parser.next p; let lidents = parse_lident_list p in - Some (TypeParameter {attrs; locs = lidents; p_pos = start_pos})) + Some (TypeParameter {attrs; locs = lidents})) else - let attrs, lbl, lbl_loc, pat = + let lbl, lbl_loc, pat = match p.Parser.token with | Tilde -> ( Parser.next p; @@ -1977,8 +1934,7 @@ and parse_parameter p = match p.Parser.token with | Comma | Equal | Rparen -> let loc = mk_loc start_pos p.prev_end_pos in - ( [], - Asttypes.Labelled {txt = lbl_name; loc = lbl_loc}, + ( Asttypes.Labelled {txt = lbl_name; loc = lbl_loc}, lbl_loc, Ast_helper.Pat.var ~attrs ~loc (Location.mkloc lbl_name loc) ) | Colon -> @@ -1991,26 +1947,24 @@ and parse_parameter p = let loc = mk_loc start_pos p.prev_end_pos in Ast_helper.Pat.constraint_ ~attrs ~loc pat typ in - ([], Asttypes.Labelled {txt = lbl_name; loc = lbl_loc}, lbl_loc, pat) + (Asttypes.Labelled {txt = lbl_name; loc = lbl_loc}, lbl_loc, pat) | As -> Parser.next p; let pat = let pat = parse_constrained_pattern p in {pat with ppat_attributes = attrs @ pat.ppat_attributes} in - ([], Asttypes.Labelled {txt = lbl_name; loc = lbl_loc}, lbl_loc, pat) + (Asttypes.Labelled {txt = lbl_name; loc = lbl_loc}, lbl_loc, pat) | t -> Parser.err p (Diagnostics.unexpected t p.breadcrumbs); let loc = mk_loc start_pos p.prev_end_pos in - ( [], - Asttypes.Labelled {txt = lbl_name; loc = lbl_loc}, + ( Asttypes.Labelled {txt = lbl_name; loc = lbl_loc}, lbl_loc, Ast_helper.Pat.var ~attrs ~loc (Location.mkloc lbl_name loc) )) | _ -> let pattern = parse_constrained_pattern p in let attrs = List.concat [pattern.ppat_attributes; attrs] in - ( [], - Asttypes.Nolabel, + ( Asttypes.Nolabel, Location.none, {pattern with ppat_attributes = attrs} ) in @@ -2035,19 +1989,11 @@ and parse_parameter p = match p.Parser.token with | Question -> Parser.next p; - Some - (TermParameter - {attrs; p_label = lbl; expr = None; pat; p_pos = start_pos}) + Some (TermParameter {p_label = lbl; expr = None; pat}) | _ -> let expr = parse_constrained_or_coerced_expr p in - Some - (TermParameter - {attrs; p_label = lbl; expr = Some expr; pat; p_pos = start_pos}) - ) - | _ -> - Some - (TermParameter - {attrs; p_label = lbl; expr = None; pat; p_pos = start_pos})) + Some (TermParameter {p_label = lbl; expr = Some expr; pat})) + | _ -> Some (TermParameter {p_label = lbl; expr = None; pat})) else None and parse_parameter_list p = @@ -2056,7 +2002,7 @@ and parse_parameter_list p = ~f:parse_parameter ~closing:Rparen p in Parser.expect Rparen p; - extract_fundef_params ~type_acc:None ~term_acc:[] parameters + extract_fundef_params ~type_acc:[] ~term_acc:[] parameters (* parameters ::= * | _ @@ -2065,7 +2011,7 @@ and parse_parameter_list p = * | (.) (* deprecated uncurried syntax *) * | ( parameter {, parameter} [,] ) *) -and parse_parameters p : fundef_type_param option * fundef_term_param list = +and parse_parameters p : fundef_type_param list * fundef_term_param list = let start_pos = p.Parser.start_pos in let unit_term_parameter () = let loc = mk_loc start_pos p.Parser.prev_end_pos in @@ -2074,39 +2020,29 @@ and parse_parameters p : fundef_type_param option * fundef_term_param list = (Location.mkloc (Longident.Lident "()") loc) None in - { - attrs = []; - p_label = Asttypes.Nolabel; - expr = None; - pat = unit_pattern; - p_pos = start_pos; - } + {p_label = Asttypes.Nolabel; expr = None; pat = unit_pattern} in match p.Parser.token with | Lident ident -> Parser.next p; let loc = mk_loc start_pos p.Parser.prev_end_pos in - ( None, + ( [], [ { - attrs = []; p_label = Asttypes.Nolabel; expr = None; pat = Ast_helper.Pat.var ~loc (Location.mkloc ident loc); - p_pos = start_pos; }; ] ) | Underscore -> Parser.next p; let loc = mk_loc start_pos p.Parser.prev_end_pos in - ( None, + ( [], [ { - attrs = []; p_label = Asttypes.Nolabel; expr = None; pat = Ast_helper.Pat.any ~loc (); - p_pos = start_pos; }; ] ) | Lparen -> @@ -2122,7 +2058,7 @@ and parse_parameters p : fundef_type_param option * fundef_term_param list = (type_params, term_params) | token -> Parser.err p (Diagnostics.unexpected token p.breadcrumbs); - (None, []) + ([], []) and parse_coerced_expr ~(expr : Parsetree.expression) p = Parser.expect ColonGreaterThan p; @@ -3412,11 +3348,9 @@ and parse_braced_or_record_expr p = ~term_parameters: [ { - attrs = []; p_label = Nolabel; expr = None; pat = Ast_helper.Pat.var ~loc:ident.loc ident; - p_pos = start_pos; }; ] p @@ -3778,10 +3712,8 @@ and parse_expr_block ?first p = over_parse_constrained_or_coerced_or_arrow_expression p block_expr and parse_async_arrow_expression ?(arrow_attrs = []) p = - let start_pos = p.Parser.start_pos in Parser.expect (Lident "async") p; - parse_es6_arrow_expression ~async:true ~arrow_attrs - ~arrow_start_pos:(Some start_pos) p + parse_es6_arrow_expression ~async:true ~arrow_attrs p and parse_await_expression p = let await_loc = mk_loc p.Parser.start_pos p.end_pos in diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index 5b00112fba1..fe63d5b9889 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -185,6 +185,19 @@ type fun_param_kind = } | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} +(* Turns the function's newtypes into printable groups: a new group starts + at each attribute-bearing newtype, matching how the parser distributes + group attributes. *) +let group_newtypes newtypes = + List.fold_left + (fun groups ((name : string Asttypes.loc), attrs) -> + match groups with + | (gattrs, locs) :: rest when attrs = [] -> + (gattrs, locs @ [name]) :: rest + | _ -> (attrs, [name]) :: groups) + [] newtypes + |> List.rev + let fun_expr expr_ = let params_of_fun params = List.map @@ -193,6 +206,10 @@ let fun_expr expr_ = {attrs = p_attrs; lbl = p_lbl; default_expr = p_default; pat = p_pat}) params in + let newtype_params newtypes = + 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. *) @@ -205,14 +222,21 @@ let fun_expr 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 {params; body; async}; pexp_attributes = []} -> - (async, newtype_param :: params_of_fun params, body) + | { + 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 {params; body; async}} -> - (async, params_of_fun params, body) + | {pexp_desc = Pexp_fun {newtypes; params; body; async}} -> + (async, newtype_params newtypes @ params_of_fun params, body) | _ -> (false, [], expr_) let process_braces_attr expr = diff --git a/compiler/syntax/src/res_parsetree_viewer.mli b/compiler/syntax/src/res_parsetree_viewer.mli index 10797277be8..e546abfa074 100644 --- a/compiler/syntax/src/res_parsetree_viewer.mli +++ b/compiler/syntax/src/res_parsetree_viewer.mli @@ -51,6 +51,12 @@ type fun_param_kind = } | NewTypes of {attrs: Parsetree.attributes; locs: string Asttypes.loc list} +(* Groups a function's newtypes into printable groups: a new group starts + at each attribute-bearing newtype. *) +val group_newtypes : + (string Asttypes.loc * Parsetree.attributes) list -> + (Parsetree.attributes * string Asttypes.loc list) list + val fun_expr : Parsetree.expression -> bool * fun_param_kind list * Parsetree.expression diff --git a/compiler/syntax/src/res_printer.ml b/compiler/syntax/src/res_printer.ml index 612b4adc388..0ed2a1724bf 100644 --- a/compiler/syntax/src/res_printer.ml +++ b/compiler/syntax/src/res_printer.ml @@ -2355,7 +2355,8 @@ and print_value_binding ~state ~rec_flag (vb : Parsetree.value_binding) cmt_tbl ppat_desc = Ppat_constraint (pattern, ({ptyp_desc = Ptyp_poly _} as pat_typ)); }; - pvb_expr = {pexp_desc = Pexp_newtype _} as expr; + pvb_expr = + {pexp_desc = Pexp_newtype _ | Pexp_fun {newtypes = _ :: _}} as expr; } -> ( let _, parameters, return_expr = Parsetree_viewer.fun_expr expr in let abstract_type = diff --git a/tests/build_tests/super_errors/expected/newtype_fun_ppwarning.res.expected b/tests/build_tests/super_errors/expected/newtype_fun_ppwarning.res.expected new file mode 100644 index 00000000000..efc7101f057 --- /dev/null +++ b/tests/build_tests/super_errors/expected/newtype_fun_ppwarning.res.expected @@ -0,0 +1,17 @@ + + Warning number 22 + /.../fixtures/newtype_fun_ppwarning.res:1:20-33 + + 1 │ let f = @ppwarning("emitted-once") (type a b, x: a) => x + 2 │ + + emitted-once + + + Warning number 34 + /.../fixtures/newtype_fun_ppwarning.res:1:36-56 + + 1 │ let f = @ppwarning("emitted-once") (type a b, x: a) => x + 2 │ + + unused type b. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/newtype_group_warning_scope.res.expected b/tests/build_tests/super_errors/expected/newtype_group_warning_scope.res.expected new file mode 100644 index 00000000000..c6bdf128bc0 --- /dev/null +++ b/tests/build_tests/super_errors/expected/newtype_group_warning_scope.res.expected @@ -0,0 +1,16 @@ + + Warning number 26 + /.../fixtures/newtype_group_warning_scope.res:6:7-12 + + 4 │ } + 5 │ let unsuppressed = (type a, x: a) => { + 6 │ let unused = 1 + 7 │ x + 8 │ } + + unused variable unused. + +Fix this by: +- Deleting the variable if it's not used anymore. +- Prepending the variable name with `_` (like `_unused`) to ignore that the variable is unused. +- Using the variable somewhere. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/newtype_fun_ppwarning.res b/tests/build_tests/super_errors/fixtures/newtype_fun_ppwarning.res new file mode 100644 index 00000000000..2ed5b52a8ac --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/newtype_fun_ppwarning.res @@ -0,0 +1 @@ +let f = @ppwarning("emitted-once") (type a b, x: a) => x diff --git a/tests/build_tests/super_errors/fixtures/newtype_group_warning_scope.res b/tests/build_tests/super_errors/fixtures/newtype_group_warning_scope.res new file mode 100644 index 00000000000..8aaa40872ee --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/newtype_group_warning_scope.res @@ -0,0 +1,8 @@ +let suppressed = (@warning("-26") type a, x: a) => { + let unused = 1 + x +} +let unsuppressed = (type a, x: a) => { + let unused = 1 + x +} diff --git a/tests/syntax_tests/data/ast-mapping/FunctionsAndArrows.res b/tests/syntax_tests/data/ast-mapping/FunctionsAndArrows.res index 782392229de..25936d60424 100644 --- a/tests/syntax_tests/data/ast-mapping/FunctionsAndArrows.res +++ b/tests/syntax_tests/data/ast-mapping/FunctionsAndArrows.res @@ -48,3 +48,6 @@ 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" + +// 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) 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 782392229de..7605b4147ed 100644 --- a/tests/syntax_tests/data/ast-mapping/expected/FunctionsAndArrows.res.txt +++ b/tests/syntax_tests/data/ast-mapping/expected/FunctionsAndArrows.res.txt @@ -48,3 +48,6 @@ 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" + +// 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) 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 0c04ab839d4..f726e44a170 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 @@ -28,17 +28,17 @@ let ex2 = (await 3) ** (await 4) let ex3 = await (foo -> (bar ~arg)) let ex4 = await ((foo.bar).baz) let attr1 = ((async fun [arity:1]x -> x + 1)[@a ]) -let attr2 = ((fun (type a) -> - async fun [arity:1]() -> fun (type b) -> fun (type c) -> - fun [arity:1]x -> 3) +let attr2 = + ((async fun (type a) [arity:1]() -> fun (type b) (type c) [arity:1]x -> 3) [@a ]) -let attr3 = ((fun (type a) -> - fun [arity:1]() -> fun (type b) -> fun (type c) -> - async fun [arity:1]x -> 3) +let attr3 = + ((fun (type a) [arity:1]() -> async fun (type b) (type c) [arity:1]x -> 3) [@a ]) -let attr4 = ((fun (type a) -> - fun [arity:1]() -> ((fun (type b) -> fun (type c) -> - async fun [arity:1]x -> 3)[@b ])) +let attr4 = + ((fun (type a) [arity:1]() -> + ((async fun (type b) (type c) [arity:1]x -> 3)[@b ])) [@a ]) -let (attr5 : int) = ((fun (type a) -> fun (type b) -> fun (type c) -> - async fun [arity:1]() -> fun [arity:1](x : a) -> x)[@a ][@b ]) \ No newline at end of file +let (attr5 : int) = + ((async fun (type a) (type b) (type c) [arity:1]() -> + fun [arity:1](x : a) -> x) + [@a ][@b ]) \ No newline at end of file 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 24693d89e30..a8966415fc1 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 @@ -3,16 +3,14 @@ let f (type t) (type s) [arity:2](xs : t list) (ys : s list) = () let f (type t) (type u) (type v) [arity:1](xs : (t * u * v) list) = () 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) (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) (ys : (u * v * w) list) -> ()) - [@attr ][@attr ][@attr ][@attr ]) +let f = + ((fun (type t) (type u) (type v) [@attr2 ](type s) (type w) (type z) + [arity:2](xs : (t * u * v) list) (ys : (s * w * z) list) -> ()) + [@attr ]) +let f [@attr ](type t) [@attr ](type s) [@attr ](type u) [@attr ](type v) + (type w) [arity:2](xs : (t * s) list) (ys : (u * v * w) list) = () let cancel_and_collect_callbacks : 'a 'u 'c . packed_callbacks list -> ('a, 'u, 'c) promise -> packed_callbacks list (a:2) - = fun (type x) -> - fun [arity:2]callbacks_accumulator (p : (_, _, c) promise) -> () \ No newline at end of file + = fun (type x) [arity:2]callbacks_accumulator (p : (_, _, c) promise) -> () \ No newline at end of file diff --git a/tests/syntax_tests/data/printer/comments/expected/expr.res.txt b/tests/syntax_tests/data/printer/comments/expected/expr.res.txt index 0b346bfe3cb..9196ebdd69b 100644 --- a/tests/syntax_tests/data/printer/comments/expected/expr.res.txt +++ b/tests/syntax_tests/data/printer/comments/expected/expr.res.txt @@ -237,9 +237,9 @@ let f = ( let multiply = (type /* c-2 */ t /* c-1 */, /* c0 */ m1 /* c1 */, /* c2 */ m2 /* c3 */) => () let multiply = ( - type /* c-4 */ t /* c-3 */ s, + type /* c-4 */ t /* c-3 */ /* c-2 */ s /* c-1 */, /* c0 */ m1 /* c1 */, - /* c-2 */ /* c-1 */ /* c2 */ m2 /* c3 */, + /* c2 */ m2 /* c3 */, ) => () f( diff --git a/tests/syntax_tests/data/printer/expr/expected/newtype.res.txt b/tests/syntax_tests/data/printer/expr/expected/newtype.res.txt index e97ff990e0e..e8480471a65 100644 --- a/tests/syntax_tests/data/printer/expr/expected/newtype.res.txt +++ b/tests/syntax_tests/data/printer/expr/expected/newtype.res.txt @@ -1,12 +1,19 @@ let f = (type t, xs: list) => () let f = @attr (type t, xs: list) => () let f = (type t s, xs: list, ys: list) => () -let f = @attr @attr2 (type t s, xs: list, ys: list) => () +let f = @attr (type t, @attr2 type s, xs: list, ys: list) => () let f = (type t u v, xs: list<(t, u, v)>) => () let f = @attr (type t u v, xs: list<(t, u, v)>) => () let f = (type t u v s w z, xs: list<(t, u, v)>, ys: list<(s, w, z)>) => () -let f = @attr @attr2 (type t u v s w z, xs: list<(t, u, v)>, ys: list<(s, w, z)>) => () -let f = @attr @attr @attr @attr (type t s u v w, xs: list<(t, s)>, ys: list<(u, v, w)>) => () +let f = @attr (type t u v, @attr2 type s w z, xs: list<(t, u, v)>, ys: list<(s, w, z)>) => () +let f = ( + @attr type t, + @attr type s, + @attr type u, + @attr type v w, + xs: list<(t, s)>, + ys: list<(u, v, w)>, +) => () let mk_formatting_gen: type a b c d e f. formatting_gen => Parsetree.expression = @@ -18,3 +25,8 @@ let mk_formatting_gen: let cancel_and_collect_callbacks: 'a 'u 'c. (list, promise<'a, 'u, 'c>) => list = (type x, callbacks_accumulator, p: promise<_, _, c>) => () + +// type parameters written between term parameters are hoisted to the front +let g = (type t, x, y: t) => y +let g = (@attr type t u v, x: int, y: t, z: v) => (y, z) +let g = (type /* c1 */ t /* c2 */, /* before */ x, y: t) => y diff --git a/tests/syntax_tests/data/printer/expr/newtype.res b/tests/syntax_tests/data/printer/expr/newtype.res index c8e30bd68e6..a5b6b62eba0 100644 --- a/tests/syntax_tests/data/printer/expr/newtype.res +++ b/tests/syntax_tests/data/printer/expr/newtype.res @@ -20,3 +20,8 @@ let cancel_and_collect_callbacks: (list, promise<'a, 'u, 'c>) => list = (type x, callbacks_accumulator, p: promise<_, _, c>) => (); + +// type parameters written between term parameters are hoisted to the front +let g = (x, type t, y: t) => y +let g = (x: int, @attr type t u, y: t, type v, z: v) => (y, z) +let g = (/* before */ x, type /* c1 */ t /* c2 */, y: t) => y diff --git a/tools/src/transforms.ml b/tools/src/transforms.ml index 901cc9c2154..da3e07f94a9 100644 --- a/tools/src/transforms.ml +++ b/tools/src/transforms.ml @@ -3,12 +3,13 @@ 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 {params; body; async} -> + | Pexp_fun {newtypes; params; body; async} -> { e with pexp_desc = Pexp_fun { + newtypes; params = List.map (fun (p : Parsetree.fun_param) -> {p with p_lbl = Nolabel}) From 403b094bd649b3539d798c8212bc344b1635aafa Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 17 Aug 2026 14:19:00 +0200 Subject: [PATCH 2/3] 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) From 17d8b224749f0b9aad1fa25df90d1d759055443e Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Mon, 17 Aug 2026 14:41:33 +0200 Subject: [PATCH 3/3] Preserve structure in docgen function details Function labels in Outcometree were strings, with optionality encoded by a leading question mark. That forced printers to decode the spelling and left downstream consumers without the label structure already known by the type system. Store Noloc.arg_label directly on Otyp_arrow, update both printers to match it exhaustively, and remove the unproduced Octy_arrow constructor. The doc generator previously walked Types.type_expr independently and flattened every reachable constructor into one list. Nested arrows became outer parameters, tuples and type variables disappeared, labels and optionality were lost, and non-function values acquired fabricated zero-parameter signatures. Build details from the normalized Outcometree instead: parameters retain their metadata, constructors, variables, tuples, and functions form recursive nodes, uncommon forms remain visible through a rendered fallback, and only top-level arrows receive signature details. Update the published RescriptTools.Docgen types and snapshots for the intentionally breaking JSON shape, and correct the implementation's stale alias tag to match the signature tag declared by its interface. The documentation site drops value details before publishing its data, but third-party consumers of rescript-tools doc need the changelog warning. Focused fixtures cover labeled and optional parameters, generic variables, callbacks, tuple returns, returned functions, fallback rendering, and non-function values. Compiler, tools, analysis, syntax, roundtrip, and full test suites remain green. Signed-off-by: Cristiano Calcagno --- CHANGELOG.md | 1 + compiler/ml/oprint.ml | 11 +- compiler/ml/outcometree.ml | 3 +- compiler/ml/printtyp.ml | 3 +- compiler/syntax/src/res_outcome_printer.ml | 35 ++- .../runtime/RescriptTools_Docgen.res | 18 +- .../runtime/RescriptTools_Docgen.resi | 16 +- .../src/DocgenSignatureDetails.res | 17 ++ .../src/DocgenSignatureDetails.resi | 17 ++ .../src/expected/DocExtraction2.res.json | 45 +++- .../src/expected/DocExtraction2.resi.json | 45 +++- .../src/expected/DocExtractionRes.res.json | 126 +++++---- .../expected/DocgenSignatureDetails.res.json | 243 ++++++++++++++++++ .../expected/DocgenSignatureDetails.resi.json | 243 ++++++++++++++++++ tests/tools_tests/src/expected/ModC.res.json | 9 +- tests/tools_tests/src/expected/ModC.resi.json | 9 +- tools/src/tools.ml | 162 +++++++----- 17 files changed, 824 insertions(+), 179 deletions(-) create mode 100644 tests/tools_tests/src/DocgenSignatureDetails.res create mode 100644 tests/tools_tests/src/DocgenSignatureDetails.resi create mode 100644 tests/tools_tests/src/expected/DocgenSignatureDetails.res.json create mode 100644 tests/tools_tests/src/expected/DocgenSignatureDetails.resi.json diff --git a/CHANGELOG.md b/CHANGELOG.md index d1c3012c010..ff63df08f19 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -17,6 +17,7 @@ - Remove runtime APIs that were deprecated for removal in ReScript 13, including the `Char` module, unsafe `Obj` operations, legacy `Pervasives` helpers, and `Array.unsafe_get`. https://github.com/rescript-lang/rescript/pull/8564 - Remove the deprecated `Js` namespace and its runtime modules. https://github.com/rescript-lang/rescript/pull/8531 - Move Belt into the separately installed `@rescript/belt` package. Projects using Belt must install the package and list it in their `rescript.json` dependencies. https://github.com/rescript-lang/rescript/pull/8554 +- Correct the structured function details produced by `rescript-tools doc` and exposed by `RescriptTools.Docgen`: parameters now retain labels and optionality, nested functions, tuples, variables, and generic arguments retain their type structure, return types are identified correctly, and non-function values no longer receive fake function details. This changes the published docgen detail schema. https://github.com/rescript-lang/rescript/pull/8576 #### :eyeglasses: Spec Compliance diff --git a/compiler/ml/oprint.ml b/compiler/ml/oprint.ml index 6d0b764d500..795a1b30fb0 100644 --- a/compiler/ml/oprint.ml +++ b/compiler/ml/oprint.ml @@ -253,9 +253,10 @@ and print_out_type_1 ppf = function pp_open_box ppf 0; List.iter (fun (lab, ty1) -> - if lab <> "" then ( - pp_print_string ppf lab; - pp_print_char ppf ':'); + (match lab with + | Asttypes.Noloc.Nolabel -> () + | Asttypes.Noloc.Labelled label -> fprintf ppf "%s:" label + | Asttypes.Noloc.Optional label -> fprintf ppf "?%s:" label); print_out_type_2 ppf ty1; pp_print_string ppf " ->"; pp_print_space ppf ()) @@ -406,10 +407,6 @@ let rec print_out_class_type ppf = function | tyl -> fprintf ppf "@[<1>[%a]@]@ " (print_typlist !out_type ",") tyl in fprintf ppf "@[%a%a@]" pr_tyl tyl print_ident id - | Octy_arrow (lab, ty, cty) -> - fprintf ppf "@[%s%a ->@ %a@]" - (if lab <> "" then lab ^ ":" else "") - print_out_type_2 ty print_out_class_type cty | Octy_signature (self_ty, csil) -> let pr_param ppf = function | Some ty -> fprintf ppf "@ @[(%a)@]" !out_type ty diff --git a/compiler/ml/outcometree.ml b/compiler/ml/outcometree.ml index d2e02e036e9..4d6e4190eb4 100644 --- a/compiler/ml/outcometree.ml +++ b/compiler/ml/outcometree.ml @@ -53,7 +53,7 @@ type out_type = | Otyp_abstract | Otyp_open | Otyp_alias of out_type * string - | Otyp_arrow of (string * out_type) list * out_type + | Otyp_arrow of (Asttypes.Noloc.arg_label * out_type) list * out_type | Otyp_class of bool * out_ident * out_type list | Otyp_constr of out_ident * out_type list | Otyp_manifest of out_type * out_type @@ -74,7 +74,6 @@ and out_variant = type out_class_type = | Octy_constr of out_ident * out_type list - | Octy_arrow of string * out_type * out_class_type | Octy_signature of out_type option * out_class_sig_item list and out_class_sig_item = | Ocsg_constraint of out_type * out_type diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index 624a3b75a0e..3f79ca004a8 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -616,7 +616,6 @@ let rec tree_of_typexp ?(printing_context : printing_context option) sch ty = let args = List.map (fun (arg : Types.arg) -> - let lab = string_of_label arg.lbl in let t1 = if is_optional arg.lbl then match (repr arg.typ).desc with @@ -626,7 +625,7 @@ let rec tree_of_typexp ?(printing_context : printing_context option) sch ty = | _ -> Otyp_stuff "" else tree_of_typexp ?printing_context sch arg.typ in - (lab, t1)) + (Asttypes.to_noloc arg.lbl, t1)) params in Otyp_arrow (args, tree_of_typexp ?printing_context sch ret) diff --git a/compiler/syntax/src/res_outcome_printer.ml b/compiler/syntax/src/res_outcome_printer.ml index ac723459952..684b3006689 100644 --- a/compiler/syntax/src/res_outcome_printer.ml +++ b/compiler/syntax/src/res_outcome_printer.ml @@ -238,29 +238,26 @@ let rec print_out_type_doc (out_type : Outcometree.out_type) = and print_out_arrow_type typ = let typ_args, typ = collect_arrow_args typ in + let print_labeled_arg label optional_indicator typ = + Doc.group + (Doc.concat + [ + Doc.text ("~" ^ label ^ ": "); + print_out_type_doc typ; + optional_indicator; + ]) + in let args = Doc.join ~sep:(Doc.concat [Doc.comma; Doc.line]) (List.map (fun (lbl, typ) -> - let lbl_len = String.length lbl in - if lbl_len = 0 then print_out_type_doc typ - else - let lbl, optional_indicator = - (* the ocaml compiler hardcodes the optional label inside the string of the label in printtyp.ml *) - match String.unsafe_get lbl 0 with - | '?' -> - ( (String.sub [@doesNotRaise]) lbl 1 (lbl_len - 1), - Doc.text "=?" ) - | _ -> (lbl, Doc.nil) - in - Doc.group - (Doc.concat - [ - Doc.text ("~" ^ lbl ^ ": "); - print_out_type_doc typ; - optional_indicator; - ])) + match lbl with + | Asttypes.Noloc.Nolabel -> print_out_type_doc typ + | Asttypes.Noloc.Labelled label -> + print_labeled_arg label Doc.nil typ + | Asttypes.Noloc.Optional label -> + print_labeled_arg label (Doc.text "=?") typ) typ_args) in let args_doc = @@ -268,7 +265,7 @@ and print_out_arrow_type typ = match typ_args with | [(_, (Otyp_tuple _ | Otyp_arrow _))] -> true (* single argument should not be wrapped *) - | [("", _)] -> false + | [(Asttypes.Noloc.Nolabel, _)] -> false | _ -> true in if needs_parens then diff --git a/packages/@rescript/runtime/RescriptTools_Docgen.res b/packages/@rescript/runtime/RescriptTools_Docgen.res index 6dd74547473..8dd1cc2e880 100644 --- a/packages/@rescript/runtime/RescriptTools_Docgen.res +++ b/packages/@rescript/runtime/RescriptTools_Docgen.res @@ -17,13 +17,21 @@ type constructor = { payload?: constructorPayload, } -type rec typeInSignature = { - path: string, - genericTypeParameters: array, +@tag("kind") +type rec typeInSignature = + | @as("constructor") Constructor({path: string, genericTypeParameters: array}) + | @as("variable") Variable({name: string, weak: bool}) + | @as("tuple") Tuple({elements: array}) + | @as("function") Function({parameters: array, returnType: typeInSignature}) + | @as("rendered") Rendered({signature: string}) +and signatureParameter = { + label?: string, + optional: bool, + @as("type") type_: typeInSignature, } type signatureDetails = { - parameters: array, + parameters: array, returnType: typeInSignature, } @@ -31,7 +39,7 @@ type signatureDetails = { type detail = | @as("record") Record({items: array}) | @as("variant") Variant({items: array}) - | @as("alias") Signature({details: signatureDetails}) + | @as("signature") Signature({details: signatureDetails}) type source = { filepath: string, diff --git a/packages/@rescript/runtime/RescriptTools_Docgen.resi b/packages/@rescript/runtime/RescriptTools_Docgen.resi index 2c8b1d4ad10..ae20015090f 100644 --- a/packages/@rescript/runtime/RescriptTools_Docgen.resi +++ b/packages/@rescript/runtime/RescriptTools_Docgen.resi @@ -17,13 +17,21 @@ type constructor = { payload?: constructorPayload, } -type rec typeInSignature = { - path: string, - genericTypeParameters: array, +@tag("kind") +type rec typeInSignature = + | @as("constructor") Constructor({path: string, genericTypeParameters: array}) + | @as("variable") Variable({name: string, weak: bool}) + | @as("tuple") Tuple({elements: array}) + | @as("function") Function({parameters: array, returnType: typeInSignature}) + | @as("rendered") Rendered({signature: string}) +and signatureParameter = { + label?: string, + optional: bool, + @as("type") type_: typeInSignature, } type signatureDetails = { - parameters: array, + parameters: array, returnType: typeInSignature, } diff --git a/tests/tools_tests/src/DocgenSignatureDetails.res b/tests/tools_tests/src/DocgenSignatureDetails.res new file mode 100644 index 00000000000..b52a9a8a4a6 --- /dev/null +++ b/tests/tools_tests/src/DocgenSignatureDetails.res @@ -0,0 +1,17 @@ +let labeledOptional: (~required: 'a, ~optional: array<'a>=?) => result<'a, string> = ( + ~required, + ~optional=?, +) => { + ignore(optional) + Ok(required) +} + +let takesCallback: ('a => string) => bool = _callback => true + +let returnsTuple: int => (string, int) = value => ("value", value) + +let returnsFunction: int => string => bool = _value => _text => true + +let takesVariant: [#enabled | #count(int)] => unit = _variant => () + +let constant = 42 diff --git a/tests/tools_tests/src/DocgenSignatureDetails.resi b/tests/tools_tests/src/DocgenSignatureDetails.resi new file mode 100644 index 00000000000..d6c6a598c41 --- /dev/null +++ b/tests/tools_tests/src/DocgenSignatureDetails.resi @@ -0,0 +1,17 @@ +/** Labeled and optional parameters keep their parameter metadata. */ +let labeledOptional: (~required: 'a, ~optional: array<'a>=?) => result<'a, string> + +/** A callback remains one parameter instead of becoming outer parameters. */ +let takesCallback: ('a => string) => bool + +/** A tuple remains one return-type node. */ +let returnsTuple: int => (string, int) + +/** A returned function remains nested in the return type. */ +let returnsFunction: int => string => bool + +/** Less common type forms remain visible through an explicit fallback. */ +let takesVariant: [#enabled | #count(int)] => unit + +/** Non-functions do not receive function signature details. */ +let constant: int diff --git a/tests/tools_tests/src/expected/DocExtraction2.res.json b/tests/tools_tests/src/expected/DocExtraction2.res.json index 79eac3729cf..1221c0b1b39 100644 --- a/tests/tools_tests/src/expected/DocExtraction2.res.json +++ b/tests/tools_tests/src/expected/DocExtraction2.res.json @@ -29,8 +29,21 @@ "detail": { "kind": "signature", "details": { - "parameters": [ { "path": "unit", "genericTypeParameters": [] } ], - "returnType": { "path": "t", "genericTypeParameters": [] } + "parameters": [ + { + "optional": false, + "type": { + "kind": "constructor", + "path": "unit", + "genericTypeParameters": [] + } + } + ], + "returnType": { + "kind": "constructor", + "path": "t", + "genericTypeParameters": [] + } } } }, @@ -72,9 +85,20 @@ "kind": "signature", "details": { "parameters": [ - { "path": "unit", "genericTypeParameters": [] } + { + "optional": false, + "type": { + "kind": "constructor", + "path": "unit", + "genericTypeParameters": [] + } + } ], - "returnType": { "path": "t", "genericTypeParameters": [] } + "returnType": { + "kind": "constructor", + "path": "t", + "genericTypeParameters": [] + } } } } @@ -95,8 +119,17 @@ "detail": { "kind": "signature", "details": { - "parameters": [], - "returnType": { "path": "unit", "genericTypeParameters": [] } + "parameters": [ + { + "optional": false, + "type": { "kind": "variable", "name": "a", "weak": false } + } + ], + "returnType": { + "kind": "constructor", + "path": "unit", + "genericTypeParameters": [] + } } } } diff --git a/tests/tools_tests/src/expected/DocExtraction2.resi.json b/tests/tools_tests/src/expected/DocExtraction2.resi.json index 79eac3729cf..1221c0b1b39 100644 --- a/tests/tools_tests/src/expected/DocExtraction2.resi.json +++ b/tests/tools_tests/src/expected/DocExtraction2.resi.json @@ -29,8 +29,21 @@ "detail": { "kind": "signature", "details": { - "parameters": [ { "path": "unit", "genericTypeParameters": [] } ], - "returnType": { "path": "t", "genericTypeParameters": [] } + "parameters": [ + { + "optional": false, + "type": { + "kind": "constructor", + "path": "unit", + "genericTypeParameters": [] + } + } + ], + "returnType": { + "kind": "constructor", + "path": "t", + "genericTypeParameters": [] + } } } }, @@ -72,9 +85,20 @@ "kind": "signature", "details": { "parameters": [ - { "path": "unit", "genericTypeParameters": [] } + { + "optional": false, + "type": { + "kind": "constructor", + "path": "unit", + "genericTypeParameters": [] + } + } ], - "returnType": { "path": "t", "genericTypeParameters": [] } + "returnType": { + "kind": "constructor", + "path": "t", + "genericTypeParameters": [] + } } } } @@ -95,8 +119,17 @@ "detail": { "kind": "signature", "details": { - "parameters": [], - "returnType": { "path": "unit", "genericTypeParameters": [] } + "parameters": [ + { + "optional": false, + "type": { "kind": "variable", "name": "a", "weak": false } + } + ], + "returnType": { + "kind": "constructor", + "path": "unit", + "genericTypeParameters": [] + } } } } diff --git a/tests/tools_tests/src/expected/DocExtractionRes.res.json b/tests/tools_tests/src/expected/DocExtractionRes.res.json index 5d3d3c2bdc2..da2ef13a178 100644 --- a/tests/tools_tests/src/expected/DocExtractionRes.res.json +++ b/tests/tools_tests/src/expected/DocExtractionRes.res.json @@ -48,8 +48,21 @@ "detail": { "kind": "signature", "details": { - "parameters": [ { "path": "string", "genericTypeParameters": [] } ], - "returnType": { "path": "t", "genericTypeParameters": [] } + "parameters": [ + { + "optional": false, + "type": { + "kind": "constructor", + "path": "string", + "genericTypeParameters": [] + } + } + ], + "returnType": { + "kind": "constructor", + "path": "t", + "genericTypeParameters": [] + } } } }, @@ -67,8 +80,21 @@ "detail": { "kind": "signature", "details": { - "parameters": [ { "path": "t", "genericTypeParameters": [] } ], - "returnType": { "path": "t", "genericTypeParameters": [] } + "parameters": [ + { + "optional": false, + "type": { + "kind": "constructor", + "path": "t", + "genericTypeParameters": [] + } + } + ], + "returnType": { + "kind": "constructor", + "path": "t", + "genericTypeParameters": [] + } } } }, @@ -82,13 +108,6 @@ "filepath": "src/DocExtractionRes.res", "line": 26, "col": 5 - }, - "detail": { - "kind": "signature", - "details": { - "parameters": [], - "returnType": { "path": "int", "genericTypeParameters": [] } - } } }, { @@ -211,11 +230,19 @@ "details": { "parameters": [ { - "path": "SomeInnerModule.status", - "genericTypeParameters": [] + "optional": false, + "type": { + "kind": "constructor", + "path": "SomeInnerModule.status", + "genericTypeParameters": [] + } } ], - "returnType": { "path": "bool", "genericTypeParameters": [] } + "returnType": { + "kind": "constructor", + "path": "bool", + "genericTypeParameters": [] + } } } }, @@ -312,9 +339,20 @@ "kind": "signature", "details": { "parameters": [ - { "path": "unit", "genericTypeParameters": [] } + { + "optional": false, + "type": { + "kind": "constructor", + "path": "unit", + "genericTypeParameters": [] + } + } ], - "returnType": { "path": "t", "genericTypeParameters": [] } + "returnType": { + "kind": "constructor", + "path": "t", + "genericTypeParameters": [] + } } } } @@ -357,8 +395,21 @@ "detail": { "kind": "signature", "details": { - "parameters": [ { "path": "t", "genericTypeParameters": [] } ], - "returnType": { "path": "t", "genericTypeParameters": [] } + "parameters": [ + { + "optional": false, + "type": { + "kind": "constructor", + "path": "t", + "genericTypeParameters": [] + } + } + ], + "returnType": { + "kind": "constructor", + "path": "t", + "genericTypeParameters": [] + } } } } @@ -402,9 +453,20 @@ "kind": "signature", "details": { "parameters": [ - { "path": "int", "genericTypeParameters": [] } + { + "optional": false, + "type": { + "kind": "constructor", + "path": "int", + "genericTypeParameters": [] + } + } ], - "returnType": { "path": "int", "genericTypeParameters": [] } + "returnType": { + "kind": "constructor", + "path": "int", + "genericTypeParameters": [] + } } } } @@ -432,13 +494,6 @@ "filepath": "src/DocExtractionRes.res", "line": 138, "col": 3 - }, - "detail": { - "kind": "signature", - "details": { - "parameters": [], - "returnType": { "path": "int", "genericTypeParameters": [] } - } } } ] @@ -464,13 +519,6 @@ "filepath": "src/DocExtractionRes.res", "line": 142, "col": 7 - }, - "detail": { - "kind": "signature", - "details": { - "parameters": [], - "returnType": { "path": "int", "genericTypeParameters": [] } - } } } ], @@ -508,16 +556,6 @@ "filepath": "src/DocExtractionRes.res", "line": 147, "col": 9 - }, - "detail": { - "kind": "signature", - "details": { - "parameters": [], - "returnType": { - "path": "int", - "genericTypeParameters": [] - } - } } } ], diff --git a/tests/tools_tests/src/expected/DocgenSignatureDetails.res.json b/tests/tools_tests/src/expected/DocgenSignatureDetails.res.json new file mode 100644 index 00000000000..381618d2709 --- /dev/null +++ b/tests/tools_tests/src/expected/DocgenSignatureDetails.res.json @@ -0,0 +1,243 @@ +{ + "name": "DocgenSignatureDetails", + "docstrings": [], + "source": { + "filepath": "src/DocgenSignatureDetails.resi", + "line": 1, + "col": 1 + }, + "items": [ + { + "id": "DocgenSignatureDetails.labeledOptional", + "kind": "value", + "name": "labeledOptional", + "signature": "let labeledOptional: (\n ~required: 'a,\n ~optional: array<'a>=?,\n) => result<'a, string>", + "docstrings": [ + "Labeled and optional parameters keep their parameter metadata." + ], + "source": { + "filepath": "src/DocgenSignatureDetails.resi", + "line": 2, + "col": 1 + }, + "detail": { + "kind": "signature", + "details": { + "parameters": [ + { + "label": "required", + "optional": false, + "type": { "kind": "variable", "name": "a", "weak": false } + }, + { + "label": "optional", + "optional": true, + "type": { + "kind": "constructor", + "path": "array", + "genericTypeParameters": [ + { "kind": "variable", "name": "a", "weak": false } + ] + } + } + ], + "returnType": { + "kind": "constructor", + "path": "result", + "genericTypeParameters": [ + { "kind": "variable", "name": "a", "weak": false }, + { + "kind": "constructor", + "path": "string", + "genericTypeParameters": [] + } + ] + } + } + } + }, + { + "id": "DocgenSignatureDetails.takesCallback", + "kind": "value", + "name": "takesCallback", + "signature": "let takesCallback: ('a => string) => bool", + "docstrings": [ + "A callback remains one parameter instead of becoming outer parameters." + ], + "source": { + "filepath": "src/DocgenSignatureDetails.resi", + "line": 5, + "col": 1 + }, + "detail": { + "kind": "signature", + "details": { + "parameters": [ + { + "optional": false, + "type": { + "kind": "function", + "parameters": [ + { + "optional": false, + "type": { + "kind": "variable", + "name": "a", + "weak": false + } + } + ], + "returnType": { + "kind": "constructor", + "path": "string", + "genericTypeParameters": [] + } + } + } + ], + "returnType": { + "kind": "constructor", + "path": "bool", + "genericTypeParameters": [] + } + } + } + }, + { + "id": "DocgenSignatureDetails.returnsTuple", + "kind": "value", + "name": "returnsTuple", + "signature": "let returnsTuple: int => (string, int)", + "docstrings": [ "A tuple remains one return-type node." ], + "source": { + "filepath": "src/DocgenSignatureDetails.resi", + "line": 8, + "col": 1 + }, + "detail": { + "kind": "signature", + "details": { + "parameters": [ + { + "optional": false, + "type": { + "kind": "constructor", + "path": "int", + "genericTypeParameters": [] + } + } + ], + "returnType": { + "kind": "tuple", + "elements": [ + { + "kind": "constructor", + "path": "string", + "genericTypeParameters": [] + }, + { + "kind": "constructor", + "path": "int", + "genericTypeParameters": [] + } + ] + } + } + } + }, + { + "id": "DocgenSignatureDetails.returnsFunction", + "kind": "value", + "name": "returnsFunction", + "signature": "let returnsFunction: int => string => bool", + "docstrings": [ + "A returned function remains nested in the return type." + ], + "source": { + "filepath": "src/DocgenSignatureDetails.resi", + "line": 11, + "col": 1 + }, + "detail": { + "kind": "signature", + "details": { + "parameters": [ + { + "optional": false, + "type": { + "kind": "constructor", + "path": "int", + "genericTypeParameters": [] + } + } + ], + "returnType": { + "kind": "function", + "parameters": [ + { + "optional": false, + "type": { + "kind": "constructor", + "path": "string", + "genericTypeParameters": [] + } + } + ], + "returnType": { + "kind": "constructor", + "path": "bool", + "genericTypeParameters": [] + } + } + } + } + }, + { + "id": "DocgenSignatureDetails.takesVariant", + "kind": "value", + "name": "takesVariant", + "signature": "let takesVariant: [#count(int) | #enabled] => unit", + "docstrings": [ + "Less common type forms remain visible through an explicit fallback." + ], + "source": { + "filepath": "src/DocgenSignatureDetails.resi", + "line": 14, + "col": 1 + }, + "detail": { + "kind": "signature", + "details": { + "parameters": [ + { + "optional": false, + "type": { + "kind": "rendered", + "signature": "[#count(int) | #enabled]" + } + } + ], + "returnType": { + "kind": "constructor", + "path": "unit", + "genericTypeParameters": [] + } + } + } + }, + { + "id": "DocgenSignatureDetails.constant", + "kind": "value", + "name": "constant", + "signature": "let constant: int", + "docstrings": [ + "Non-functions do not receive function signature details." + ], + "source": { + "filepath": "src/DocgenSignatureDetails.resi", + "line": 17, + "col": 1 + } + } + ] +} diff --git a/tests/tools_tests/src/expected/DocgenSignatureDetails.resi.json b/tests/tools_tests/src/expected/DocgenSignatureDetails.resi.json new file mode 100644 index 00000000000..381618d2709 --- /dev/null +++ b/tests/tools_tests/src/expected/DocgenSignatureDetails.resi.json @@ -0,0 +1,243 @@ +{ + "name": "DocgenSignatureDetails", + "docstrings": [], + "source": { + "filepath": "src/DocgenSignatureDetails.resi", + "line": 1, + "col": 1 + }, + "items": [ + { + "id": "DocgenSignatureDetails.labeledOptional", + "kind": "value", + "name": "labeledOptional", + "signature": "let labeledOptional: (\n ~required: 'a,\n ~optional: array<'a>=?,\n) => result<'a, string>", + "docstrings": [ + "Labeled and optional parameters keep their parameter metadata." + ], + "source": { + "filepath": "src/DocgenSignatureDetails.resi", + "line": 2, + "col": 1 + }, + "detail": { + "kind": "signature", + "details": { + "parameters": [ + { + "label": "required", + "optional": false, + "type": { "kind": "variable", "name": "a", "weak": false } + }, + { + "label": "optional", + "optional": true, + "type": { + "kind": "constructor", + "path": "array", + "genericTypeParameters": [ + { "kind": "variable", "name": "a", "weak": false } + ] + } + } + ], + "returnType": { + "kind": "constructor", + "path": "result", + "genericTypeParameters": [ + { "kind": "variable", "name": "a", "weak": false }, + { + "kind": "constructor", + "path": "string", + "genericTypeParameters": [] + } + ] + } + } + } + }, + { + "id": "DocgenSignatureDetails.takesCallback", + "kind": "value", + "name": "takesCallback", + "signature": "let takesCallback: ('a => string) => bool", + "docstrings": [ + "A callback remains one parameter instead of becoming outer parameters." + ], + "source": { + "filepath": "src/DocgenSignatureDetails.resi", + "line": 5, + "col": 1 + }, + "detail": { + "kind": "signature", + "details": { + "parameters": [ + { + "optional": false, + "type": { + "kind": "function", + "parameters": [ + { + "optional": false, + "type": { + "kind": "variable", + "name": "a", + "weak": false + } + } + ], + "returnType": { + "kind": "constructor", + "path": "string", + "genericTypeParameters": [] + } + } + } + ], + "returnType": { + "kind": "constructor", + "path": "bool", + "genericTypeParameters": [] + } + } + } + }, + { + "id": "DocgenSignatureDetails.returnsTuple", + "kind": "value", + "name": "returnsTuple", + "signature": "let returnsTuple: int => (string, int)", + "docstrings": [ "A tuple remains one return-type node." ], + "source": { + "filepath": "src/DocgenSignatureDetails.resi", + "line": 8, + "col": 1 + }, + "detail": { + "kind": "signature", + "details": { + "parameters": [ + { + "optional": false, + "type": { + "kind": "constructor", + "path": "int", + "genericTypeParameters": [] + } + } + ], + "returnType": { + "kind": "tuple", + "elements": [ + { + "kind": "constructor", + "path": "string", + "genericTypeParameters": [] + }, + { + "kind": "constructor", + "path": "int", + "genericTypeParameters": [] + } + ] + } + } + } + }, + { + "id": "DocgenSignatureDetails.returnsFunction", + "kind": "value", + "name": "returnsFunction", + "signature": "let returnsFunction: int => string => bool", + "docstrings": [ + "A returned function remains nested in the return type." + ], + "source": { + "filepath": "src/DocgenSignatureDetails.resi", + "line": 11, + "col": 1 + }, + "detail": { + "kind": "signature", + "details": { + "parameters": [ + { + "optional": false, + "type": { + "kind": "constructor", + "path": "int", + "genericTypeParameters": [] + } + } + ], + "returnType": { + "kind": "function", + "parameters": [ + { + "optional": false, + "type": { + "kind": "constructor", + "path": "string", + "genericTypeParameters": [] + } + } + ], + "returnType": { + "kind": "constructor", + "path": "bool", + "genericTypeParameters": [] + } + } + } + } + }, + { + "id": "DocgenSignatureDetails.takesVariant", + "kind": "value", + "name": "takesVariant", + "signature": "let takesVariant: [#count(int) | #enabled] => unit", + "docstrings": [ + "Less common type forms remain visible through an explicit fallback." + ], + "source": { + "filepath": "src/DocgenSignatureDetails.resi", + "line": 14, + "col": 1 + }, + "detail": { + "kind": "signature", + "details": { + "parameters": [ + { + "optional": false, + "type": { + "kind": "rendered", + "signature": "[#count(int) | #enabled]" + } + } + ], + "returnType": { + "kind": "constructor", + "path": "unit", + "genericTypeParameters": [] + } + } + } + }, + { + "id": "DocgenSignatureDetails.constant", + "kind": "value", + "name": "constant", + "signature": "let constant: int", + "docstrings": [ + "Non-functions do not receive function signature details." + ], + "source": { + "filepath": "src/DocgenSignatureDetails.resi", + "line": 17, + "col": 1 + } + } + ] +} diff --git a/tests/tools_tests/src/expected/ModC.res.json b/tests/tools_tests/src/expected/ModC.res.json index cc4cce09bba..db9cdf11e52 100644 --- a/tests/tools_tests/src/expected/ModC.res.json +++ b/tests/tools_tests/src/expected/ModC.res.json @@ -16,14 +16,7 @@ "name": "name", "signature": "let name: string", "docstrings": [], - "source": { "filepath": "src/ModC.resi", "line": 5, "col": 3 }, - "detail": { - "kind": "signature", - "details": { - "parameters": [], - "returnType": { "path": "string", "genericTypeParameters": [] } - } - } + "source": { "filepath": "src/ModC.resi", "line": 5, "col": 3 } } ] } diff --git a/tests/tools_tests/src/expected/ModC.resi.json b/tests/tools_tests/src/expected/ModC.resi.json index cc4cce09bba..db9cdf11e52 100644 --- a/tests/tools_tests/src/expected/ModC.resi.json +++ b/tests/tools_tests/src/expected/ModC.resi.json @@ -16,14 +16,7 @@ "name": "name", "signature": "let name: string", "docstrings": [], - "source": { "filepath": "src/ModC.resi", "line": 5, "col": 3 }, - "detail": { - "kind": "signature", - "details": { - "parameters": [], - "returnType": { "path": "string", "genericTypeParameters": [] } - } - } + "source": { "filepath": "src/ModC.resi", "line": 5, "col": 3 } } ] } diff --git a/tools/src/tools.ml b/tools/src/tools.ml index d7787073952..f893f81f986 100644 --- a/tools/src/tools.ml +++ b/tools/src/tools.ml @@ -20,8 +20,19 @@ type constructor_doc = { items: constructor_payload option; } -type type_doc = {path: string; generic_parameters: type_doc list} -type value_signature = {parameters: type_doc list; return_type: type_doc} +type type_doc = + | Constructor of {path: string; generic_parameters: type_doc list} + | Variable of {name: string; weak: bool} + | Tuple of type_doc list + | Function of value_signature + | Rendered of string + +and signature_parameter = {label: string option; optional: bool; typ: type_doc} + +and value_signature = { + parameters: signature_parameter list; + return_type: type_doc; +} type source = {filepath: string; line: int; col: int} @@ -103,13 +114,45 @@ let stringify_constructor_payload (constructor_payload : constructor_payload) = ("fields", `List (field_docs |> List.map stringify_field_doc)); ] -let rec stringify_type_doc (td : type_doc) = - let ps = - match td.generic_parameters with - | [] -> `List [] - | ts -> ts |> List.map stringify_type_doc |> fun ts -> `List ts - in - `Assoc [("path", `String td.path); ("genericTypeParameters", ps)] +let rec stringify_type_doc = function + | Constructor {path; generic_parameters} -> + `Assoc + [ + ("kind", `String "constructor"); + ("path", `String path); + ( "genericTypeParameters", + `List (List.map stringify_type_doc generic_parameters) ); + ] + | Variable {name; weak} -> + `Assoc + [ + ("kind", `String "variable"); + ("name", `String name); + ("weak", `Bool weak); + ] + | Tuple elements -> + `Assoc + [ + ("kind", `String "tuple"); + ("elements", `List (List.map stringify_type_doc elements)); + ] + | Function signature -> + `Assoc (("kind", `String "function") :: stringify_value_signature signature) + | Rendered signature -> + `Assoc [("kind", `String "rendered"); ("signature", `String signature)] + +and stringify_signature_parameter {label; optional; typ} = + `Assoc + ((match label with + | Some label -> [("label", `String label)] + | None -> []) + @ [("optional", `Bool optional); ("type", stringify_type_doc typ)]) + +and stringify_value_signature {parameters; return_type} = + [ + ("parameters", `List (List.map stringify_signature_parameter parameters)); + ("returnType", stringify_type_doc return_type); + ] let stringify_detail (detail : doc_item_detail) = match detail with @@ -147,18 +190,10 @@ let stringify_detail (detail : doc_item_detail) = | None -> []))) ); ] | Signature {parameters; return_type} -> - let ps = - match parameters with - | [] -> `List [] - | ps -> ps |> List.map stringify_type_doc |> fun ps -> `List ps - in `Assoc [ ("kind", `String "signature"); - ( "details", - `Assoc - [("parameters", ps); ("returnType", stringify_type_doc return_type)] - ); + ("details", `Assoc (stringify_value_signature {parameters; return_type})); ] let stringify_source source = @@ -309,60 +344,51 @@ let type_detail typ ~env ~full ~state = }) | _ -> None -(* split a list into two parts all the items except the last one and the last item *) -let split_last l = - let rec splitLast' acc = function - | [] -> failwith "splitLast: empty list" - | [x] -> (List.rev acc, x) - | x :: xs -> splitLast' (x :: acc) xs - in - splitLast' [] l +let rec string_of_out_ident = function + | Outcometree.Oide_ident name -> name + | Oide_dot (path, name) -> string_of_out_ident path ^ "." ^ name + | Oide_apply (functor_, argument) -> + string_of_out_ident functor_ ^ "(" ^ string_of_out_ident argument ^ ")" + +let render_out_type typ = + Res_doc.to_string ~width:80 (Res_outcome_printer.print_out_type_doc typ) + +let rec type_doc_of_out_type (typ : Outcometree.out_type) = + match typ with + | Otyp_constr (path, generic_parameters) -> + Constructor + { + path = string_of_out_ident path; + generic_parameters = List.map type_doc_of_out_type generic_parameters; + } + | Otyp_var (weak, name) -> Variable {name; weak} + | Otyp_tuple elements -> Tuple (List.map type_doc_of_out_type elements) + | Otyp_arrow (parameters, return_type) -> + Function (value_signature_of_arrow parameters return_type) + | _ -> Rendered (render_out_type typ) -let path_to_string path = - let buf = Buffer.create 64 in - let rec aux = function - | Path.Pident id -> Buffer.add_string buf (Ident.name id) - | Path.Pdot (p, s, _) -> - aux p; - Buffer.add_char buf '.'; - Buffer.add_string buf s - | Path.Papply (p1, p2) -> - aux p1; - Buffer.add_char buf '('; - aux p2; - Buffer.add_char buf ')' +and signature_parameter_of_out_type (label, typ) = + let label, optional = + match label with + | Asttypes.Noloc.Nolabel -> (None, false) + | Asttypes.Noloc.Labelled label -> (Some label, false) + | Asttypes.Noloc.Optional label -> (Some label, true) in - aux path; - Buffer.contents buf + {label; optional; typ = type_doc_of_out_type typ} + +and value_signature_of_arrow parameters return_type = + { + parameters = List.map signature_parameter_of_out_type parameters; + return_type = type_doc_of_out_type return_type; + } let value_detail (typ : Types.type_expr) = - let rec collect_signature_types (typ : Types.type_expr) = - match typ.desc with - | Tlink t | Tsubst t | Tpoly (t, []) -> collect_signature_types t - | Tconstr (path, ts, _) -> ( - let p = path_to_string path in - match ts with - | [] -> [{path = p; generic_parameters = []}] - | ts -> - let ts = - ts - |> List.concat_map (fun (t : Types.type_expr) -> - collect_signature_types t) - in - [{path = p; generic_parameters = ts}]) - | Tarrow (params, ret) -> - List.concat_map - (fun ({typ} : Types.arg) -> collect_signature_types typ) - params - @ collect_signature_types ret - | Tvar None -> [{path = "_"; generic_parameters = []}] - | _ -> [] - in - match collect_signature_types typ with - | [] -> None - | ts -> - let parameters, return_type = split_last ts in - Some (Signature {parameters; return_type}) + Printtyp.reset_names (); + Printtyp.reset_and_mark_loops typ; + match Printtyp.tree_of_typexp false typ with + | Otyp_arrow (parameters, return_type) -> + Some (Signature (value_signature_of_arrow parameters return_type)) + | _ -> None let make_id module_path ~identifier = identifier :: module_path |> List.rev |> Shared_types.ident