From ffc7666f699d6a0dadf86055c19200e10a4f4d64 Mon Sep 17 00:00:00 2001 From: nojaf Date: Thu, 10 Apr 2025 13:11:25 +0200 Subject: [PATCH 01/31] Add additional node to Pexp_apply --- analysis/src/CompletionFrontEnd.ml | 6 +++++- compiler/frontend/ast_compatible.ml | 18 ++++++++++++++++-- compiler/frontend/ast_exp_apply.ml | 8 +++++--- compiler/frontend/ast_uncurry_gen.ml | 1 + compiler/ml/ast_helper.ml | 4 ++-- compiler/ml/ast_helper.mli | 1 + compiler/ml/parsetree.ml | 1 + compiler/syntax/src/jsx_v4.ml | 21 +++++++++++---------- compiler/syntax/src/res_core.ml | 10 ++++++++-- compiler/syntax/src/res_parsetree_viewer.ml | 8 +++++++- 10 files changed, 57 insertions(+), 21 deletions(-) diff --git a/analysis/src/CompletionFrontEnd.ml b/analysis/src/CompletionFrontEnd.ml index e2d4a51f46..b1717ae893 100644 --- a/analysis/src/CompletionFrontEnd.ml +++ b/analysis/src/CompletionFrontEnd.ml @@ -267,12 +267,14 @@ let rec exprToContextPathInner ~(inJsxContext : bool) (e : Parsetree.expression) }; args = [(_, lhs); (_, {pexp_desc = Pexp_apply {funct = d; args; partial}})]; + transformed_jsx; } -> (* Transform away pipe with apply call *) exprToContextPath ~inJsxContext { pexp_desc = - Pexp_apply {funct = d; args = (Nolabel, lhs) :: args; partial}; + Pexp_apply + {funct = d; args = (Nolabel, lhs) :: args; partial; transformed_jsx}; pexp_loc; pexp_attributes; } @@ -284,6 +286,7 @@ let rec exprToContextPathInner ~(inJsxContext : bool) (e : Parsetree.expression) (_, lhs); (_, {pexp_desc = Pexp_ident id; pexp_loc; pexp_attributes}); ]; partial; + transformed_jsx; } -> (* Transform away pipe with identifier *) exprToContextPath ~inJsxContext @@ -294,6 +297,7 @@ let rec exprToContextPathInner ~(inJsxContext : bool) (e : Parsetree.expression) funct = {pexp_desc = Pexp_ident id; pexp_loc; pexp_attributes}; args = [(Nolabel, lhs)]; partial; + transformed_jsx; }; pexp_loc; pexp_attributes; diff --git a/compiler/frontend/ast_compatible.ml b/compiler/frontend/ast_compatible.ml index 04a1be4f4a..982957c02f 100644 --- a/compiler/frontend/ast_compatible.ml +++ b/compiler/frontend/ast_compatible.ml @@ -44,6 +44,7 @@ let apply_simple ?(loc = default_loc) ?(attrs = []) (fn : expression) funct = fn; args = Ext_list.map args (fun x -> (Asttypes.Nolabel, x)); partial = false; + transformed_jsx = None; }; } @@ -52,7 +53,13 @@ let app1 ?(loc = default_loc) ?(attrs = []) fn arg1 : expression = pexp_loc = loc; pexp_attributes = attrs; pexp_desc = - Pexp_apply {funct = fn; args = [(Nolabel, arg1)]; partial = false}; + Pexp_apply + { + funct = fn; + args = [(Nolabel, arg1)]; + partial = false; + transformed_jsx = None; + }; } let app2 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 : expression = @@ -61,7 +68,12 @@ let app2 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 : expression = pexp_attributes = attrs; pexp_desc = Pexp_apply - {funct = fn; args = [(Nolabel, arg1); (Nolabel, arg2)]; partial = false}; + { + funct = fn; + args = [(Nolabel, arg1); (Nolabel, arg2)]; + partial = false; + transformed_jsx = None; + }; } let app3 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 arg3 : expression = @@ -74,6 +86,7 @@ let app3 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 arg3 : expression = funct = fn; args = [(Nolabel, arg1); (Nolabel, arg2); (Nolabel, arg3)]; partial = false; + transformed_jsx = None; }; } @@ -121,6 +134,7 @@ let apply_labels ?(loc = default_loc) ?(attrs = []) fn Ext_list.map args (fun (l, a) -> (Asttypes.Labelled {txt = l; loc = Location.none}, a)); partial = false; + transformed_jsx = None; }; } diff --git a/compiler/frontend/ast_exp_apply.ml b/compiler/frontend/ast_exp_apply.ml index fb5b500db9..afffea4e3c 100644 --- a/compiler/frontend/ast_exp_apply.ml +++ b/compiler/frontend/ast_exp_apply.ml @@ -88,11 +88,12 @@ let app_exp_mapper (e : exp) (self : Bs_ast_mapper.mapper) : exp = {f with pexp_desc = Pexp_variant (label, Some a); pexp_loc = e.pexp_loc} | Pexp_construct (ctor, None) -> {f with pexp_desc = Pexp_construct (ctor, Some a); pexp_loc = e.pexp_loc} - | Pexp_apply {funct = fn1; args; partial} -> + | Pexp_apply {funct = fn1; args; partial; transformed_jsx} -> Bs_ast_invariant.warn_discarded_unused_attributes fn1.pexp_attributes; { pexp_desc = - Pexp_apply {funct = fn1; args = (Nolabel, a) :: args; partial}; + Pexp_apply + {funct = fn1; args = (Nolabel, a) :: args; partial; transformed_jsx}; pexp_loc = e.pexp_loc; pexp_attributes = e.pexp_attributes @ f.pexp_attributes; } @@ -108,7 +109,7 @@ let app_exp_mapper (e : exp) (self : Bs_ast_mapper.mapper) : exp = fn with pexp_desc = Pexp_construct (ctor, Some bounded_obj_arg); } - | Pexp_apply {funct = fn; args} -> + | Pexp_apply {funct = fn; args; transformed_jsx} -> Bs_ast_invariant.warn_discarded_unused_attributes fn.pexp_attributes; { @@ -118,6 +119,7 @@ let app_exp_mapper (e : exp) (self : Bs_ast_mapper.mapper) : exp = funct = fn; args = (Nolabel, bounded_obj_arg) :: args; partial = false; + transformed_jsx; }; pexp_attributes = []; pexp_loc = fn.pexp_loc; diff --git a/compiler/frontend/ast_uncurry_gen.ml b/compiler/frontend/ast_uncurry_gen.ml index 70e4e2d550..aa241deb83 100644 --- a/compiler/frontend/ast_uncurry_gen.ml +++ b/compiler/frontend/ast_uncurry_gen.ml @@ -75,4 +75,5 @@ let to_method_callback loc (self : Bs_ast_mapper.mapper) label [Typ.any ~loc ()]) ); ]; partial = false; + transformed_jsx = None; } diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index 347b5b5e0d..a10c55c5b2 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -154,8 +154,8 @@ module Exp = struct let fun_ ?loc ?attrs ?(async = false) ~arity a b c d = mk ?loc ?attrs (Pexp_fun {arg_label = a; default = b; lhs = c; rhs = d; arity; async}) - let apply ?loc ?attrs ?(partial = false) funct args = - mk ?loc ?attrs (Pexp_apply {funct; args; partial}) + let apply ?loc ?attrs ?(partial = false) ?transformed_jsx funct args = + mk ?loc ?attrs (Pexp_apply {funct; args; partial; transformed_jsx}) let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) let tuple ?loc ?attrs a = mk ?loc ?attrs (Pexp_tuple a) diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index d8cfef1c5e..73dda41177 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -149,6 +149,7 @@ module Exp : sig ?loc:loc -> ?attrs:attrs -> ?partial:bool -> + ?transformed_jsx:jsx_element -> expression -> (arg_label * expression) list -> expression diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index 1fefea4a2d..98a75e5a6c 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -244,6 +244,7 @@ and expression_desc = funct: expression; args: (arg_label * expression) list; partial: bool; + transformed_jsx: jsx_element option; } (* E0 ~l1:E1 ... ~ln:En li can be empty (non labeled argument) or start with '?' diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index febc245f21..45243d9795 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -1232,7 +1232,8 @@ let append_children_prop (config : Jsx_common.jsx_config) mapper [(Nolabel, Exp.array (List.map (mapper.expr mapper) xs))] ); ] -let mk_react_jsx (config : Jsx_common.jsx_config) mapper loc attrs +let mk_react_jsx (config : Jsx_common.jsx_config) mapper + (transformed_jsx : jsx_element) loc attrs (component_description : componentDescription) (elementTag : expression) (props : jsx_props) (children : jsx_children) : expression = let more_than_one_children = @@ -1277,7 +1278,7 @@ let mk_react_jsx (config : Jsx_common.jsx_config) mapper loc attrs [key_prop; (nolabel, unit_expr ~loc:Location.none)] ) in let args = [(nolabel, elementTag); (nolabel, props_record)] @ key_and_unit in - Exp.apply ~loc ~attrs jsx_expr args + Exp.apply ~loc ~attrs ~transformed_jsx jsx_expr args (* In most situations, the component name is the make function from a module. However, if the name contains a lowercase letter, it means it probably an external component. @@ -1306,8 +1307,8 @@ let expr ~(config : Jsx_common.jsx_config) mapper expression = let fragment = Exp.ident ~loc {loc; txt = module_access_name config "jsxFragment"} in - mk_react_jsx config mapper loc attrs FragmentComponent fragment [] - children + mk_react_jsx config mapper jsx_element loc attrs FragmentComponent + fragment [] children | Jsx_unary_element {jsx_unary_element_tag_name = tag_name; jsx_unary_element_props = props} -> @@ -1315,13 +1316,13 @@ let expr ~(config : Jsx_common.jsx_config) mapper expression = if starts_with_lowercase name then (* For example 'input' *) let component_name_expr = constant_string ~loc:tag_name.loc name in - mk_react_jsx config mapper loc attrs LowercasedComponent + mk_react_jsx config mapper jsx_element loc attrs LowercasedComponent component_name_expr props (JSXChildrenItems []) else if starts_with_uppercase name then (* MyModule.make *) let make_id = mk_uppercase_tag_name_expr tag_name in - mk_react_jsx config mapper loc attrs UppercasedComponent make_id props - (JSXChildrenItems []) + mk_react_jsx config mapper jsx_element loc attrs UppercasedComponent + make_id props (JSXChildrenItems []) else Jsx_common.raise_error ~loc "JSX: element name is neither upper- or lowercase, got \"%s\"" @@ -1338,13 +1339,13 @@ let expr ~(config : Jsx_common.jsx_config) mapper expression = *) if starts_with_lowercase name then let component_name_expr = constant_string ~loc:tag_name.loc name in - mk_react_jsx config mapper loc attrs LowercasedComponent + mk_react_jsx config mapper jsx_element loc attrs LowercasedComponent component_name_expr props children else if starts_with_uppercase name then (* MyModule.make *) let make_id = mk_uppercase_tag_name_expr tag_name in - mk_react_jsx config mapper loc attrs UppercasedComponent make_id props - children + mk_react_jsx config mapper jsx_element loc attrs UppercasedComponent + make_id props children else Jsx_common.raise_error ~loc "JSX: element name is neither upper- or lowercase, got \"%s\"" diff --git a/compiler/syntax/src/res_core.ml b/compiler/syntax/src/res_core.ml index c9c36496c6..e610d4589d 100644 --- a/compiler/syntax/src/res_core.ml +++ b/compiler/syntax/src/res_core.ml @@ -2188,12 +2188,18 @@ and parse_binary_expr ?(context = OrdinaryExpr) ?a p prec = let loc = mk_loc a.Parsetree.pexp_loc.loc_start b.pexp_loc.loc_end in let expr = match (token, b.pexp_desc) with - | BarGreater, Pexp_apply {funct = fun_expr; args; partial} -> + | ( BarGreater, + Pexp_apply {funct = fun_expr; args; partial; transformed_jsx} ) -> { b with pexp_desc = Pexp_apply - {funct = fun_expr; args = args @ [(Nolabel, a)]; partial}; + { + funct = fun_expr; + args = args @ [(Nolabel, a)]; + partial; + transformed_jsx; + }; } | BarGreater, _ -> Ast_helper.Exp.apply ~loc b [(Nolabel, a)] | _ -> diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index b2d6444e59..171e624aa9 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -142,7 +142,13 @@ let rewrite_underscore_apply expr = { e with pexp_desc = - Pexp_apply {funct = call_expr; args = new_args; partial = false}; + Pexp_apply + { + funct = call_expr; + args = new_args; + partial = false; + transformed_jsx = None; + }; } | _ -> expr From 92e38cbddc71d532073e9f991568c94a00938833 Mon Sep 17 00:00:00 2001 From: nojaf Date: Thu, 10 Apr 2025 14:18:11 +0200 Subject: [PATCH 02/31] Try and pass jsx_element from typed_tree to js_call --- compiler/core/js_call_info.ml | 14 +++++--- compiler/core/js_call_info.mli | 6 +++- compiler/core/js_dump.ml | 4 +++ compiler/core/lam.ml | 31 ++++++++++------ compiler/core/lam.mli | 14 ++++++-- compiler/core/lam_bounded_vars.ml | 4 +-- compiler/core/lam_compile.ml | 39 +++++++++++++++----- compiler/core/lam_compile_external_call.ml | 41 +++++++++++++++++----- compiler/core/lam_compile_primitive.ml | 9 +++-- compiler/core/lam_convert.ml | 14 ++++++-- compiler/core/lam_pass_alpha_conversion.ml | 16 +++++---- compiler/core/lam_pass_deep_flatten.ml | 4 +-- compiler/core/lam_pass_eliminate_ref.ml | 6 ++-- compiler/core/lam_pass_exits.ml | 6 ++-- compiler/core/lam_pass_lets_dce.ml | 3 +- compiler/core/lam_pass_remove_alias.ml | 14 +++++--- compiler/core/lam_util.ml | 4 +-- compiler/ml/lambda.ml | 1 + compiler/ml/lambda.mli | 1 + compiler/ml/matching.ml | 1 + compiler/ml/tast_mapper.ml | 3 +- compiler/ml/translcore.ml | 30 ++++++++++++---- compiler/ml/translmod.ml | 2 ++ compiler/ml/typecore.ml | 4 +-- compiler/ml/typedtree.ml | 1 + compiler/ml/typedtree.mli | 1 + 26 files changed, 201 insertions(+), 72 deletions(-) diff --git a/compiler/core/js_call_info.ml b/compiler/core/js_call_info.ml index 547f03c7f8..8d9c61584e 100644 --- a/compiler/core/js_call_info.ml +++ b/compiler/core/js_call_info.ml @@ -33,10 +33,16 @@ type call_info = {[ fun x y -> (f x y) === f ]} when [f] is an atom *) -type t = {call_info: call_info; arity: arity} +type t = { + call_info: call_info; + arity: arity; + call_transformed_jsx: Parsetree.jsx_element option; +} -let dummy = {arity = NA; call_info = Call_na} +let dummy = {arity = NA; call_info = Call_na; call_transformed_jsx = None} -let builtin_runtime_call = {arity = Full; call_info = Call_builtin_runtime} +let builtin_runtime_call = + {arity = Full; call_info = Call_builtin_runtime; call_transformed_jsx = None} -let ml_full_call = {arity = Full; call_info = Call_ml} +let ml_full_call = + {arity = Full; call_info = Call_ml; call_transformed_jsx = None} diff --git a/compiler/core/js_call_info.mli b/compiler/core/js_call_info.mli index 0381c0cd2b..9fe502556d 100644 --- a/compiler/core/js_call_info.mli +++ b/compiler/core/js_call_info.mli @@ -35,7 +35,11 @@ type call_info = {[ fun x y -> f x y === f ]} when [f] is an atom *) -type t = {call_info: call_info; arity: arity} +type t = { + call_info: call_info; + arity: arity; + call_transformed_jsx: Parsetree.jsx_element option; +} val dummy : t diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index bc174e7dd5..17be079918 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -524,6 +524,10 @@ and expression_desc cxt ~(level : int) f x : cxt = when Ext_list.length_equal el i ]} *) + | Call (e, el, {call_transformed_jsx = Some jsx_element}) -> + (* The grand point would be to reconstruct the JSX here *) + P.string f ""; + cxt | Call (e, el, info) -> P.cond_paren_group f (level > 15) (fun _ -> P.group f 0 (fun _ -> diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index 77f991e181..e9eb2fdebc 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -81,7 +81,12 @@ module Types = struct *) and prim_info = {primitive: Lam_primitive.t; args: t list; loc: Location.t} - and apply = {ap_func: t; ap_args: t list; ap_info: ap_info} + and apply = { + ap_func: t; + ap_args: t list; + ap_info: ap_info; + ap_transformed_jsx: Parsetree.jsx_element option; + } and t = | Lvar of ident @@ -121,7 +126,12 @@ module X = struct loc: Location.t; } - and apply = Types.apply = {ap_func: t; ap_args: t list; ap_info: ap_info} + and apply = Types.apply = { + ap_func: t; + ap_args: t list; + ap_info: ap_info; + ap_transformed_jsx: Parsetree.jsx_element option; + } and lfunction = Types.lfunction = { arity: int; @@ -159,10 +169,10 @@ include Types let inner_map (l : t) (f : t -> X.t) : X.t = match l with | Lvar (_ : ident) | Lconst (_ : Lam_constant.t) -> ((* Obj.magic *) l : X.t) - | Lapply {ap_func; ap_args; ap_info} -> + | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> let ap_func = f ap_func in let ap_args = Ext_list.map ap_args f in - Lapply {ap_func; ap_args; ap_info} + Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} | Lfunction {body; arity; params; attr} -> let body = f body in Lfunction {body; arity; params; attr} @@ -279,7 +289,7 @@ let rec is_eta_conversion_exn params inner_args outer_args : t list = | _, _, _ -> raise_notrace Not_simple_form (** FIXME: more robust inlining check later, we should inline it before we add stub code*) -let rec apply fn args (ap_info : ap_info) : t = +let rec apply ?(ap_transformed_jsx = None) fn args (ap_info : ap_info) : t = match fn with | Lfunction { @@ -300,7 +310,7 @@ let rec apply fn args (ap_info : ap_info) : t = Lprim {primitive = wrap; args = [Lprim {primitive_call with args; loc}]; loc} | exception Not_simple_form -> - Lapply {ap_func = fn; ap_args = args; ap_info}) + Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}) | Lfunction { params; @@ -308,7 +318,8 @@ let rec apply fn args (ap_info : ap_info) : t = } -> ( match is_eta_conversion_exn params inner_args args with | args -> Lprim {primitive_call with args; loc = ap_info.ap_loc} - | exception _ -> Lapply {ap_func = fn; ap_args = args; ap_info}) + | exception _ -> + Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx}) | Lfunction { params; @@ -321,17 +332,17 @@ let rec apply fn args (ap_info : ap_info) : t = | args -> Lsequence (Lprim {primitive_call with args; loc = ap_info.ap_loc}, const) | exception _ -> - Lapply {ap_func = fn; ap_args = args; ap_info} + Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx} (* | Lfunction {params;body} when Ext_list.same_length params args -> Ext_list.fold_right2 (fun p arg acc -> Llet(Strict,p,arg,acc) ) params args body *) (* TODO: more rigirous analysis on [let_kind] *)) | Llet (kind, id, e, (Lfunction _ as fn)) -> - Llet (kind, id, e, apply fn args ap_info) + Llet (kind, id, e, apply fn args ap_info ~ap_transformed_jsx) (* | Llet (kind0, id0, e0, Llet (kind,id, e, (Lfunction _ as fn))) -> Llet(kind0,id0,e0,Llet (kind, id, e, apply fn args loc status)) *) - | _ -> Lapply {ap_func = fn; ap_args = args; ap_info} + | _ -> Lapply {ap_func = fn; ap_args = args; ap_info; ap_transformed_jsx} let rec eq_approx (l1 : t) (l2 : t) = match l1 with diff --git a/compiler/core/lam.mli b/compiler/core/lam.mli index 66858ac2a4..9d009b959c 100644 --- a/compiler/core/lam.mli +++ b/compiler/core/lam.mli @@ -41,7 +41,12 @@ type lambda_switch = { sw_names: Ast_untagged_variants.switch_names option; } -and apply = private {ap_func: t; ap_args: t list; ap_info: ap_info} +and apply = private { + ap_func: t; + ap_args: t list; + ap_info: ap_info; + ap_transformed_jsx: Parsetree.jsx_element option; +} and lfunction = { arity: int; @@ -103,7 +108,12 @@ val global_module : ?dynamic_import:bool -> ident -> t val const : Lam_constant.t -> t -val apply : t -> t list -> ap_info -> t +val apply : + ?ap_transformed_jsx:Parsetree.jsx_element option -> + t -> + t list -> + ap_info -> + t val function_ : attr:Lambda.function_attribute -> diff --git a/compiler/core/lam_bounded_vars.ml b/compiler/core/lam_bounded_vars.ml index 15ee9cff97..e038e56798 100644 --- a/compiler/core/lam_bounded_vars.ml +++ b/compiler/core/lam_bounded_vars.ml @@ -108,10 +108,10 @@ let rewrite (map : _ Hash_ident.t) (lam : Lam.t) : Lam.t = (* here it makes sure that global vars are not rebound *) Lam.prim ~primitive ~args:(Ext_list.map args aux) loc | Lglobal_module _ -> lam - | Lapply {ap_func; ap_args; ap_info} -> + | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> let fn = aux ap_func in let args = Ext_list.map ap_args aux in - Lam.apply fn args ap_info + Lam.apply ~ap_transformed_jsx fn args ap_info | Lswitch ( l, { diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index ea865bbe6f..893fd9fd7a 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -31,12 +31,13 @@ let args_either_function_or_const (args : Lam.t list) = | Lfunction _ | Lconst _ -> true | _ -> false) -let call_info_of_ap_status (ap_status : Lam.apply_status) : Js_call_info.t = +let call_info_of_ap_status call_transformed_jsx (ap_status : Lam.apply_status) : + Js_call_info.t = (* XXX *) match ap_status with - | App_infer_full -> {arity = Full; call_info = Call_ml} - | App_uncurry -> {arity = Full; call_info = Call_na} - | App_na -> {arity = NA; call_info = Call_ml} + | App_infer_full -> {arity = Full; call_info = Call_ml; call_transformed_jsx} + | App_uncurry -> {arity = Full; call_info = Call_na; call_transformed_jsx} + | App_na -> {arity = NA; call_info = Call_ml; call_transformed_jsx} let rec apply_with_arity_aux (fn : J.expression) (arity : int list) (args : E.t list) (len : int) : E.t = @@ -49,7 +50,14 @@ let rec apply_with_arity_aux (fn : J.expression) (arity : int list) if len >= x then let first_part, continue = Ext_list.split_at args x in apply_with_arity_aux - (E.call ~info:{arity = Full; call_info = Call_ml} fn first_part) + (E.call + ~info: + { + arity = Full; + call_info = Call_ml; + (* no clue if this is correct *) call_transformed_jsx = None; + } + fn first_part) rest continue (len - x) else if (* GPR #1423 *) @@ -63,7 +71,13 @@ let rec apply_with_arity_aux (fn : J.expression) (arity : int list) [ S.return_stmt (E.call - ~info:{arity = Full; call_info = Call_ml} + ~info: + { + arity = Full; + call_info = Call_ml; + (* no clue if this is correct *) call_transformed_jsx = + None; + } fn (Ext_list.append args @@ Ext_list.map params E.var)); ] @@ -306,7 +320,9 @@ let compile output_prefix = let expression = match appinfo.ap_info.ap_status with | (App_infer_full | App_uncurry) as ap_status -> - E.call ~info:(call_info_of_ap_status ap_status) fn args + E.call + ~info:(call_info_of_ap_status appinfo.ap_transformed_jsx ap_status) + fn args | App_na -> ( match ident_info.arity with | Submodule _ | Single Arity_na -> @@ -1439,6 +1455,7 @@ let compile output_prefix = ap_func = Lapply {ap_func; ap_args; ap_info = {ap_status = App_na; ap_inlined}}; ap_info = {ap_status = App_na} as outer_ap_info; + ap_transformed_jsx; } -> (* After inlining, we can generate such code, see {!Ari_regress_test}*) let ap_info = @@ -1446,7 +1463,9 @@ let compile output_prefix = else {outer_ap_info with ap_inlined} in compile_lambda lambda_cxt - (Lam.apply ap_func (Ext_list.append ap_args appinfo.ap_args) ap_info) + (Lam.apply ap_func + (Ext_list.append ap_args appinfo.ap_args) + ap_info ~ap_transformed_jsx) (* External function call: it can not be tailcall in this case*) | { ap_func = @@ -1529,7 +1548,9 @@ let compile output_prefix = Js_output.output_of_block_and_expression lambda_cxt.continuation args_code (E.call - ~info:(call_info_of_ap_status appinfo.ap_info.ap_status) + ~info: + (call_info_of_ap_status appinfo.ap_transformed_jsx + appinfo.ap_info.ap_status) fn_code args)) and compile_prim (prim_info : Lam.prim_info) (lambda_cxt : Lam_compile_context.t) = diff --git a/compiler/core/lam_compile_external_call.ml b/compiler/core/lam_compile_external_call.ml index 6d9056e570..fa2c720702 100644 --- a/compiler/core/lam_compile_external_call.ml +++ b/compiler/core/lam_compile_external_call.ml @@ -287,7 +287,11 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types | _ -> let args, eff, dynamic = assemble_args_has_splice arg_types args in let args = if dynamic then E.variadic_args args else args in - add_eff eff (E.call ~info:{arity = Full; call_info = Call_na} fn args)) + add_eff eff + (E.call + ~info: + {arity = Full; call_info = Call_na; call_transformed_jsx = None} + fn args)) | Js_call { external_module_name = module_name; @@ -302,20 +306,36 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types if splice then let args, eff, dynamic = assemble_args_has_splice arg_types args in let args = if dynamic then E.variadic_args args else args in - add_eff eff (E.call ~info:{arity = Full; call_info = Call_na} fn args) + add_eff eff + (E.call + ~info: + {arity = Full; call_info = Call_na; call_transformed_jsx = None} + fn args) else let args, eff = assemble_args_no_splice arg_types args in - add_eff eff @@ E.call ~info:{arity = Full; call_info = Call_na} fn args + add_eff eff + @@ E.call + ~info: + {arity = Full; call_info = Call_na; call_transformed_jsx = None} + fn args | Js_module_as_fn {external_module_name; splice} -> let fn = external_var external_module_name ~dynamic_import in if splice then let args, eff, dynamic = assemble_args_has_splice arg_types args in let args = if dynamic then E.variadic_args args else args in - add_eff eff (E.call ~info:{arity = Full; call_info = Call_na} fn args) + add_eff eff + (E.call + ~info: + {arity = Full; call_info = Call_na; call_transformed_jsx = None} + fn args) else let args, eff = assemble_args_no_splice arg_types args in (* TODO: fix in rest calling convention *) - add_eff eff (E.call ~info:{arity = Full; call_info = Call_na} fn args) + add_eff eff + (E.call + ~info: + {arity = Full; call_info = Call_na; call_transformed_jsx = None} + fn args) | Js_new {external_module_name = module_name; name = fn; splice; scopes} -> (* handle [@@new]*) (* This has some side effect, it will @@ -362,14 +382,16 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types add_eff eff (let self = translate_scoped_access js_send_scopes self in E.call - ~info:{arity = Full; call_info = Call_na} + ~info: + {arity = Full; call_info = Call_na; call_transformed_jsx = None} (E.dot self name) args) else let args, eff = assemble_args_no_splice arg_types args in add_eff eff (let self = translate_scoped_access js_send_scopes self in E.call - ~info:{arity = Full; call_info = Call_na} + ~info: + {arity = Full; call_info = Call_na; call_transformed_jsx = None} (E.dot self name) args) | _ -> assert false) | Js_module_as_var module_name -> external_var module_name ~dynamic_import @@ -384,7 +406,10 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types ~dynamic_import in if args = [] then e - else E.call ~info:{arity = Full; call_info = Call_na} e args + else + E.call + ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = None} + e args | Js_module_as_class module_name -> let fn = external_var module_name ~dynamic_import in let args, eff = assemble_args_no_splice arg_types args in diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index aac979d926..272b4ff05d 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -56,14 +56,14 @@ let get_module_system () = let import_of_path path = E.call - ~info:{arity = Full; call_info = Call_na} + ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = None} (E.js_global "import") [E.str path] let wrap_then import value = let arg = Ident.create "m" in E.call - ~info:{arity = Full; call_info = Call_na} + ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = None} (E.dot import "then") [ E.ocaml_fun ~return_unit:false ~async:false ~one_unit_arg:false [arg] @@ -88,7 +88,10 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) | _ -> assert false) | Pjs_apply -> ( match args with - | fn :: rest -> E.call ~info:{arity = Full; call_info = Call_na} fn rest + | fn :: rest -> + E.call + ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = None} + fn rest | _ -> assert false) | Pnull_to_opt -> ( match args with diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 3f252011ef..7db4e6a9b5 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -414,11 +414,19 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : let setter = Ext_string.ends_with name Literals.setter_suffix in let _ = assert (not setter) in prim ~primitive:(Pjs_unsafe_downgrade {name; setter}) ~args loc - | Lapply {ap_func = fn; ap_args = args; ap_loc = loc; ap_inlined} -> + | Lapply + { + ap_func = fn; + ap_args = args; + ap_loc = loc; + ap_inlined; + ap_transformed_jsx; + } -> (* we need do this eargly in case [aux fn] add some wrapper *) Lam.apply (convert_aux fn) (Ext_list.map args convert_aux) {ap_loc = loc; ap_inlined; ap_status = App_uncurry} + ~ap_transformed_jsx | Lfunction {params; body; attr} -> let new_map, body = rename_optional_parameters Map_ident.empty params body @@ -571,8 +579,8 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : when Ext_list.for_all2_no_exn inner_args params lam_is_var && Ext_list.length_larger_than_n inner_args args 1 -> Lam.prim ~primitive ~args:(Ext_list.append_one args x) outer_loc - | Lapply {ap_func; ap_args; ap_info} -> - Lam.apply ap_func + | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> + Lam.apply ~ap_transformed_jsx ap_func (Ext_list.append_one ap_args x) { ap_loc = outer_loc; diff --git a/compiler/core/lam_pass_alpha_conversion.ml b/compiler/core/lam_pass_alpha_conversion.ml index 3beadbeb0e..6cadf4a35e 100644 --- a/compiler/core/lam_pass_alpha_conversion.ml +++ b/compiler/core/lam_pass_alpha_conversion.ml @@ -23,14 +23,17 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = - let rec populate_apply_info (args_arity : int list) (len : int) (fn : Lam.t) - (args : Lam.t list) ap_info : Lam.t = + let rec populate_apply_info ?(ap_transformed_jsx = None) + (args_arity : int list) (len : int) (fn : Lam.t) (args : Lam.t list) + ap_info : Lam.t = match args_arity with - | 0 :: _ | [] -> Lam.apply (simpl fn) (Ext_list.map args simpl) ap_info + | 0 :: _ | [] -> + Lam.apply (simpl fn) (Ext_list.map args simpl) ap_info ~ap_transformed_jsx | x :: _ -> if x = len then Lam.apply (simpl fn) (Ext_list.map args simpl) {ap_info with ap_status = App_infer_full} + ~ap_transformed_jsx else if x > len then let fn = simpl fn in let args = Ext_list.map args simpl in @@ -39,7 +42,7 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = fn args else let first, rest = Ext_list.split_at args x in - Lam.apply + Lam.apply ~ap_transformed_jsx (Lam.apply (simpl fn) (Ext_list.map first simpl) {ap_info with ap_status = App_infer_full}) (Ext_list.map rest simpl) ap_info @@ -48,13 +51,14 @@ let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = match lam with | Lconst _ -> lam | Lvar _ -> lam - | Lapply {ap_func; ap_args; ap_info} -> + | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> (* detect functor application *) let args_arity = Lam_arity.extract_arity (Lam_arity_analysis.get_arity meta ap_func) in let len = List.length ap_args in - populate_apply_info args_arity len ap_func ap_args ap_info + populate_apply_info ~ap_transformed_jsx args_arity len ap_func ap_args + ap_info | Llet (str, v, l1, l2) -> Lam.let_ str v (simpl l1) (simpl l2) | Lletrec (bindings, body) -> let bindings = Ext_list.map_snd bindings simpl in diff --git a/compiler/core/lam_pass_deep_flatten.ml b/compiler/core/lam_pass_deep_flatten.ml index c55aeec841..0eddcb1a9d 100644 --- a/compiler/core/lam_pass_deep_flatten.ml +++ b/compiler/core/lam_pass_deep_flatten.ml @@ -224,8 +224,8 @@ let deep_flatten (lam : Lam.t) : Lam.t = (* can we switch to the tupled backend? *\) *) (* when List.length params = List.length args -> *) (* aux (beta_reduce params body args) *) - | Lapply {ap_func = l1; ap_args = ll; ap_info} -> - Lam.apply (aux l1) (Ext_list.map ll aux) ap_info + | Lapply {ap_func = l1; ap_args = ll; ap_info; ap_transformed_jsx} -> + Lam.apply (aux l1) (Ext_list.map ll aux) ap_info ~ap_transformed_jsx (* This kind of simple optimizations should be done each time and as early as possible *) | Lglobal_module _ -> lam diff --git a/compiler/core/lam_pass_eliminate_ref.ml b/compiler/core/lam_pass_eliminate_ref.ml index 4a251c1877..eb54fb2067 100644 --- a/compiler/core/lam_pass_eliminate_ref.ml +++ b/compiler/core/lam_pass_eliminate_ref.ml @@ -52,8 +52,10 @@ let rec eliminate_ref id (lam : Lam.t) = Lam.assign id (Lam.prim ~primitive:(Poffsetint delta) ~args:[Lam.var id] loc) | Lconst _ -> lam - | Lapply {ap_func = e1; ap_args = el; ap_info} -> - Lam.apply (eliminate_ref id e1) (Ext_list.map el (eliminate_ref id)) ap_info + | Lapply {ap_func = e1; ap_args = el; ap_info; ap_transformed_jsx} -> + Lam.apply ~ap_transformed_jsx (eliminate_ref id e1) + (Ext_list.map el (eliminate_ref id)) + ap_info | Llet (str, v, e1, e2) -> Lam.let_ str v (eliminate_ref id e1) (eliminate_ref id e2) | Lletrec (idel, e2) -> diff --git a/compiler/core/lam_pass_exits.ml b/compiler/core/lam_pass_exits.ml index ceba4af6e5..2eb6295699 100644 --- a/compiler/core/lam_pass_exits.ml +++ b/compiler/core/lam_pass_exits.ml @@ -199,8 +199,10 @@ let subst_helper (subst : subst_tbl) (query : int -> int) (lam : Lam.t) : Lam.t Lam.let_ Strict y l r) | None -> Lam.staticraise i ls) | Lvar _ | Lconst _ -> lam - | Lapply {ap_func; ap_args; ap_info} -> - Lam.apply (simplif ap_func) (Ext_list.map ap_args simplif) ap_info + | Lapply {ap_func; ap_args; ap_info; ap_transformed_jsx} -> + Lam.apply (simplif ap_func) + (Ext_list.map ap_args simplif) + ap_info ~ap_transformed_jsx | Lfunction {arity; params; body; attr} -> Lam.function_ ~arity ~params ~body:(simplif body) ~attr | Llet (kind, v, l1, l2) -> Lam.let_ kind v (simplif l1) (simplif l2) diff --git a/compiler/core/lam_pass_lets_dce.ml b/compiler/core/lam_pass_lets_dce.ml index ca6e32bc7c..04ab02d4bc 100644 --- a/compiler/core/lam_pass_lets_dce.ml +++ b/compiler/core/lam_pass_lets_dce.ml @@ -144,8 +144,9 @@ let lets_helper (count_var : Ident.t -> Lam_pass_count.used_info) lam : Lam.t = (* *\) *) (* when Ext_list.same_length params args -> *) (* simplif (Lam_beta_reduce.beta_reduce params body args) *) - | Lapply {ap_func = l1; ap_args = ll; ap_info} -> + | Lapply {ap_func = l1; ap_args = ll; ap_info; ap_transformed_jsx} -> Lam.apply (simplif l1) (Ext_list.map ll simplif) ap_info + ~ap_transformed_jsx | Lfunction {arity; params; body; attr} -> Lam.function_ ~arity ~params ~body:(simplif body) ~attr | Lconst _ -> lam diff --git a/compiler/core/lam_pass_remove_alias.ml b/compiler/core/lam_pass_remove_alias.ml index 065ea65edf..67472564fe 100644 --- a/compiler/core/lam_pass_remove_alias.ml +++ b/compiler/core/lam_pass_remove_alias.ml @@ -140,19 +140,23 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = | _ -> true) && Lam_analysis.lfunction_can_be_inlined lfunction -> simpl (Lam_beta_reduce.propagate_beta_reduce meta params body args) - | _ -> Lam.apply (simpl l1) (Ext_list.map args simpl) ap_info) + | _ -> + Lam.apply (simpl l1) (Ext_list.map args simpl) ap_info + ?ap_transformed_jsx:None) (* Function inlining interact with other optimizations... - parameter attributes - scope issues - code bloat *) - | Lapply {ap_func = Lvar v as fn; ap_args; ap_info} -> ( + | Lapply {ap_func = Lvar v as fn; ap_args; ap_info; ap_transformed_jsx} -> ( (* Check info for always inlining *) (* Ext_log.dwarn __LOC__ "%s/%d" v.name v.stamp; *) let ap_args = Ext_list.map ap_args simpl in - let[@local] normal () = Lam.apply (simpl fn) ap_args ap_info in + let[@local] normal () = + Lam.apply (simpl fn) ap_args ap_info ~ap_transformed_jsx + in match Hash_ident.find_opt meta.ident_tbl v with | Some (FunctionId @@ -221,8 +225,8 @@ let simplify_alias (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = (* *\) *) (* when Ext_list.same_length params args -> *) (* simpl (Lam_beta_reduce.propogate_beta_reduce meta params body args) *) - | Lapply {ap_func = l1; ap_args = ll; ap_info} -> - Lam.apply (simpl l1) (Ext_list.map ll simpl) ap_info + | Lapply {ap_func = l1; ap_args = ll; ap_info; ap_transformed_jsx} -> + Lam.apply (simpl l1) (Ext_list.map ll simpl) ap_info ~ap_transformed_jsx | Lfunction {arity; params; body; attr} -> Lam.function_ ~arity ~params ~body:(simpl body) ~attr | Lswitch diff --git a/compiler/core/lam_util.ml b/compiler/core/lam_util.ml index 7ea859f6be..f85cdc0f41 100644 --- a/compiler/core/lam_util.ml +++ b/compiler/core/lam_util.ml @@ -66,7 +66,7 @@ let refine_let (* let v= subst_lambda (Map_ident.singleton param arg ) l in *) (* Ext_log.err "@[substitution << @]@."; *) (* v *) - | _, _, Lapply {ap_func=fn; ap_args = [Lvar w]; ap_info} when + | _, _, Lapply {ap_func=fn; ap_args = [Lvar w]; ap_info; ap_transformed_jsx} when Ident.same w param && (not (Lam_hit.hit_variable param fn )) -> @@ -79,7 +79,7 @@ let refine_let ]} #1667 make sure body does not hit k *) - Lam.apply fn [arg] ap_info + Lam.apply fn [arg] ap_info ~ap_transformed_jsx | (Strict | StrictOpt ), ( Lvar _ | Lconst _ | Lprim {primitive = Pfield (_ , Fld_module _) ; diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 26aa8a8c74..c0111641d6 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -383,6 +383,7 @@ and lambda_apply = { ap_args: lambda list; ap_loc: Location.t; ap_inlined: inline_attribute; + ap_transformed_jsx: Parsetree.jsx_element option; } and lambda_switch = { diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 9e1c9b9d7c..2aefe2bbe2 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -352,6 +352,7 @@ and lambda_apply = { ap_args: lambda list; ap_loc: Location.t; ap_inlined: inline_attribute; (* specified with the [@inlined] attribute *) + ap_transformed_jsx: Parsetree.jsx_element option; } and lambda_switch = { diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index fd90f38535..3f7de33bee 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1449,6 +1449,7 @@ let inline_lazy_force arg loc = ap_inlined = Default_inline; ap_args = [arg]; ap_loc = loc; + ap_transformed_jsx = None; } let make_lazy_matching def = function | [] -> fatal_error "Matching.make_lazy_matching" diff --git a/compiler/ml/tast_mapper.ml b/compiler/ml/tast_mapper.ml index 8064d65990..c2e33e7b4f 100644 --- a/compiler/ml/tast_mapper.ml +++ b/compiler/ml/tast_mapper.ml @@ -199,12 +199,13 @@ let expr sub x = | Texp_function {arg_label; arity; param; case; partial; async} -> Texp_function {arg_label; arity; param; case = sub.case sub case; partial; async} - | Texp_apply {funct = exp; args = list; partial} -> + | Texp_apply {funct = exp; args = list; partial; transformed_jsx} -> Texp_apply { funct = sub.expr sub exp; args = List.map (tuple2 id (opt (sub.expr sub))) list; partial; + transformed_jsx; } | Texp_match (exp, cases, exn_cases, p) -> Texp_match diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 4cdeb34aa5..b8fd18ff29 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -710,6 +710,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = exp_type = prim_type; } as funct; args = oargs; + transformed_jsx; } when List.length oargs >= p.prim_arity && List.for_all (fun (_, arg) -> arg <> None) oargs -> ( @@ -720,7 +721,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = let inlined, _ = Translattribute.get_and_remove_inlined_attribute funct in - transl_apply ~inlined f args' e.exp_loc + transl_apply ~inlined ~transformed_jsx f args' e.exp_loc in let args = List.map @@ -750,7 +751,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | _, _ -> ( match (prim, argl) with | _ -> wrap (Lprim (prim, argl, e.exp_loc)))) - | Texp_apply {funct; args = oargs; partial} -> + | Texp_apply {funct; args = oargs; partial; transformed_jsx} -> let inlined, funct = Translattribute.get_and_remove_inlined_attribute funct in @@ -766,8 +767,8 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | None -> None else None in - transl_apply ~inlined ~uncurried_partial_application (transl_exp funct) - oargs e.exp_loc + transl_apply ~inlined ~uncurried_partial_application ~transformed_jsx + (transl_exp funct) oargs e.exp_loc | Texp_match (arg, pat_expr_list, exn_pat_expr_list, partial) -> transl_match e arg pat_expr_list exn_pat_expr_list partial | Texp_try (body, pat_expr_list) -> @@ -948,9 +949,17 @@ and transl_case_try {c_lhs; c_guard; c_rhs} = and transl_cases_try cases = List.map transl_case_try cases and transl_apply ?(inlined = Default_inline) - ?(uncurried_partial_application = None) lam sargs loc = + ?(uncurried_partial_application = None) ?(transformed_jsx = None) lam sargs + loc = let lapply ap_func ap_args = - Lapply {ap_loc = loc; ap_func; ap_args; ap_inlined = inlined} + Lapply + { + ap_loc = loc; + ap_func; + ap_args; + ap_inlined = inlined; + ap_transformed_jsx = transformed_jsx; + } in let rec build_apply lam args = function | (None, optional) :: l -> @@ -1008,7 +1017,14 @@ and transl_apply ?(inlined = Default_inline) let extra_args = Ext_list.map extra_ids (fun id -> Lvar id) in let ap_args = args @ extra_args in let l0 = - Lapply {ap_func = lam; ap_args; ap_inlined = inlined; ap_loc = loc} + Lapply + { + ap_func = lam; + ap_args; + ap_inlined = inlined; + ap_loc = loc; + ap_transformed_jsx = transformed_jsx; + } in Lfunction { diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index f815a536c0..3c040cbbc9 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -100,6 +100,7 @@ and apply_coercion_result loc strict funct param arg cc_res = ap_func = Lvar id; ap_args = [arg]; ap_inlined = Default_inline; + ap_transformed_jsx = None; }); }) @@ -276,6 +277,7 @@ and transl_module cc rootpath mexp = ap_func = transl_module Tcoerce_none None funct; ap_args = [transl_module ccarg None arg]; ap_inlined = inlined_attribute; + ap_transformed_jsx = None; }) | Tmod_constraint (arg, _, _, ccarg) -> transl_module (compose_coercions cc ccarg) rootpath arg diff --git a/compiler/ml/typecore.ml b/compiler/ml/typecore.ml index d1e593607f..a7ac76a341 100644 --- a/compiler/ml/typecore.ml +++ b/compiler/ml/typecore.ml @@ -2401,7 +2401,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp type_function ?in_function ~arity ~async loc sexp.pexp_attributes env ty_expected l [Ast_helper.Exp.case spat sbody] - | Pexp_apply {funct = sfunct; args = sargs; partial} -> + | Pexp_apply {funct = sfunct; args = sargs; partial; transformed_jsx} -> assert (sargs <> []); begin_def (); (* one more level for non-returning functions *) @@ -2423,7 +2423,7 @@ and type_expect_ ?type_clash_context ?in_function ?(recarg = Rejected) env sexp let mk_apply funct args = rue { - exp_desc = Texp_apply {funct; args; partial}; + exp_desc = Texp_apply {funct; args; partial; transformed_jsx}; exp_loc = loc; exp_extra = []; exp_type = ty_res; diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index 626950caec..e47de1471a 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -87,6 +87,7 @@ and expression_desc = funct: expression; args: (Noloc.arg_label * expression option) list; partial: bool; + transformed_jsx: Parsetree.jsx_element option; } | Texp_match of expression * case list * case list * partial | Texp_try of expression * case list diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index 96da873af0..05fc52ca7a 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -150,6 +150,7 @@ and expression_desc = funct: expression; args: (Noloc.arg_label * expression option) list; partial: bool; + transformed_jsx: Parsetree.jsx_element option; } (** E0 ~l1:E1 ... ~ln:En From dd56e61f764538f8cb49d1bbae20d4ca7f07e775 Mon Sep 17 00:00:00 2001 From: nojaf Date: Fri, 11 Apr 2025 10:21:18 +0200 Subject: [PATCH 03/31] Follow Lprim --- compiler/core/js_dump.ml | 2 + compiler/core/lam.ml | 4 +- compiler/core/lam.mli | 1 + compiler/core/lam_convert.ml | 36 ++++++----- compiler/core/lam_primitive.ml | 3 +- compiler/core/lam_primitive.mli | 1 + compiler/core/polyvar_pattern_match.ml | 8 +-- compiler/frontend/bs_ast_mapper.ml | 4 +- compiler/ml/lambda.ml | 12 ++-- compiler/ml/lambda.mli | 2 +- compiler/ml/matching.ml | 73 +++++++++++----------- compiler/ml/printast.ml | 9 ++- compiler/ml/printlambda.ml | 2 +- compiler/ml/transl_recmodule.ml | 6 +- compiler/ml/translattribute.ml | 4 +- compiler/ml/translcore.ml | 84 +++++++++++++++++--------- compiler/ml/translmod.ml | 13 ++-- 17 files changed, 156 insertions(+), 108 deletions(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 17be079918..e1272c0b59 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -529,6 +529,8 @@ and expression_desc cxt ~(level : int) f x : cxt = P.string f ""; cxt | Call (e, el, info) -> + Format.fprintf Format.err_formatter "Js_dump Has transformed_jsx %b\n" + (Option.is_some info.call_transformed_jsx); P.cond_paren_group f (level > 15) (fun _ -> P.group f 0 (fun _ -> match (info, el) with diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index e9eb2fdebc..d2715c672e 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -723,10 +723,10 @@ let result_wrap loc (result_type : External_ffi_types.return_wrapper) result = prim ~primitive:Pundefined_to_opt ~args:[result] loc | Return_unset | Return_identity -> result -let handle_bs_non_obj_ffi (arg_types : External_arg_spec.params) +let handle_bs_non_obj_ffi ?transformed_jsx (arg_types : External_arg_spec.params) (result_type : External_ffi_types.return_wrapper) ffi args loc prim_name ~dynamic_import = result_wrap loc result_type (prim - ~primitive:(Pjs_call {prim_name; arg_types; ffi; dynamic_import}) + ~primitive:(Pjs_call {prim_name; arg_types; ffi; dynamic_import; transformed_jsx}) ~args loc) diff --git a/compiler/core/lam.mli b/compiler/core/lam.mli index 9d009b959c..c15515b545 100644 --- a/compiler/core/lam.mli +++ b/compiler/core/lam.mli @@ -90,6 +90,7 @@ and t = private val inner_map : t -> (t -> t) -> t val handle_bs_non_obj_ffi : + ?transformed_jsx:Parsetree.jsx_element -> External_arg_spec.params -> External_ffi_types.return_wrapper -> External_ffi_types.external_spec -> diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 7db4e6a9b5..74383b0ff0 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -348,8 +348,8 @@ let rec rename_optional_parameters map params (body : Lambda.lambda) = value_kind, id, Lifthenelse - ( Lprim (p, [Lvar ({name = "*opt*"} as opt)], p_loc), - Lprim (p1, [Lvar ({name = "*opt*"} as opt2)], x_loc), + ( Lprim (p, [Lvar ({name = "*opt*"} as opt)], p_loc, p_tj), + Lprim (p1, [Lvar ({name = "*opt*"} as opt2)], x_loc, x_tj), f ), rest ) when Ident.same opt opt2 && List.mem opt params -> @@ -361,8 +361,8 @@ let rec rename_optional_parameters map params (body : Lambda.lambda) = value_kind, id, Lifthenelse - ( Lprim (p, [Lvar new_id], p_loc), - Lprim (p1, [Lvar new_id], x_loc), + ( Lprim (p, [Lvar new_id], p_loc, p_tj), + Lprim (p1, [Lvar new_id], x_loc, x_tj), f ), rest ) ) | _ -> (map, body) @@ -373,7 +373,7 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : let exit_map = Hash_int.create 0 in let may_depends = Lam_module_ident.Hash_set.create 0 in - let rec convert_ccall (a_prim : Primitive.description) + let rec convert_ccall ?(transformed_jsx = None) (a_prim : Primitive.description) (args : Lambda.lambda list) loc ~dynamic_import : Lam.t = let prim_name = a_prim.prim_name in match External_ffi_types.from_string a_prim.prim_native_name with @@ -381,13 +381,14 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : let args = Ext_list.map args convert_aux in prim ~primitive:(Pjs_object_create labels) ~args loc | Ffi_bs (arg_types, result_type, ffi) -> + Format.fprintf Format.err_formatter "Ffi_bs\n"; let arg_types = match arg_types with | Params ls -> ls | Param_number i -> Ext_list.init i (fun _ -> External_arg_spec.dummy) in let args = Ext_list.map args convert_aux in - Lam.handle_bs_non_obj_ffi arg_types result_type ffi args loc prim_name + Lam.handle_bs_non_obj_ffi ?transformed_jsx arg_types result_type ffi args loc prim_name ~dynamic_import | Ffi_inline_const i -> Lam.const i | Ffi_normal -> @@ -447,20 +448,23 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : let lam = Lam.letrec bindings body in Lam_scc.scc bindings lam body (* inlining will affect how mututal recursive behave *) - | Lprim (Prevapply, [x; f], outer_loc) | Lprim (Pdirapply, [f; x], outer_loc) - -> + | Lprim (Prevapply, [x; f], outer_loc, _) + | Lprim (Pdirapply, [f; x], outer_loc, _) -> convert_pipe f x outer_loc - | Lprim (Prevapply, _, _) -> assert false - | Lprim (Pdirapply, _, _) -> assert false - | Lprim (Pccall a, args, loc) -> convert_ccall a args loc ~dynamic_import - | Lprim (Pjs_raw_expr, args, loc) -> ( + | Lprim (Prevapply, _, _, _) -> assert false + | Lprim (Pdirapply, _, _, _) -> assert false + | Lprim (Pccall a, args, loc, transformed_jsx) -> + Format.fprintf Format.err_formatter + "lam convert Pccall Has transformed_jsx %b\n" (Option.is_some transformed_jsx); + convert_ccall ~transformed_jsx a args loc ~dynamic_import + | Lprim (Pjs_raw_expr, args, loc, _) -> ( match args with | [Lconst (Const_base (Const_string (code, _)))] -> (* js parsing here *) let kind = Classify_function.classify code in prim ~primitive:(Praw_js_code {code; code_info = Exp kind}) ~args:[] loc | _ -> assert false) - | Lprim (Pjs_raw_stmt, args, loc) -> ( + | Lprim (Pjs_raw_stmt, args, loc, _) -> ( match args with | [Lconst (Const_base (Const_string (code, _)))] -> let kind = Classify_function.classify_stmt code in @@ -468,7 +472,7 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : ~primitive:(Praw_js_code {code; code_info = Stmt kind}) ~args:[] loc | _ -> assert false) - | Lprim (Pgetglobal id, args, _) -> + | Lprim (Pgetglobal id, args, _, _) -> let args = Ext_list.map args convert_aux in if Ident.is_predef_exn id then Lam.const (Const_string {s = id.name; unicode = false}) @@ -476,10 +480,10 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : may_depend may_depends (Lam_module_ident.of_ml ~dynamic_import id); assert (args = []); Lam.global_module ~dynamic_import id) - | Lprim (Pimport, args, loc) -> + | Lprim (Pimport, args, loc, _) -> let args = Ext_list.map args (convert_aux ~dynamic_import:true) in lam_prim ~primitive:Pimport ~args loc - | Lprim (primitive, args, loc) -> + | Lprim (primitive, args, loc, tj) -> let args = Ext_list.map args (convert_aux ~dynamic_import) in lam_prim ~primitive ~args loc | Lswitch (e, s, _loc) -> convert_switch e s diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index e28c652cd9..c45fcb4fb7 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -46,6 +46,7 @@ type t = arg_types: External_arg_spec.params; ffi: External_ffi_types.external_spec; dynamic_import: bool; + transformed_jsx: Parsetree.jsx_element option; } | Pjs_object_create of External_arg_spec.obj_params (* Exceptions *) @@ -250,7 +251,7 @@ let eq_primitive_approx (lhs : t) (rhs : t) = | Pmakeblock (i1, info1, flag1) -> i0 = i1 && flag0 = flag1 && eq_tag_info info0 info1 | _ -> false) - | Pjs_call {prim_name; arg_types; ffi; dynamic_import} -> ( + | Pjs_call {prim_name; arg_types; ffi; dynamic_import; _} -> ( match rhs with | Pjs_call rhs -> prim_name = rhs.prim_name && arg_types = rhs.arg_types && ffi = rhs.ffi diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index 460ef392c4..f6a13ceceb 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -42,6 +42,7 @@ type t = arg_types: External_arg_spec.params; ffi: External_ffi_types.external_spec; dynamic_import: bool; + transformed_jsx: Parsetree.jsx_element option; } | Pjs_object_create of External_arg_spec.obj_params | Praise diff --git a/compiler/core/polyvar_pattern_match.ml b/compiler/core/polyvar_pattern_match.ml index fea0b53f1d..b398bac2aa 100644 --- a/compiler/core/polyvar_pattern_match.ml +++ b/compiler/core/polyvar_pattern_match.ml @@ -65,7 +65,7 @@ let or_list (arg : lam) (hash_names : (int * string) list) = Lprim ( Pintcomp Ceq, [arg; Lconst (Const_pointer (hash, Pt_variant {name}))], - Location.none ) + Location.none, None ) in Ext_list.fold_left rest init (fun acc (hash, name) -> Lambda.Lprim @@ -75,9 +75,9 @@ let or_list (arg : lam) (hash_names : (int * string) list) = Lprim ( Pintcomp Ceq, [arg; Lconst (Const_pointer (hash, Pt_variant {name}))], - Location.none ); + Location.none , None ); ], - Location.none )) + Location.none, None )) | _ -> assert false let make_test_sequence_variant_constant (fail : lam option) (arg : lam) @@ -111,5 +111,5 @@ let call_switcher_variant_constr (loc : Location.t) (fail : lam option) ( Alias, Pgenval, v, - Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc), + Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc, None), call_switcher_variant_constant loc fail (Lvar v) int_lambda_list names ) diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml index fff7690b20..075aaa19f4 100644 --- a/compiler/frontend/bs_ast_mapper.ml +++ b/compiler/frontend/bs_ast_mapper.ml @@ -330,8 +330,8 @@ module E = struct fun_ ~loc ~attrs ~arity ~async lab (map_opt (sub.expr sub) def) (sub.pat sub p) (sub.expr sub e) - | Pexp_apply {funct = e; args = l; partial} -> - apply ~loc ~attrs ~partial (sub.expr sub e) + | Pexp_apply {funct = e; args = l; partial; transformed_jsx} -> + apply ~loc ~attrs ~partial ?transformed_jsx (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) | Pexp_match (e, pel) -> match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index c0111641d6..d710c71485 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -357,7 +357,7 @@ type lambda = | Lfunction of lfunction | Llet of let_kind * value_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list * Location.t + | Lprim of primitive * lambda list * Location.t * Parsetree.jsx_element option | Lswitch of lambda * lambda_switch * Location.t | Lstringswitch of lambda * (string * lambda) list * lambda option * Location.t @@ -462,7 +462,7 @@ let make_key e = let ex = tr_rec env ex in let y = make_key x in Llet (str, k, y, ex, tr_rec (Ident.add x (Lvar y) env) e) - | Lprim (p, es, _) -> Lprim (p, tr_recs env es, Location.none) + | Lprim (p, es, _, tj) -> Lprim (p, tr_recs env es, Location.none, tj) | Lswitch (e, sw, loc) -> Lswitch (tr_rec env e, tr_sw env sw, loc) | Lstringswitch (e, sw, d, _) -> Lstringswitch @@ -520,7 +520,7 @@ let iter f = function | Lletrec (decl, body) -> f body; List.iter (fun (_id, exp) -> f exp) decl - | Lprim (_p, args, _loc) -> List.iter f args + | Lprim (_p, args, _loc, _tj) -> List.iter f args | Lswitch (arg, sw, _) -> f arg; List.iter (fun (_key, case) -> f case) sw.sw_consts; @@ -618,13 +618,13 @@ let rec patch_guarded patch = function let rec transl_normal_path = function | Path.Pident id -> - if Ident.global id then Lprim (Pgetglobal id, [], Location.none) + if Ident.global id then Lprim (Pgetglobal id, [], Location.none, None) else Lvar id | Pdot (p, s, pos) -> Lprim ( Pfield (pos, Fld_module {name = s}), [transl_normal_path p], - Location.none ) + Location.none , None) | Papply _ -> assert false (* Translation of identifiers *) @@ -658,7 +658,7 @@ let subst_lambda s lam = Lfunction {params; body = subst body; attr; loc} | Llet (str, k, id, arg, body) -> Llet (str, k, id, subst arg, subst body) | Lletrec (decl, body) -> Lletrec (List.map subst_decl decl, subst body) - | Lprim (p, args, loc) -> Lprim (p, List.map subst args, loc) + | Lprim (p, args, loc, tj) -> Lprim (p, List.map subst args, loc, tj) | Lswitch (arg, sw, loc) -> Lswitch ( subst arg, diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 2aefe2bbe2..6777d4798a 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -324,7 +324,7 @@ type lambda = | Lfunction of lfunction | Llet of let_kind * value_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list * Location.t + | Lprim of primitive * lambda list * Location.t * Parsetree.jsx_element option | Lswitch of lambda * lambda_switch * Location.t (* switch on strings, clauses are sorted by string order, strings are pairwise distinct *) diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 3f7de33bee..405973c748 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1194,7 +1194,7 @@ let make_field_args ~fld_info loc binding_kind arg first_pos last_pos argl = let rec make_args pos = if pos > last_pos then argl else - (Lprim (Pfield (pos, fld_info), [arg], loc), binding_kind) + (Lprim (Pfield (pos, fld_info), [arg], loc, None), binding_kind) :: make_args (pos + 1) in make_args first_pos @@ -1277,7 +1277,7 @@ let make_constr_matching p def ctx = function Pval_from_option_not_nest | _ -> Pval_from_option in - (Lprim (from_option, [arg], p.pat_loc), Alias) :: argl + (Lprim (from_option, [arg], p.pat_loc, None), Alias) :: argl | Cstr_constant _ | Cstr_block _ -> make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl ~fld_info:(if cstr.cstr_name = "::" then Fld_cons else Fld_variant) @@ -1336,7 +1336,8 @@ let make_variant_matching_nonconst p lab def ctx = function { cases = []; args = - (Lprim (Pfield (1, Fld_poly_var_content), [arg], p.pat_loc), Alias) + ( Lprim (Pfield (1, Fld_poly_var_content), [arg], p.pat_loc, None), + Alias ) :: argl; default = def; }; @@ -1426,8 +1427,9 @@ let get_mod_field modname field = in Lprim ( Pfield (p, Fld_module {name = field}), - [Lprim (Pgetglobal mod_ident, [], Location.none)], - Location.none ) + [Lprim (Pgetglobal mod_ident, [], Location.none, None)], + Location.none, + None ) with Not_found -> fatal_error ("Module " ^ modname ^ " unavailable.")) let code_force = get_mod_field Primitive_modules.lazy_ "force" @@ -1484,7 +1486,7 @@ let make_tuple_matching loc arity def = function let rec make_args pos = if pos >= arity then argl else - (Lprim (Pfield (pos, Fld_tuple), [arg], loc), Alias) + (Lprim (Pfield (pos, Fld_tuple), [arg], loc, None), Alias) :: make_args (pos + 1) in { @@ -1533,16 +1535,19 @@ let make_record_matching loc all_labels def = function match lbl.lbl_repres with | Record_float_unused -> assert false | Record_regular -> - Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc) + Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc, None) | Record_inlined _ -> Lprim - (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [arg], loc) + ( Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), + [arg], + loc, None ) | Record_unboxed _ -> arg | Record_extension -> Lprim ( Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), [arg], - loc ) + loc, + None ) in let str = match lbl.lbl_mut with @@ -1587,7 +1592,7 @@ let make_array_matching p def ctx = function if pos >= len then argl else ( Lprim - (Parrayrefu, [arg; Lconst (Const_base (Const_int pos))], p.pat_loc), + (Parrayrefu, [arg; Lconst (Const_base (Const_int pos))], p.pat_loc, None), StrictOpt ) :: make_args (pos + 1) in @@ -1639,7 +1644,7 @@ let make_string_test_sequence loc arg sw d = List.fold_right (fun (s, lam) k -> Lifthenelse - ( Lprim (Pstringcomp Cneq, [arg; Lconst (Const_immstring s)], loc), + ( Lprim (Pstringcomp Cneq, [arg; Lconst (Const_immstring s)], loc, None), k, lam )) sw d) @@ -1657,9 +1662,9 @@ let zero_lam = Lconst (Const_base (Const_int 0)) let tree_way_test loc arg lt eq gt = Lifthenelse - ( Lprim (Pintcomp Clt, [arg; zero_lam], loc), + ( Lprim (Pintcomp Clt, [arg; zero_lam], loc, None), lt, - Lifthenelse (Lprim (Pintcomp Clt, [zero_lam; arg], loc), gt, eq) ) + Lifthenelse (Lprim (Pintcomp Clt, [zero_lam; arg], loc, None), gt, eq) ) (* Dichotomic tree *) @@ -1670,7 +1675,7 @@ let rec do_make_string_test_tree loc arg sw delta d = else let lt, (s, act), gt = split len sw in bind_sw - (Lprim (Pstringcomp Ceq, [arg; Lconst (Const_immstring s)], loc)) + (Lprim (Pstringcomp Ceq, [arg; Lconst (Const_immstring s)], loc, None)) (fun r -> tree_way_test loc r (do_make_string_test_tree loc arg lt delta d) @@ -1757,7 +1762,7 @@ let rec do_tests_fail loc fail tst arg = function | [] -> fail | (c, act) :: rem -> Lifthenelse - ( Lprim (tst, [arg; Lconst (Const_base c)], loc), + ( Lprim (tst, [arg; Lconst (Const_base c)], loc, None), do_tests_fail loc fail tst arg rem, act ) @@ -1766,7 +1771,7 @@ let rec do_tests_nofail loc tst arg = function | [(_, act)] -> act | (c, act) :: rem -> Lifthenelse - ( Lprim (tst, [arg; Lconst (Const_base c)], loc), + ( Lprim (tst, [arg; Lconst (Const_base c)], loc, None), do_tests_nofail loc tst arg rem, act ) @@ -1786,7 +1791,7 @@ let make_test_sequence loc fail tst lt_tst arg const_lambda_list = cut (List.length const_lambda_list / 2) const_lambda_list in Lifthenelse - ( Lprim (lt_tst, [arg; Lconst (Const_base (fst (List.hd list2)))], loc), + ( Lprim (lt_tst, [arg; Lconst (Const_base (fst (List.hd list2)))], loc, None), make_test_sequence list1, make_test_sequence list2 ) in @@ -1804,11 +1809,11 @@ module SArg = struct type act = Lambda.lambda - let make_prim p args = Lprim (p, args, Location.none) + let make_prim p args = Lprim (p, args, Location.none, None) let make_offset arg n = match n with | 0 -> arg - | _ -> Lprim (Poffsetint n, [arg], Location.none) + | _ -> Lprim (Poffsetint n, [arg], Location.none, None) let bind arg body = let newvar, newarg = @@ -1820,8 +1825,8 @@ module SArg = struct in bind Alias newvar arg (body newarg) let make_const i = Lconst (Const_base (Const_int i)) - let make_isout h arg = Lprim (Pisout, [h; arg], Location.none) - let make_isin h arg = Lprim (Pnot, [make_isout h arg], Location.none) + let make_isout h arg = Lprim (Pisout, [h; arg], Location.none, None) + let make_isin h arg = Lprim (Pnot, [make_isout h arg], Location.none, None) let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) let make_switch loc arg cases acts ~offset sw_names = let l = ref [] in @@ -2216,7 +2221,7 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def (fun (path, act) rem -> let ext = transl_extension_path ex_pat.pat_env path in Lifthenelse - (Lprim (Pextension_slot_eq, [Lvar tag; ext], loc), act, rem)) + (Lprim (Pextension_slot_eq, [Lvar tag; ext], loc, None), act, rem)) extension_cases default in Llet (Alias, Pgenval, tag, arg, tests) @@ -2246,9 +2251,9 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def case *) let arg = if Datarepr.constructor_has_optional_shape cstr then - Lprim (Pis_not_none, [arg], loc) + Lprim (Pis_not_none, [arg], loc, None) else - Lprim (Pjscomp Cneq, [arg; Lconst (Const_base (Const_int 0))], loc) + Lprim (Pjscomp Cneq, [arg; Lconst (Const_base (Const_int 0))], loc, None) in Lifthenelse (arg, act2, act1) | 2, 0, [(i1, act1); (_, act2)], [] @@ -2272,7 +2277,7 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def match act0 with | Some act when false (* relies on tag being an int *) -> Lifthenelse - ( Lprim (Pisint, [arg], loc), + ( Lprim (Pisint, [arg], loc, None), call_switcher loc fail_opt arg 0 (n - 1) consts sw_names, act ) (* Emit a switch, as bytecode implements this sophisticated instruction *) @@ -2311,7 +2316,7 @@ let call_switcher_variant_constr loc fail arg int_lambda_list names = ( Alias, Pgenval, v, - Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc), + Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc, None), call_switcher loc fail (Lvar v) min_int max_int (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) names ) @@ -2357,7 +2362,7 @@ let combine_variant names loc row arg partial ctx def row.row_fields else num_constr := max_int; let test_int_or_block arg if_int if_block = - Lifthenelse (Lprim (Pis_poly_var_block, [arg], loc), if_block, if_int) + Lifthenelse (Lprim (Pis_poly_var_block, [arg], loc, None), if_block, if_int) in let sig_complete = List.length tag_lambda_list = !num_constr and one_action = same_actions tag_lambda_list in @@ -2407,7 +2412,7 @@ let combine_array names loc arg partial ctx def (len_lambda_list, total1, _pats) let switch = call_switcher loc fail (Lvar newvar) 0 max_int len_lambda_list names in - bind Alias newvar (Lprim (Parraylength, [arg], loc)) switch + bind Alias newvar (Lprim (Parraylength, [arg], loc, None)) switch in (lambda1, jumps_union local_jumps total1) @@ -2488,7 +2493,7 @@ let compile_test compile_fun partial divide combine ctx to_match = let rec approx_present v = function | Lconst _ -> false | Lstaticraise (_, args) -> List.exists (fun lam -> approx_present v lam) args - | Lprim (_, args, _) -> List.exists (fun lam -> approx_present v lam) args + | Lprim (_, args, _, _) -> List.exists (fun lam -> approx_present v lam) args | Llet (Alias, _k, _, l1, l2) -> approx_present v l1 || approx_present v l2 | Lvar vv -> Ident.same v vv | _ -> true @@ -2835,9 +2840,9 @@ let partial_function loc () = Const_base (Const_int char); ] )); ], - loc ); + loc, None ); ], - loc ) + loc, None ) let for_function loc repr param pat_act_list partial = compile_matching repr (partial_function loc) param pat_act_list partial @@ -2845,7 +2850,7 @@ let for_function loc repr param pat_act_list partial = (* In the following two cases, exhaustiveness info is not available! *) let for_trywith param pat_act_list = compile_matching None - (fun () -> Lprim (Praise Raise_reraise, [param], Location.none)) + (fun () -> Lprim (Praise Raise_reraise, [param], Location.none, None)) param pat_act_list Partial let simple_for_let loc param pat body = @@ -3012,14 +3017,14 @@ let do_for_multiple_match loc paraml pat_act_list partial = ( raise_num, { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc), Strict)]; + args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc, None), Strict)]; default = [([[omega]], raise_num)]; } ) | _ -> ( -1, { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc), Strict)]; + args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc, None), Strict)]; default = []; } ) in diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index ded0cfd35b..bb96c45693 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -251,11 +251,16 @@ and expression i ppf x = option i expression ppf eo; pattern i ppf p; expression i ppf e - | Pexp_apply {funct = e; args = l; partial} -> + | Pexp_apply {funct = e; args = l; partial; transformed_jsx} -> line i ppf "Pexp_apply\n"; if partial then line i ppf "partial\n"; expression i ppf e; - list i label_x_expression ppf l + list i label_x_expression ppf l; + Option.iter + (fun jsx -> + line i ppf "transformed_jsx:\n"; + expression (i + 1) ppf {x with pexp_desc = Pexp_jsx_element jsx}) + transformed_jsx | Pexp_match (e, l) -> line i ppf "Pexp_match\n"; expression i ppf e; diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index f0ad4698bb..e069e7173b 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -319,7 +319,7 @@ let rec lam ppf = function in fprintf ppf "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body - | Lprim (prim, largs, _) -> + | Lprim (prim, largs, _, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs | Lswitch (larg, sw, _loc) -> diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index 17aa511aa2..cd71664b90 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -151,7 +151,7 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = ( Strict, Pgenval, id, - Lprim (Pinit_mod, [loc; shape], Location.none), + Lprim (Pinit_mod, [loc; shape], Location.none, None), bind_inits rem acc ) in let rec bind_strict args acc = @@ -167,7 +167,7 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = | (_id, None, _rhs) :: rem -> patch_forwards rem | (id, Some (_loc, shape), rhs) :: rem -> Lsequence - ( Lprim (Pupdate_mod, [shape; Lvar id; rhs], Location.none), + ( Lprim (Pupdate_mod, [shape; Lvar id; rhs], Location.none, None), patch_forwards rem ) in bind_inits bindings (bind_strict bindings (patch_forwards bindings)) @@ -178,7 +178,7 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = *) let rec is_function_or_const_block (lam : Lambda.lambda) acc = match lam with - | Lprim (Pmakeblock _, args, _) -> + | Lprim (Pmakeblock _, args, _, _) -> Ext_list.for_all args (fun x -> match x with | Lvar id -> Set_ident.mem acc id diff --git a/compiler/ml/translattribute.ml b/compiler/ml/translattribute.ml index ed63ecbdf1..800d630d0c 100644 --- a/compiler/ml/translattribute.ml +++ b/compiler/ml/translattribute.ml @@ -76,8 +76,8 @@ let rec add_inline_attribute (expr : Lambda.lambda) loc attributes = Location.prerr_warning loc (Warnings.Duplicated_attribute "inline")); let attr = {attr with inline} in Lfunction {funct with attr} - | Lprim (((Pjs_fn_make _ | Pjs_fn_make_unit) as p), [e], l), _ -> - Lambda.Lprim (p, [add_inline_attribute e loc attributes], l) + | Lprim (((Pjs_fn_make _ | Pjs_fn_make_unit) as p), [e], l, tj), _ -> + Lambda.Lprim (p, [add_inline_attribute e loc attributes], l, tj) | expr, Always_inline -> Location.prerr_warning loc (Warnings.Misplaced_attribute "inline1"); expr diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index b8fd18ff29..1817567338 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -44,7 +44,7 @@ let transl_extension_constructor env path ext = in let loc = ext.ext_loc in match ext.ext_kind with - | Text_decl _ -> Lprim (Pcreate_extension name, [], loc) + | Text_decl _ -> Lprim (Pcreate_extension name, [], loc, None) | Text_rebind (path, _lid) -> transl_extension_path ~loc env path (* Translation of primitives *) @@ -460,7 +460,7 @@ let transl_primitive loc p env ty = params = [param]; attr = default_function_attribute; loc; - body = Lprim (Pmakeblock Blk_tuple, [lam; Lvar param], loc); + body = Lprim (Pmakeblock Blk_tuple, [lam; Lvar param], loc, None); } | _ -> assert false) | _ -> @@ -471,7 +471,7 @@ let transl_primitive loc p env ty = :: make_params (n - 1) total in let prim_arity = p.prim_arity in - if p.prim_from_constructor || prim_arity = 0 then Lprim (prim, [], loc) + if p.prim_from_constructor || prim_arity = 0 then Lprim (prim, [], loc, None) else let params = if prim_arity = 1 then [Ident.create "prim"] @@ -482,7 +482,7 @@ let transl_primitive loc p env ty = params; attr = default_function_attribute; loc; - body = Lprim (prim, List.map (fun id -> Lvar id) params, loc); + body = Lprim (prim, List.map (fun id -> Lvar id) params, loc, None); } let transl_primitive_application loc prim env ty args = @@ -629,9 +629,11 @@ let assert_failed exp = Const_base (Const_int char); ] )); ], - exp.exp_loc ); + exp.exp_loc, + None ); ], - exp.exp_loc ) + exp.exp_loc, + None ) let rec cut n l = if n = 0 then ([], l) @@ -700,7 +702,8 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = Lprim ( prim (* could be replaced with Opaque in the future except arity 0*), [lambda], - loc ) + loc, + None ) | None -> lambda) | Texp_apply { @@ -714,9 +717,16 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = } when List.length oargs >= p.prim_arity && List.for_all (fun (_, arg) -> arg <> None) oargs -> ( + Format.fprintf Format.err_formatter + "transl_exp0 when Has transformed_jsx %b" + (Option.is_some transformed_jsx); let args, args' = cut p.prim_arity oargs in let wrap f = - if args' = [] then f + if args' = [] then ( + Format.fprintf Format.err_formatter + "args' = [] Has transformed_jsx %b\n" + (Option.is_some transformed_jsx); + f) else let inlined, _ = Translattribute.get_and_remove_inlined_attribute funct @@ -742,16 +752,20 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Raise_regular, Lvar id when Hashtbl.mem try_ids id -> Raise_reraise | _ -> k in - wrap (Lprim (Praise k, [targ], e.exp_loc)) + wrap (Lprim (Praise k, [targ], e.exp_loc, transformed_jsx)) | Ploc kind, [] -> lam_of_loc kind e.exp_loc | Ploc kind, [arg1] -> + Format.fprintf Format.err_formatter "Ploc Has transformed_jsx %b" + (Option.is_some transformed_jsx); let lam = lam_of_loc kind arg1.exp_loc in - Lprim (Pmakeblock Blk_tuple, lam :: argl, e.exp_loc) + Lprim (Pmakeblock Blk_tuple, lam :: argl, e.exp_loc, transformed_jsx) | Ploc _, _ -> assert false | _, _ -> ( match (prim, argl) with - | _ -> wrap (Lprim (prim, argl, e.exp_loc)))) + | _ -> wrap (Lprim (prim, argl, e.exp_loc, transformed_jsx)))) | Texp_apply {funct; args = oargs; partial; transformed_jsx} -> + Format.fprintf Format.err_formatter "transl_exp0 Has transformed_jsx %b" + (Option.is_some transformed_jsx); let inlined, funct = Translattribute.get_and_remove_inlined_attribute funct in @@ -780,7 +794,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Texp_tuple el -> ( let ll = transl_list el in try Lconst (Const_block (Blk_tuple, List.map extract_constant ll)) - with Not_constant -> Lprim (Pmakeblock Blk_tuple, ll, e.exp_loc)) + with Not_constant -> Lprim (Pmakeblock Blk_tuple, ll, e.exp_loc, None)) | Texp_construct ({txt = Lident "false"}, _, []) -> Lconst Const_false | Texp_construct ({txt = Lident "true"}, _, []) -> Lconst Const_true | Texp_construct (lid, cstr, args) -> ( @@ -835,12 +849,13 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = } in try Lconst (Const_block (tag_info, List.map extract_constant ll)) - with Not_constant -> Lprim (Pmakeblock tag_info, ll, e.exp_loc)) + with Not_constant -> Lprim (Pmakeblock tag_info, ll, e.exp_loc, None)) | Cstr_extension path -> Lprim ( Pmakeblock Blk_extension, transl_extension_path e.exp_env path :: ll, - e.exp_loc )) + e.exp_loc, + None )) | Texp_extension_constructor (_, path) -> transl_extension_path e.exp_env path | Texp_variant (l, arg) -> ( let tag = Btype.hash_variant l in @@ -857,7 +872,8 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = Lprim ( Pmakeblock tag_info, [Lconst (Const_base (Const_int tag)); lam], - e.exp_loc ))) + e.exp_loc, + None ))) | Texp_record {fields; representation; extended_expression} -> transl_record e.exp_loc e.exp_env fields representation extended_expression | Texp_field (arg, _, lbl) -> ( @@ -865,16 +881,21 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = match lbl.lbl_repres with | Record_float_unused -> assert false | Record_regular -> - Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [targ], e.exp_loc) + Lprim + (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [targ], e.exp_loc, None) | Record_inlined _ -> Lprim - (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [targ], e.exp_loc) + ( Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), + [targ], + e.exp_loc, + None ) | Record_unboxed _ -> targ | Record_extension -> Lprim ( Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), [targ], - e.exp_loc )) + e.exp_loc, + None )) | Texp_setfield (arg, _, lbl, newval) -> let access = match lbl.lbl_repres with @@ -886,10 +907,10 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Record_extension -> Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) in - Lprim (access, [transl_exp arg; transl_exp newval], e.exp_loc) + Lprim (access, [transl_exp arg; transl_exp newval], e.exp_loc, None) | Texp_array expr_list -> let ll = transl_list expr_list in - Lprim (Pmakearray Mutable, ll, e.exp_loc) + Lprim (Pmakearray Mutable, ll, e.exp_loc, None) | Texp_ifthenelse (cond, ifso, Some ifnot) -> Lifthenelse (transl_exp cond, transl_exp ifso, transl_exp ifnot) | Texp_ifthenelse (cond, ifso, None) -> @@ -923,7 +944,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = (* when e needs no computation (constants, identifiers, ...), we optimize the translation just as Lazy.lazy_from_val would do *) - Lprim (Pmakeblock Blk_lazy_general, [transl_exp e], e.exp_loc) + Lprim (Pmakeblock Blk_lazy_general, [transl_exp e], e.exp_loc, None) and transl_list expr_list = List.map transl_exp expr_list @@ -952,6 +973,8 @@ and transl_apply ?(inlined = Default_inline) ?(uncurried_partial_application = None) ?(transformed_jsx = None) lam sargs loc = let lapply ap_func ap_args = + Format.fprintf Format.err_formatter "Lapply transformed_jsx %b" + (Option.is_some transformed_jsx); Lapply { ap_loc = loc; @@ -1016,6 +1039,9 @@ and transl_apply ?(inlined = Default_inline) in let extra_args = Ext_list.map extra_ids (fun id -> Lvar id) in let ap_args = args @ extra_args in + Format.fprintf Format.err_formatter + "uncurried_partial_application transformed_jsx %b" + (Option.is_some transformed_jsx); let l0 = Lapply { @@ -1113,7 +1139,8 @@ and transl_record loc env fields repres opt_init_expr = ( Pjs_fn_make arity, (* could be replaced with Opaque in the future except arity 0*) [lambda], - loc ) + loc, + None ) else lambda | _ -> ( let size = Array.length fields in @@ -1150,7 +1177,7 @@ and transl_record loc env fields repres opt_init_expr = | Record_extension -> Pfield (i + 1, Lambda.fld_record_extension lbl) in - Lprim (access, [Lvar init_id], loc) + Lprim (access, [Lvar init_id], loc, None) | Overridden (_lid, expr) -> transl_exp expr) fields in @@ -1183,7 +1210,7 @@ and transl_record loc env fields repres opt_init_expr = with Not_constant -> ( match repres with | Record_regular -> - Lprim (Pmakeblock (Lambda.blk_record fields mut), ll, loc) + Lprim (Pmakeblock (Lambda.blk_record fields mut), ll, loc, None) | Record_float_unused -> assert false | Record_inlined {tag; name; num_nonconsts; attrs} -> Lprim @@ -1191,7 +1218,8 @@ and transl_record loc env fields repres opt_init_expr = (Lambda.blk_record_inlined fields name num_nonconsts ~tag ~attrs mut), ll, - loc ) + loc, + None ) | Record_unboxed _ -> ( match ll with | [v] -> v @@ -1205,7 +1233,7 @@ and transl_record loc env fields repres opt_init_expr = in let slot = transl_extension_path env path in Lprim - (Pmakeblock (Lambda.blk_record_ext fields mut), slot :: ll, loc)) + (Pmakeblock (Lambda.blk_record_ext fields mut), slot :: ll, loc, None)) in match opt_init_expr with | None -> lam @@ -1230,7 +1258,7 @@ and transl_record loc env fields repres opt_init_expr = | Record_extension -> Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) in - Lsequence (Lprim (upd, [Lvar copy_id; transl_exp expr], loc), cont) + Lsequence (Lprim (upd, [Lvar copy_id; transl_exp expr], loc, None), cont) in match opt_init_expr with | None -> assert false @@ -1239,7 +1267,7 @@ and transl_record loc env fields repres opt_init_expr = ( Strict, Pgenval, copy_id, - Lprim (Pduprecord, [transl_exp init_expr], loc), + Lprim (Pduprecord, [transl_exp init_expr], loc, None), Array.fold_left update_field (Lvar copy_id) fields )) and transl_match e arg pat_expr_list exn_pat_expr_list partial = diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index 3c040cbbc9..77453c97c7 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -64,15 +64,15 @@ let rec apply_coercion loc strict (restr : Typedtree.module_coercion) arg = | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> Lambda.name_lambda strict arg (fun id -> let get_field_name name pos = - Lambda.Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc) + Lambda.Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc, None) in let lam = Lambda.Lprim ( Pmakeblock (Blk_module runtime_fields), Ext_list.map2 pos_cc_list runtime_fields (fun (pos, cc) name -> apply_coercion loc Alias cc - (Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc))), - loc ) + (Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc, None))), + loc,None ) in wrap_id_pos_list loc id_pos_list get_field_name lam) | Tcoerce_functor (cc_arg, cc_res) -> @@ -306,7 +306,7 @@ and transl_structure loc fields cc rootpath final_env = function (if is_top_root_path then Blk_module_export !export_identifiers else Blk_module (List.rev_map (fun id -> id.Ident.name) fields)), block_fields, - loc ), + loc, None ), List.length fields ) | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> (* Do not ignore id_pos_list ! *) @@ -342,7 +342,7 @@ and transl_structure loc fields cc rootpath final_env = function (if is_top_root_path then Blk_module_export !export_identifiers else Blk_module runtime_fields), result, - loc ) + loc, None ) and id_pos_list = Ext_list.filter id_pos_list (fun (id, _, _) -> not (Lambda.IdentSet.mem id ids)) @@ -434,7 +434,8 @@ and transl_structure loc fields cc rootpath final_env = function Lprim ( Pfield (pos, Fld_module {name = Ident.name id}), [Lvar mid], - incl.incl_loc ), + incl.incl_loc, + None ), body ), size ) in From a0c170f0bed6ab52ecd12d57960f1191c44289ed Mon Sep 17 00:00:00 2001 From: nojaf Date: Wed, 23 Apr 2025 13:40:08 +0200 Subject: [PATCH 04/31] Transform initial simple element --- compiler/core/js_dump.ml | 56 +++++++++++++++++++-- compiler/core/jsx_help.ml | 46 +++++++++++++++++ compiler/core/lam.ml | 6 ++- compiler/core/lam_compile_external_call.ml | 52 +++++++++++++++---- compiler/core/lam_compile_external_call.mli | 1 + compiler/core/lam_compile_primitive.ml | 4 +- compiler/core/lam_convert.ml | 12 +++-- compiler/core/polyvar_pattern_match.ml | 9 ++-- compiler/ml/lambda.ml | 5 +- compiler/ml/matching.ml | 30 ++++++++--- compiler/ml/translcore.ml | 8 ++- compiler/ml/translmod.ml | 12 +++-- 12 files changed, 199 insertions(+), 42 deletions(-) create mode 100644 compiler/core/jsx_help.ml diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index e1272c0b59..a2ef559b75 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -524,13 +524,58 @@ and expression_desc cxt ~(level : int) f x : cxt = when Ext_list.length_equal el i ]} *) - | Call (e, el, {call_transformed_jsx = Some jsx_element}) -> - (* The grand point would be to reconstruct the JSX here *) - P.string f ""; - cxt + | Call (e, el, {call_transformed_jsx = Some jsx_element}) -> ( + match el with + | [ + _tag; + { + expression_desc = + Caml_block (el, _mutable_flag, _, Lambda.Blk_record {fields}); + }; + ] -> ( + let fields = + Ext_list.array_list_filter_map fields el (fun (f, opt) x -> + match x.expression_desc with + | Undefined _ when opt -> None + | _ -> Some (f, x)) + in + match jsx_element with + | Parsetree.Jsx_container_element + { + jsx_container_element_tag_name_start = + {txt = Longident.Lident tagName}; + } -> + P.string f (Format.sprintf "<%s" tagName); + List.iter + (fun (n, x) -> + P.space f; + P.string f n; + P.string f "="; + P.string f "{"; + let _ = expression ~level:0 cxt f x in + P.string f "}") + fields; + P.string f ">"; + cxt + | _ -> + expression_desc cxt ~level f + (Call + ( e, + el, + {call_transformed_jsx = None; arity = Full; call_info = Call_ml} + ))) + | _ -> + expression_desc cxt ~level f + (Call + ( e, + el, + {call_transformed_jsx = None; arity = Full; call_info = Call_ml} )) + ) | Call (e, el, info) -> Format.fprintf Format.err_formatter "Js_dump Has transformed_jsx %b\n" - (Option.is_some info.call_transformed_jsx); + (Option.is_some info.call_transformed_jsx); P.cond_paren_group f (level > 15) (fun _ -> P.group f 0 (fun _ -> match (info, el) with @@ -687,6 +732,7 @@ and expression_desc cxt ~(level : int) f x : cxt = P.cond_paren_group f (level > 12) (fun _ -> let cxt = expression ~level:0 cxt f prop in P.string f " in "; + P.string f " in "; expression ~level:0 cxt f obj) | Typeof e -> P.string f "typeof"; diff --git a/compiler/core/jsx_help.ml b/compiler/core/jsx_help.ml new file mode 100644 index 0000000000..25a6256bd3 --- /dev/null +++ b/compiler/core/jsx_help.ml @@ -0,0 +1,46 @@ +let j_exp_to_string (e : J.expression) = + match e.J.expression_desc with + | J.Object _ -> "Object" + | J.Str _ -> "String" + | J.Var _ -> "Var" + | J.Call _ -> "Call" + | J.Fun _ -> "Fun" + | J.Array _ -> "Array" + | J.Bin _ -> "Bin" + | J.Cond _ -> "Cond" + | J.New _ -> "New" + | J.Seq _ -> "Seq" + | J.Number _ -> "Number" + | J.Bool _ -> "Bool" + | J.Null -> "Null" + | J.Undefined _ -> "Undefined" + | J.Is_null_or_undefined _ -> "Is_null_or_undefined" + | J.Js_not _ -> "Js_not" + | J.Typeof _ -> "Typeof" + | J.String_index _ -> "String_index" + | J.Array_index _ -> "Array_index" + | J.Static_index _ -> "Static_index" + | J.Length _ -> "Length" + | J.Caml_block _ -> "Caml_block" + | J.Caml_block_tag _ -> "Caml_block_tag" + | J.Tagged_template _ -> "Tagged_template" + | J.Optional_block _ -> "Optional_block" + | J.Spread _ -> "Spread" + | J.Await _ -> "Await" + | J.Raw_js_code _ -> "Raw_js_code" + | _ -> "Other" + +let lambda_tag_info_to_string (e : Lambda.tag_info) = + match e with + | Lambda.Blk_constructor _ -> "Blk_constructor" + | Lambda.Blk_record_inlined _ -> "Blk_record_inlined" + | Lambda.Blk_tuple -> "Blk_tuple" + | Lambda.Blk_poly_var _ -> "Blk_poly_var" + | Lambda.Blk_record _ -> "Blk_record" + | Lambda.Blk_module _ -> "Blk_module" + | Lambda.Blk_module_export _ -> "Blk_module_export" + | Lambda.Blk_extension -> "Blk_extension" + | Lambda.Blk_some -> "Blk_some" + | Lambda.Blk_some_not_nested -> "Blk_some_not_nested" + | Lambda.Blk_record_ext _ -> "Blk_record_ext" + | Lambda.Blk_lazy_general -> "Blk_lazy_general" diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index d2715c672e..4f90ce336a 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -723,10 +723,12 @@ let result_wrap loc (result_type : External_ffi_types.return_wrapper) result = prim ~primitive:Pundefined_to_opt ~args:[result] loc | Return_unset | Return_identity -> result -let handle_bs_non_obj_ffi ?transformed_jsx (arg_types : External_arg_spec.params) +let handle_bs_non_obj_ffi ?transformed_jsx + (arg_types : External_arg_spec.params) (result_type : External_ffi_types.return_wrapper) ffi args loc prim_name ~dynamic_import = result_wrap loc result_type (prim - ~primitive:(Pjs_call {prim_name; arg_types; ffi; dynamic_import; transformed_jsx}) + ~primitive: + (Pjs_call {prim_name; arg_types; ffi; dynamic_import; transformed_jsx}) ~args loc) diff --git a/compiler/core/lam_compile_external_call.ml b/compiler/core/lam_compile_external_call.ml index fa2c720702..ed2b1984ef 100644 --- a/compiler/core/lam_compile_external_call.ml +++ b/compiler/core/lam_compile_external_call.ml @@ -267,7 +267,8 @@ let translate_scoped_access scopes obj = | [] -> obj | x :: xs -> Ext_list.fold_left xs (E.dot obj x) E.dot -let translate_ffi (cxt : Lam_compile_context.t) arg_types +let translate_ffi ?(transformed_jsx : Parsetree.jsx_element option) + (cxt : Lam_compile_context.t) arg_types (ffi : External_ffi_types.external_spec) (args : J.expression list) ~dynamic_import = match ffi with @@ -290,7 +291,11 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types add_eff eff (E.call ~info: - {arity = Full; call_info = Call_na; call_transformed_jsx = None} + { + arity = Full; + call_info = Call_na; + call_transformed_jsx = transformed_jsx; + } fn args)) | Js_call { @@ -309,14 +314,22 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types add_eff eff (E.call ~info: - {arity = Full; call_info = Call_na; call_transformed_jsx = None} + { + arity = Full; + call_info = Call_na; + call_transformed_jsx = transformed_jsx; + } fn args) else let args, eff = assemble_args_no_splice arg_types args in add_eff eff @@ E.call ~info: - {arity = Full; call_info = Call_na; call_transformed_jsx = None} + { + arity = Full; + call_info = Call_na; + call_transformed_jsx = transformed_jsx; + } fn args | Js_module_as_fn {external_module_name; splice} -> let fn = external_var external_module_name ~dynamic_import in @@ -326,7 +339,11 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types add_eff eff (E.call ~info: - {arity = Full; call_info = Call_na; call_transformed_jsx = None} + { + arity = Full; + call_info = Call_na; + call_transformed_jsx = transformed_jsx; + } fn args) else let args, eff = assemble_args_no_splice arg_types args in @@ -334,7 +351,11 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types add_eff eff (E.call ~info: - {arity = Full; call_info = Call_na; call_transformed_jsx = None} + { + arity = Full; + call_info = Call_na; + call_transformed_jsx = transformed_jsx; + } fn args) | Js_new {external_module_name = module_name; name = fn; splice; scopes} -> (* handle [@@new]*) @@ -383,7 +404,11 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types (let self = translate_scoped_access js_send_scopes self in E.call ~info: - {arity = Full; call_info = Call_na; call_transformed_jsx = None} + { + arity = Full; + call_info = Call_na; + call_transformed_jsx = transformed_jsx; + } (E.dot self name) args) else let args, eff = assemble_args_no_splice arg_types args in @@ -391,7 +416,11 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types (let self = translate_scoped_access js_send_scopes self in E.call ~info: - {arity = Full; call_info = Call_na; call_transformed_jsx = None} + { + arity = Full; + call_info = Call_na; + call_transformed_jsx = transformed_jsx; + } (E.dot self name) args) | _ -> assert false) | Js_module_as_var module_name -> external_var module_name ~dynamic_import @@ -408,7 +437,12 @@ let translate_ffi (cxt : Lam_compile_context.t) arg_types if args = [] then e else E.call - ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = None} + ~info: + { + arity = Full; + call_info = Call_na; + call_transformed_jsx = transformed_jsx; + } e args | Js_module_as_class module_name -> let fn = external_var module_name ~dynamic_import in diff --git a/compiler/core/lam_compile_external_call.mli b/compiler/core/lam_compile_external_call.mli index e8c974f10a..4638ed618d 100644 --- a/compiler/core/lam_compile_external_call.mli +++ b/compiler/core/lam_compile_external_call.mli @@ -30,6 +30,7 @@ val ocaml_to_js_eff : (** Compile ocaml external function call to JS IR. *) val translate_ffi : + ?transformed_jsx:Parsetree.jsx_element -> Lam_compile_context.t -> External_arg_spec.params -> External_ffi_types.external_spec -> diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index 272b4ff05d..3b99a95ab1 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -597,9 +597,9 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) (* Lam_compile_external_call.translate loc cxt prim args *) (* Test if the argument is a block or an immediate integer *) | Pjs_object_create _ -> assert false - | Pjs_call {arg_types; ffi; dynamic_import} -> + | Pjs_call {arg_types; ffi; dynamic_import; transformed_jsx} -> Lam_compile_external_call.translate_ffi cxt arg_types ffi args - ~dynamic_import + ~dynamic_import ?transformed_jsx (* FIXME, this can be removed later *) | Pisint -> E.is_type_number (Ext_list.singleton_exn args) | Pis_poly_var_block -> E.is_type_object (Ext_list.singleton_exn args) diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 74383b0ff0..fbc233fb9f 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -373,8 +373,9 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : let exit_map = Hash_int.create 0 in let may_depends = Lam_module_ident.Hash_set.create 0 in - let rec convert_ccall ?(transformed_jsx = None) (a_prim : Primitive.description) - (args : Lambda.lambda list) loc ~dynamic_import : Lam.t = + let rec convert_ccall ?(transformed_jsx = None) + (a_prim : Primitive.description) (args : Lambda.lambda list) loc + ~dynamic_import : Lam.t = let prim_name = a_prim.prim_name in match External_ffi_types.from_string a_prim.prim_native_name with | Ffi_obj_create labels -> @@ -388,8 +389,8 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : | Param_number i -> Ext_list.init i (fun _ -> External_arg_spec.dummy) in let args = Ext_list.map args convert_aux in - Lam.handle_bs_non_obj_ffi ?transformed_jsx arg_types result_type ffi args loc prim_name - ~dynamic_import + Lam.handle_bs_non_obj_ffi ?transformed_jsx arg_types result_type ffi args + loc prim_name ~dynamic_import | Ffi_inline_const i -> Lam.const i | Ffi_normal -> Location.raise_errorf ~loc @@ -455,7 +456,8 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : | Lprim (Pdirapply, _, _, _) -> assert false | Lprim (Pccall a, args, loc, transformed_jsx) -> Format.fprintf Format.err_formatter - "lam convert Pccall Has transformed_jsx %b\n" (Option.is_some transformed_jsx); + "lam convert Pccall Has transformed_jsx %b\n" + (Option.is_some transformed_jsx); convert_ccall ~transformed_jsx a args loc ~dynamic_import | Lprim (Pjs_raw_expr, args, loc, _) -> ( match args with diff --git a/compiler/core/polyvar_pattern_match.ml b/compiler/core/polyvar_pattern_match.ml index b398bac2aa..e519b712fe 100644 --- a/compiler/core/polyvar_pattern_match.ml +++ b/compiler/core/polyvar_pattern_match.ml @@ -65,7 +65,8 @@ let or_list (arg : lam) (hash_names : (int * string) list) = Lprim ( Pintcomp Ceq, [arg; Lconst (Const_pointer (hash, Pt_variant {name}))], - Location.none, None ) + Location.none, + None ) in Ext_list.fold_left rest init (fun acc (hash, name) -> Lambda.Lprim @@ -75,9 +76,11 @@ let or_list (arg : lam) (hash_names : (int * string) list) = Lprim ( Pintcomp Ceq, [arg; Lconst (Const_pointer (hash, Pt_variant {name}))], - Location.none , None ); + Location.none, + None ); ], - Location.none, None )) + Location.none, + None )) | _ -> assert false let make_test_sequence_variant_constant (fail : lam option) (arg : lam) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index d710c71485..bf9fc0c754 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -357,7 +357,7 @@ type lambda = | Lfunction of lfunction | Llet of let_kind * value_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list * Location.t * Parsetree.jsx_element option + | Lprim of primitive * lambda list * Location.t * Parsetree.jsx_element option | Lswitch of lambda * lambda_switch * Location.t | Lstringswitch of lambda * (string * lambda) list * lambda option * Location.t @@ -624,7 +624,8 @@ let rec transl_normal_path = function Lprim ( Pfield (pos, Fld_module {name = s}), [transl_normal_path p], - Location.none , None) + Location.none, + None ) | Papply _ -> assert false (* Translation of identifiers *) diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 405973c748..93a72ca4b8 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1540,7 +1540,8 @@ let make_record_matching loc all_labels def = function Lprim ( Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [arg], - loc, None ) + loc, + None ) | Record_unboxed _ -> arg | Record_extension -> Lprim @@ -1592,7 +1593,10 @@ let make_array_matching p def ctx = function if pos >= len then argl else ( Lprim - (Parrayrefu, [arg; Lconst (Const_base (Const_int pos))], p.pat_loc, None), + ( Parrayrefu, + [arg; Lconst (Const_base (Const_int pos))], + p.pat_loc, + None ), StrictOpt ) :: make_args (pos + 1) in @@ -1644,7 +1648,8 @@ let make_string_test_sequence loc arg sw d = List.fold_right (fun (s, lam) k -> Lifthenelse - ( Lprim (Pstringcomp Cneq, [arg; Lconst (Const_immstring s)], loc, None), + ( Lprim + (Pstringcomp Cneq, [arg; Lconst (Const_immstring s)], loc, None), k, lam )) sw d) @@ -1791,7 +1796,8 @@ let make_test_sequence loc fail tst lt_tst arg const_lambda_list = cut (List.length const_lambda_list / 2) const_lambda_list in Lifthenelse - ( Lprim (lt_tst, [arg; Lconst (Const_base (fst (List.hd list2)))], loc, None), + ( Lprim + (lt_tst, [arg; Lconst (Const_base (fst (List.hd list2)))], loc, None), make_test_sequence list1, make_test_sequence list2 ) in @@ -2221,7 +2227,9 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def (fun (path, act) rem -> let ext = transl_extension_path ex_pat.pat_env path in Lifthenelse - (Lprim (Pextension_slot_eq, [Lvar tag; ext], loc, None), act, rem)) + ( Lprim (Pextension_slot_eq, [Lvar tag; ext], loc, None), + act, + rem )) extension_cases default in Llet (Alias, Pgenval, tag, arg, tests) @@ -2253,7 +2261,11 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def if Datarepr.constructor_has_optional_shape cstr then Lprim (Pis_not_none, [arg], loc, None) else - Lprim (Pjscomp Cneq, [arg; Lconst (Const_base (Const_int 0))], loc, None) + Lprim + ( Pjscomp Cneq, + [arg; Lconst (Const_base (Const_int 0))], + loc, + None ) in Lifthenelse (arg, act2, act1) | 2, 0, [(i1, act1); (_, act2)], [] @@ -2840,9 +2852,11 @@ let partial_function loc () = Const_base (Const_int char); ] )); ], - loc, None ); + loc, + None ); ], - loc, None ) + loc, + None ) let for_function loc repr param pat_act_list partial = compile_matching repr (partial_function loc) param pat_act_list partial diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 1817567338..ddb7f25847 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -1233,7 +1233,10 @@ and transl_record loc env fields repres opt_init_expr = in let slot = transl_extension_path env path in Lprim - (Pmakeblock (Lambda.blk_record_ext fields mut), slot :: ll, loc, None)) + ( Pmakeblock (Lambda.blk_record_ext fields mut), + slot :: ll, + loc, + None )) in match opt_init_expr with | None -> lam @@ -1258,7 +1261,8 @@ and transl_record loc env fields repres opt_init_expr = | Record_extension -> Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) in - Lsequence (Lprim (upd, [Lvar copy_id; transl_exp expr], loc, None), cont) + Lsequence + (Lprim (upd, [Lvar copy_id; transl_exp expr], loc, None), cont) in match opt_init_expr with | None -> assert false diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index 77453c97c7..3474b94021 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -71,8 +71,10 @@ let rec apply_coercion loc strict (restr : Typedtree.module_coercion) arg = ( Pmakeblock (Blk_module runtime_fields), Ext_list.map2 pos_cc_list runtime_fields (fun (pos, cc) name -> apply_coercion loc Alias cc - (Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc, None))), - loc,None ) + (Lprim + (Pfield (pos, Fld_module {name}), [Lvar id], loc, None))), + loc, + None ) in wrap_id_pos_list loc id_pos_list get_field_name lam) | Tcoerce_functor (cc_arg, cc_res) -> @@ -306,7 +308,8 @@ and transl_structure loc fields cc rootpath final_env = function (if is_top_root_path then Blk_module_export !export_identifiers else Blk_module (List.rev_map (fun id -> id.Ident.name) fields)), block_fields, - loc, None ), + loc, + None ), List.length fields ) | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> (* Do not ignore id_pos_list ! *) @@ -342,7 +345,8 @@ and transl_structure loc fields cc rootpath final_env = function (if is_top_root_path then Blk_module_export !export_identifiers else Blk_module runtime_fields), result, - loc, None ) + loc, + None ) and id_pos_list = Ext_list.filter id_pos_list (fun (id, _, _) -> not (Lambda.IdentSet.mem id ids)) From a98e3b8e765cf981575135475c5190ef5712ddda Mon Sep 17 00:00:00 2001 From: nojaf Date: Thu, 24 Apr 2025 13:36:19 +0200 Subject: [PATCH 05/31] Initial fragment support --- compiler/core/js_dump.ml | 19 +++++++++++++++++++ compiler/core/jsx_help.ml | 33 +++++++++++++++++---------------- compiler/ml/ast_mapper.ml | 4 ++-- compiler/syntax/src/jsx_v4.ml | 2 +- 4 files changed, 39 insertions(+), 19 deletions(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index a2ef559b75..d186389b4f 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -540,6 +540,25 @@ and expression_desc cxt ~(level : int) f x : cxt = | _ -> Some (f, x)) in match jsx_element with + | Parsetree.Jsx_fragment {jsx_fragment_children = children} -> + P.string f "<>"; + (let children = + fields + |> List.find_map (fun (n, e) -> + if n = "children" then Some e else None) + in + children + |> Option.iter (fun c -> + P.string f "{"; + let _ = expression ~level:1 cxt f c in + P.string f "}")); + P.string f ""; + cxt + | Parsetree.Jsx_unary_element + {jsx_unary_element_tag_name = {txt = Longident.Lident tagName}} -> + Printf.eprintf "Crazy Tag: %s\n" tagName; + P.string f (Format.sprintf "<%s />" tagName); + cxt | Parsetree.Jsx_container_element { jsx_container_element_tag_name_start = diff --git a/compiler/core/jsx_help.ml b/compiler/core/jsx_help.ml index 25a6256bd3..a1a8f1c650 100644 --- a/compiler/core/jsx_help.ml +++ b/compiler/core/jsx_help.ml @@ -1,3 +1,18 @@ +let lambda_tag_info_to_string (e : Lambda.tag_info) = + match e with + | Lambda.Blk_constructor _ -> "Blk_constructor" + | Lambda.Blk_record_inlined _ -> "Blk_record_inlined" + | Lambda.Blk_tuple -> "Blk_tuple" + | Lambda.Blk_poly_var _ -> "Blk_poly_var" + | Lambda.Blk_record _ -> "Blk_record" + | Lambda.Blk_module _ -> "Blk_module" + | Lambda.Blk_module_export _ -> "Blk_module_export" + | Lambda.Blk_extension -> "Blk_extension" + | Lambda.Blk_some -> "Blk_some" + | Lambda.Blk_some_not_nested -> "Blk_some_not_nested" + | Lambda.Blk_record_ext _ -> "Blk_record_ext" + | Lambda.Blk_lazy_general -> "Blk_lazy_general" + let j_exp_to_string (e : J.expression) = match e.J.expression_desc with | J.Object _ -> "Object" @@ -21,7 +36,8 @@ let j_exp_to_string (e : J.expression) = | J.Array_index _ -> "Array_index" | J.Static_index _ -> "Static_index" | J.Length _ -> "Length" - | J.Caml_block _ -> "Caml_block" + | J.Caml_block (_, _, _, tag) -> + Format.sprintf "Caml_block (%s)" (lambda_tag_info_to_string tag) | J.Caml_block_tag _ -> "Caml_block_tag" | J.Tagged_template _ -> "Tagged_template" | J.Optional_block _ -> "Optional_block" @@ -29,18 +45,3 @@ let j_exp_to_string (e : J.expression) = | J.Await _ -> "Await" | J.Raw_js_code _ -> "Raw_js_code" | _ -> "Other" - -let lambda_tag_info_to_string (e : Lambda.tag_info) = - match e with - | Lambda.Blk_constructor _ -> "Blk_constructor" - | Lambda.Blk_record_inlined _ -> "Blk_record_inlined" - | Lambda.Blk_tuple -> "Blk_tuple" - | Lambda.Blk_poly_var _ -> "Blk_poly_var" - | Lambda.Blk_record _ -> "Blk_record" - | Lambda.Blk_module _ -> "Blk_module" - | Lambda.Blk_module_export _ -> "Blk_module_export" - | Lambda.Blk_extension -> "Blk_extension" - | Lambda.Blk_some -> "Blk_some" - | Lambda.Blk_some_not_nested -> "Blk_some_not_nested" - | Lambda.Blk_record_ext _ -> "Blk_record_ext" - | Lambda.Blk_lazy_general -> "Blk_lazy_general" diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index ba678c1a85..56b465d24e 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -293,8 +293,8 @@ module E = struct fun_ ~loc ~attrs ~arity ~async lab (map_opt (sub.expr sub) def) (sub.pat sub p) (sub.expr sub e) - | Pexp_apply {funct = e; args = l; partial} -> - apply ~loc ~attrs ~partial (sub.expr sub e) + | Pexp_apply {funct = e; args = l; partial; transformed_jsx} -> + apply ~loc ~attrs ~partial ?transformed_jsx (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) | Pexp_match (e, pel) -> match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index 45243d9795..89aa370d3e 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -1208,7 +1208,7 @@ let append_children_prop (config : Jsx_common.jsx_config) mapper Exp.apply (Exp.ident {txt = Ldot (element_binding, "someElement"); loc = Location.none}) - [(Nolabel, child)] + [(Nolabel, mapper.expr mapper child)] in let is_optional = match component_description with From 1801da10b00632e8e883e062048c41c80acb0b08 Mon Sep 17 00:00:00 2001 From: nojaf Date: Thu, 24 Apr 2025 18:16:43 +0200 Subject: [PATCH 06/31] WIP extract, good stuff --- compiler/core/js_dump.ml | 119 +++++++++++++++++++++++---------------- 1 file changed, 71 insertions(+), 48 deletions(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index d186389b4f..729a19eb86 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -527,64 +527,19 @@ and expression_desc cxt ~(level : int) f x : cxt = | Call (e, el, {call_transformed_jsx = Some jsx_element}) -> ( match el with | [ - _tag; + tag; { expression_desc = Caml_block (el, _mutable_flag, _, Lambda.Blk_record {fields}); }; - ] -> ( + ] -> let fields = Ext_list.array_list_filter_map fields el (fun (f, opt) x -> match x.expression_desc with | Undefined _ when opt -> None | _ -> Some (f, x)) in - match jsx_element with - | Parsetree.Jsx_fragment {jsx_fragment_children = children} -> - P.string f "<>"; - (let children = - fields - |> List.find_map (fun (n, e) -> - if n = "children" then Some e else None) - in - children - |> Option.iter (fun c -> - P.string f "{"; - let _ = expression ~level:1 cxt f c in - P.string f "}")); - P.string f ""; - cxt - | Parsetree.Jsx_unary_element - {jsx_unary_element_tag_name = {txt = Longident.Lident tagName}} -> - Printf.eprintf "Crazy Tag: %s\n" tagName; - P.string f (Format.sprintf "<%s />" tagName); - cxt - | Parsetree.Jsx_container_element - { - jsx_container_element_tag_name_start = - {txt = Longident.Lident tagName}; - } -> - P.string f (Format.sprintf "<%s" tagName); - List.iter - (fun (n, x) -> - P.space f; - P.string f n; - P.string f "="; - P.string f "{"; - let _ = expression ~level:0 cxt f x in - P.string f "}") - fields; - P.string f ">"; - cxt - | _ -> - expression_desc cxt ~level f - (Call - ( e, - el, - {call_transformed_jsx = None; arity = Full; call_info = Call_ml} - ))) + print_jsx cxt ~level f tag fields | _ -> expression_desc cxt ~level f (Call @@ -1027,6 +982,74 @@ and expression_desc cxt ~(level : int) f x : cxt = P.string f "..."; expression ~level:13 cxt f e) +(* + (* match jsx_element with + | Parsetree.Jsx_fragment {jsx_fragment_children = children} -> + P.string f "<>"; + (let children = + fields + |> List.find_map (fun (n, e) -> + if n = "children" then Some e else None) + in + children + |> Option.iter (fun c -> + P.string f "{"; + let _ = expression ~level:1 cxt f c in + P.string f "}")); + P.string f ""; + cxt + | Parsetree.Jsx_unary_element + {jsx_unary_element_tag_name = {txt = Longident.Lident tagName}} -> + Printf.eprintf "Crazy Tag: %s\n" tagName; + P.string f (Format.sprintf "<%s />" tagName); + cxt + | Parsetree.Jsx_container_element + { + jsx_container_element_tag_name_start = + {txt = Longident.Lident tagName}; + } -> + P.string f (Format.sprintf "<%s" tagName); + List.iter + (fun (n, x) -> + P.space f; + P.string f n; + P.string f "="; + P.string f "{"; + let _ = expression ~level:0 cxt f x in + P.string f "}") + fields; + P.string f ">"; + cxt *) + | _ -> + expression_desc cxt ~level f + (Call + ( e, + el, + {call_transformed_jsx = None; arity = Full; call_info = Call_ml} + ))) +*) + +and print_jsx cxt ~(level : int) f (tag : J.expression) + (fields : (string * J.expression) list) : cxt = + ignore (level, tag, fields); + let children_opt = + List.find_map (fun (n, e) -> if n = "children" then Some e else None) fields + in + (match children_opt with + | None -> P.string f "< />" + | Some children -> + P.string f "<"; + let _ = expression ~level cxt f tag in + P.string f ">"; + let _ = expression ~level cxt f children in + P.string f ""); + + cxt + and property_name_and_value_list cxt f (l : J.property_map) = iter_lst cxt f l (fun cxt f (pn, e) -> From ab32462545bd34525e52f2f8c0c683d2fa690e60 Mon Sep 17 00:00:00 2001 From: nojaf Date: Fri, 25 Apr 2025 08:30:09 +0200 Subject: [PATCH 07/31] Print props, catch with key functions --- compiler/core/js_dump.ml | 55 +++++++++++++++++++++++++++++++++++++--- 1 file changed, 51 insertions(+), 4 deletions(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 729a19eb86..a6bbee652a 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -540,6 +540,22 @@ and expression_desc cxt ~(level : int) f x : cxt = | _ -> Some (f, x)) in print_jsx cxt ~level f tag fields + | [ + tag; + { + expression_desc = + Caml_block (el, _mutable_flag, _, Lambda.Blk_record {fields}); + }; + key; + ] -> + let fields = + Ext_list.array_list_filter_map fields el (fun (f, opt) x -> + match x.expression_desc with + | Undefined _ when opt -> None + | _ -> Some (f, x)) + in + let fields = ("key", key) :: fields in + print_jsx cxt ~level f tag fields | _ -> expression_desc cxt ~level f (Call @@ -1033,19 +1049,50 @@ and expression_desc cxt ~(level : int) f x : cxt = and print_jsx cxt ~(level : int) f (tag : J.expression) (fields : (string * J.expression) list) : cxt = - ignore (level, tag, fields); + let print_tag () = + match tag.expression_desc with + | J.Str {txt} -> P.string f txt + | _ -> + let _ = expression ~level cxt f tag in + () + in let children_opt = List.find_map (fun (n, e) -> if n = "children" then Some e else None) fields in + let print_props () = + let props = List.filter (fun (n, _) -> n <> "children") fields in + if not (List.is_empty props) then + (List.iter (fun (n, x) -> + P.space f; + P.string f n; + P.string f "="; + P.string f "{"; + let _ = expression ~level:0 cxt f x in + P.string f "}")) + props + in (match children_opt with - | None -> P.string f "< />" + | None -> + P.string f "<"; + print_tag (); + print_props (); + P.string f "/>" | Some children -> + let child_is_jsx = + match children.expression_desc with + | J.Call (_, _, {call_transformed_jsx = Some _}) -> true + | _ -> false + in + P.string f "<"; - let _ = expression ~level cxt f tag in + print_tag (); + print_props (); P.string f ">"; + if not child_is_jsx then P.string f "{"; let _ = expression ~level cxt f children in + if not child_is_jsx then P.string f "}"; P.string f ""); cxt From 6b075c025bfb7a43c5c9d09e9dd396c53c51cb65 Mon Sep 17 00:00:00 2001 From: nojaf Date: Fri, 25 Apr 2025 08:59:30 +0200 Subject: [PATCH 08/31] Don't pass untyped ast, simple flag is sufficient. --- compiler/core/js_call_info.ml | 12 ++-- compiler/core/js_call_info.mli | 6 +- compiler/core/js_dump.ml | 10 ++- compiler/core/lam.ml | 8 +-- compiler/core/lam.mli | 11 +--- compiler/core/lam_compile.ml | 4 +- compiler/core/lam_compile_external_call.ml | 7 +-- compiler/core/lam_compile_external_call.mli | 2 +- compiler/core/lam_compile_primitive.ml | 8 +-- compiler/core/lam_convert.ml | 8 +-- compiler/core/lam_pass_alpha_conversion.ml | 2 +- compiler/core/lam_primitive.ml | 2 +- compiler/core/lam_primitive.mli | 2 +- compiler/core/polyvar_pattern_match.ml | 8 +-- compiler/frontend/ast_compatible.ml | 10 +-- compiler/frontend/ast_uncurry_gen.ml | 2 +- compiler/frontend/bs_ast_mapper.ml | 2 +- compiler/ml/ast_helper.ml | 3 +- compiler/ml/ast_helper.mli | 2 +- compiler/ml/ast_mapper.ml | 2 +- compiler/ml/lambda.ml | 8 +-- compiler/ml/lambda.mli | 4 +- compiler/ml/matching.ml | 69 +++++++++++---------- compiler/ml/parsetree.ml | 2 +- compiler/ml/printast.ml | 6 +- compiler/ml/transl_recmodule.ml | 4 +- compiler/ml/translcore.ml | 69 ++++++++------------- compiler/ml/translmod.ml | 16 ++--- compiler/ml/typedtree.ml | 2 +- compiler/ml/typedtree.mli | 2 +- compiler/syntax/src/jsx_v4.ml | 21 +++---- compiler/syntax/src/res_parsetree_viewer.ml | 2 +- 32 files changed, 139 insertions(+), 177 deletions(-) diff --git a/compiler/core/js_call_info.ml b/compiler/core/js_call_info.ml index 8d9c61584e..6412d91b1f 100644 --- a/compiler/core/js_call_info.ml +++ b/compiler/core/js_call_info.ml @@ -33,16 +33,12 @@ type call_info = {[ fun x y -> (f x y) === f ]} when [f] is an atom *) -type t = { - call_info: call_info; - arity: arity; - call_transformed_jsx: Parsetree.jsx_element option; -} +type t = {call_info: call_info; arity: arity; call_transformed_jsx: bool} -let dummy = {arity = NA; call_info = Call_na; call_transformed_jsx = None} +let dummy = {arity = NA; call_info = Call_na; call_transformed_jsx = false} let builtin_runtime_call = - {arity = Full; call_info = Call_builtin_runtime; call_transformed_jsx = None} + {arity = Full; call_info = Call_builtin_runtime; call_transformed_jsx = false} let ml_full_call = - {arity = Full; call_info = Call_ml; call_transformed_jsx = None} + {arity = Full; call_info = Call_ml; call_transformed_jsx = false} diff --git a/compiler/core/js_call_info.mli b/compiler/core/js_call_info.mli index 9fe502556d..1977426737 100644 --- a/compiler/core/js_call_info.mli +++ b/compiler/core/js_call_info.mli @@ -35,11 +35,7 @@ type call_info = {[ fun x y -> f x y === f ]} when [f] is an atom *) -type t = { - call_info: call_info; - arity: arity; - call_transformed_jsx: Parsetree.jsx_element option; -} +type t = {call_info: call_info; arity: arity; call_transformed_jsx: bool} val dummy : t diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index a6bbee652a..8acc16db8e 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -524,7 +524,7 @@ and expression_desc cxt ~(level : int) f x : cxt = when Ext_list.length_equal el i ]} *) - | Call (e, el, {call_transformed_jsx = Some jsx_element}) -> ( + | Call (e, el, {call_transformed_jsx = true}) -> ( match el with | [ tag; @@ -561,11 +561,9 @@ and expression_desc cxt ~(level : int) f x : cxt = (Call ( e, el, - {call_transformed_jsx = None; arity = Full; call_info = Call_ml} )) - ) + {call_transformed_jsx = false; arity = Full; call_info = Call_ml} + ))) | Call (e, el, info) -> - Format.fprintf Format.err_formatter "Js_dump Has transformed_jsx %b\n" - (Option.is_some info.call_transformed_jsx); P.cond_paren_group f (level > 15) (fun _ -> P.group f 0 (fun _ -> match (info, el) with @@ -1080,7 +1078,7 @@ and print_jsx cxt ~(level : int) f (tag : J.expression) | Some children -> let child_is_jsx = match children.expression_desc with - | J.Call (_, _, {call_transformed_jsx = Some _}) -> true + | J.Call (_, _, {call_transformed_jsx = is_jsx}) -> is_jsx | _ -> false in diff --git a/compiler/core/lam.ml b/compiler/core/lam.ml index 4f90ce336a..1c20bb2e8e 100644 --- a/compiler/core/lam.ml +++ b/compiler/core/lam.ml @@ -85,7 +85,7 @@ module Types = struct ap_func: t; ap_args: t list; ap_info: ap_info; - ap_transformed_jsx: Parsetree.jsx_element option; + ap_transformed_jsx: bool; } and t = @@ -130,7 +130,7 @@ module X = struct ap_func: t; ap_args: t list; ap_info: ap_info; - ap_transformed_jsx: Parsetree.jsx_element option; + ap_transformed_jsx: bool; } and lfunction = Types.lfunction = { @@ -289,7 +289,7 @@ let rec is_eta_conversion_exn params inner_args outer_args : t list = | _, _, _ -> raise_notrace Not_simple_form (** FIXME: more robust inlining check later, we should inline it before we add stub code*) -let rec apply ?(ap_transformed_jsx = None) fn args (ap_info : ap_info) : t = +let rec apply ?(ap_transformed_jsx = false) fn args (ap_info : ap_info) : t = match fn with | Lfunction { @@ -723,7 +723,7 @@ let result_wrap loc (result_type : External_ffi_types.return_wrapper) result = prim ~primitive:Pundefined_to_opt ~args:[result] loc | Return_unset | Return_identity -> result -let handle_bs_non_obj_ffi ?transformed_jsx +let handle_bs_non_obj_ffi ?(transformed_jsx = false) (arg_types : External_arg_spec.params) (result_type : External_ffi_types.return_wrapper) ffi args loc prim_name ~dynamic_import = diff --git a/compiler/core/lam.mli b/compiler/core/lam.mli index c15515b545..560d247669 100644 --- a/compiler/core/lam.mli +++ b/compiler/core/lam.mli @@ -45,7 +45,7 @@ and apply = private { ap_func: t; ap_args: t list; ap_info: ap_info; - ap_transformed_jsx: Parsetree.jsx_element option; + ap_transformed_jsx: bool; } and lfunction = { @@ -90,7 +90,7 @@ and t = private val inner_map : t -> (t -> t) -> t val handle_bs_non_obj_ffi : - ?transformed_jsx:Parsetree.jsx_element -> + ?transformed_jsx:bool -> External_arg_spec.params -> External_ffi_types.return_wrapper -> External_ffi_types.external_spec -> @@ -109,12 +109,7 @@ val global_module : ?dynamic_import:bool -> ident -> t val const : Lam_constant.t -> t -val apply : - ?ap_transformed_jsx:Parsetree.jsx_element option -> - t -> - t list -> - ap_info -> - t +val apply : ?ap_transformed_jsx:bool -> t -> t list -> ap_info -> t val function_ : attr:Lambda.function_attribute -> diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 893fd9fd7a..58ba342170 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -55,7 +55,7 @@ let rec apply_with_arity_aux (fn : J.expression) (arity : int list) { arity = Full; call_info = Call_ml; - (* no clue if this is correct *) call_transformed_jsx = None; + (* no clue if this is correct *) call_transformed_jsx = false; } fn first_part) rest continue (len - x) @@ -76,7 +76,7 @@ let rec apply_with_arity_aux (fn : J.expression) (arity : int list) arity = Full; call_info = Call_ml; (* no clue if this is correct *) call_transformed_jsx = - None; + false; } fn (Ext_list.append args @@ Ext_list.map params E.var)); diff --git a/compiler/core/lam_compile_external_call.ml b/compiler/core/lam_compile_external_call.ml index ed2b1984ef..2a5ff0f3f4 100644 --- a/compiler/core/lam_compile_external_call.ml +++ b/compiler/core/lam_compile_external_call.ml @@ -267,10 +267,9 @@ let translate_scoped_access scopes obj = | [] -> obj | x :: xs -> Ext_list.fold_left xs (E.dot obj x) E.dot -let translate_ffi ?(transformed_jsx : Parsetree.jsx_element option) - (cxt : Lam_compile_context.t) arg_types - (ffi : External_ffi_types.external_spec) (args : J.expression list) - ~dynamic_import = +let translate_ffi ?(transformed_jsx = false) (cxt : Lam_compile_context.t) + arg_types (ffi : External_ffi_types.external_spec) + (args : J.expression list) ~dynamic_import = match ffi with | Js_call {external_module_name; name; splice : _; scopes; tagged_template = true} diff --git a/compiler/core/lam_compile_external_call.mli b/compiler/core/lam_compile_external_call.mli index 4638ed618d..29e05c96f9 100644 --- a/compiler/core/lam_compile_external_call.mli +++ b/compiler/core/lam_compile_external_call.mli @@ -30,7 +30,7 @@ val ocaml_to_js_eff : (** Compile ocaml external function call to JS IR. *) val translate_ffi : - ?transformed_jsx:Parsetree.jsx_element -> + ?transformed_jsx:bool -> Lam_compile_context.t -> External_arg_spec.params -> External_ffi_types.external_spec -> diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index 3b99a95ab1..ae17cd8077 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -56,14 +56,14 @@ let get_module_system () = let import_of_path path = E.call - ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = None} + ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = false} (E.js_global "import") [E.str path] let wrap_then import value = let arg = Ident.create "m" in E.call - ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = None} + ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = false} (E.dot import "then") [ E.ocaml_fun ~return_unit:false ~async:false ~one_unit_arg:false [arg] @@ -90,7 +90,7 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) match args with | fn :: rest -> E.call - ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = None} + ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = false} fn rest | _ -> assert false) | Pnull_to_opt -> ( @@ -599,7 +599,7 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) | Pjs_object_create _ -> assert false | Pjs_call {arg_types; ffi; dynamic_import; transformed_jsx} -> Lam_compile_external_call.translate_ffi cxt arg_types ffi args - ~dynamic_import ?transformed_jsx + ~dynamic_import ~transformed_jsx (* FIXME, this can be removed later *) | Pisint -> E.is_type_number (Ext_list.singleton_exn args) | Pis_poly_var_block -> E.is_type_object (Ext_list.singleton_exn args) diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index fbc233fb9f..9bac6891f4 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -373,7 +373,7 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : let exit_map = Hash_int.create 0 in let may_depends = Lam_module_ident.Hash_set.create 0 in - let rec convert_ccall ?(transformed_jsx = None) + let rec convert_ccall ?(transformed_jsx = false) (a_prim : Primitive.description) (args : Lambda.lambda list) loc ~dynamic_import : Lam.t = let prim_name = a_prim.prim_name in @@ -382,14 +382,13 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : let args = Ext_list.map args convert_aux in prim ~primitive:(Pjs_object_create labels) ~args loc | Ffi_bs (arg_types, result_type, ffi) -> - Format.fprintf Format.err_formatter "Ffi_bs\n"; let arg_types = match arg_types with | Params ls -> ls | Param_number i -> Ext_list.init i (fun _ -> External_arg_spec.dummy) in let args = Ext_list.map args convert_aux in - Lam.handle_bs_non_obj_ffi ?transformed_jsx arg_types result_type ffi args + Lam.handle_bs_non_obj_ffi ~transformed_jsx arg_types result_type ffi args loc prim_name ~dynamic_import | Ffi_inline_const i -> Lam.const i | Ffi_normal -> @@ -455,9 +454,6 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : | Lprim (Prevapply, _, _, _) -> assert false | Lprim (Pdirapply, _, _, _) -> assert false | Lprim (Pccall a, args, loc, transformed_jsx) -> - Format.fprintf Format.err_formatter - "lam convert Pccall Has transformed_jsx %b\n" - (Option.is_some transformed_jsx); convert_ccall ~transformed_jsx a args loc ~dynamic_import | Lprim (Pjs_raw_expr, args, loc, _) -> ( match args with diff --git a/compiler/core/lam_pass_alpha_conversion.ml b/compiler/core/lam_pass_alpha_conversion.ml index 6cadf4a35e..1d80ae16ed 100644 --- a/compiler/core/lam_pass_alpha_conversion.ml +++ b/compiler/core/lam_pass_alpha_conversion.ml @@ -23,7 +23,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) let alpha_conversion (meta : Lam_stats.t) (lam : Lam.t) : Lam.t = - let rec populate_apply_info ?(ap_transformed_jsx = None) + let rec populate_apply_info ?(ap_transformed_jsx = false) (args_arity : int list) (len : int) (fn : Lam.t) (args : Lam.t list) ap_info : Lam.t = match args_arity with diff --git a/compiler/core/lam_primitive.ml b/compiler/core/lam_primitive.ml index c45fcb4fb7..f07b5aa024 100644 --- a/compiler/core/lam_primitive.ml +++ b/compiler/core/lam_primitive.ml @@ -46,7 +46,7 @@ type t = arg_types: External_arg_spec.params; ffi: External_ffi_types.external_spec; dynamic_import: bool; - transformed_jsx: Parsetree.jsx_element option; + transformed_jsx: bool; } | Pjs_object_create of External_arg_spec.obj_params (* Exceptions *) diff --git a/compiler/core/lam_primitive.mli b/compiler/core/lam_primitive.mli index f6a13ceceb..19b10cf964 100644 --- a/compiler/core/lam_primitive.mli +++ b/compiler/core/lam_primitive.mli @@ -42,7 +42,7 @@ type t = arg_types: External_arg_spec.params; ffi: External_ffi_types.external_spec; dynamic_import: bool; - transformed_jsx: Parsetree.jsx_element option; + transformed_jsx: bool; } | Pjs_object_create of External_arg_spec.obj_params | Praise diff --git a/compiler/core/polyvar_pattern_match.ml b/compiler/core/polyvar_pattern_match.ml index e519b712fe..0fd5bd585d 100644 --- a/compiler/core/polyvar_pattern_match.ml +++ b/compiler/core/polyvar_pattern_match.ml @@ -66,7 +66,7 @@ let or_list (arg : lam) (hash_names : (int * string) list) = ( Pintcomp Ceq, [arg; Lconst (Const_pointer (hash, Pt_variant {name}))], Location.none, - None ) + false ) in Ext_list.fold_left rest init (fun acc (hash, name) -> Lambda.Lprim @@ -77,10 +77,10 @@ let or_list (arg : lam) (hash_names : (int * string) list) = ( Pintcomp Ceq, [arg; Lconst (Const_pointer (hash, Pt_variant {name}))], Location.none, - None ); + false ); ], Location.none, - None )) + false )) | _ -> assert false let make_test_sequence_variant_constant (fail : lam option) (arg : lam) @@ -114,5 +114,5 @@ let call_switcher_variant_constr (loc : Location.t) (fail : lam option) ( Alias, Pgenval, v, - Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc, None), + Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc, false), call_switcher_variant_constant loc fail (Lvar v) int_lambda_list names ) diff --git a/compiler/frontend/ast_compatible.ml b/compiler/frontend/ast_compatible.ml index 982957c02f..0610abb015 100644 --- a/compiler/frontend/ast_compatible.ml +++ b/compiler/frontend/ast_compatible.ml @@ -44,7 +44,7 @@ let apply_simple ?(loc = default_loc) ?(attrs = []) (fn : expression) funct = fn; args = Ext_list.map args (fun x -> (Asttypes.Nolabel, x)); partial = false; - transformed_jsx = None; + transformed_jsx = false; }; } @@ -58,7 +58,7 @@ let app1 ?(loc = default_loc) ?(attrs = []) fn arg1 : expression = funct = fn; args = [(Nolabel, arg1)]; partial = false; - transformed_jsx = None; + transformed_jsx = false; }; } @@ -72,7 +72,7 @@ let app2 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 : expression = funct = fn; args = [(Nolabel, arg1); (Nolabel, arg2)]; partial = false; - transformed_jsx = None; + transformed_jsx = false; }; } @@ -86,7 +86,7 @@ let app3 ?(loc = default_loc) ?(attrs = []) fn arg1 arg2 arg3 : expression = funct = fn; args = [(Nolabel, arg1); (Nolabel, arg2); (Nolabel, arg3)]; partial = false; - transformed_jsx = None; + transformed_jsx = false; }; } @@ -134,7 +134,7 @@ let apply_labels ?(loc = default_loc) ?(attrs = []) fn Ext_list.map args (fun (l, a) -> (Asttypes.Labelled {txt = l; loc = Location.none}, a)); partial = false; - transformed_jsx = None; + transformed_jsx = false; }; } diff --git a/compiler/frontend/ast_uncurry_gen.ml b/compiler/frontend/ast_uncurry_gen.ml index aa241deb83..9e0a43fe37 100644 --- a/compiler/frontend/ast_uncurry_gen.ml +++ b/compiler/frontend/ast_uncurry_gen.ml @@ -75,5 +75,5 @@ let to_method_callback loc (self : Bs_ast_mapper.mapper) label [Typ.any ~loc ()]) ); ]; partial = false; - transformed_jsx = None; + transformed_jsx = false; } diff --git a/compiler/frontend/bs_ast_mapper.ml b/compiler/frontend/bs_ast_mapper.ml index 075aaa19f4..a6dfc764e3 100644 --- a/compiler/frontend/bs_ast_mapper.ml +++ b/compiler/frontend/bs_ast_mapper.ml @@ -331,7 +331,7 @@ module E = struct (map_opt (sub.expr sub) def) (sub.pat sub p) (sub.expr sub e) | Pexp_apply {funct = e; args = l; partial; transformed_jsx} -> - apply ~loc ~attrs ~partial ?transformed_jsx (sub.expr sub e) + apply ~loc ~attrs ~partial ~transformed_jsx (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) | Pexp_match (e, pel) -> match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) diff --git a/compiler/ml/ast_helper.ml b/compiler/ml/ast_helper.ml index a10c55c5b2..05c715e6f5 100644 --- a/compiler/ml/ast_helper.ml +++ b/compiler/ml/ast_helper.ml @@ -154,7 +154,8 @@ module Exp = struct let fun_ ?loc ?attrs ?(async = false) ~arity a b c d = mk ?loc ?attrs (Pexp_fun {arg_label = a; default = b; lhs = c; rhs = d; arity; async}) - let apply ?loc ?attrs ?(partial = false) ?transformed_jsx funct args = + let apply ?loc ?attrs ?(partial = false) ?(transformed_jsx = false) funct args + = mk ?loc ?attrs (Pexp_apply {funct; args; partial; transformed_jsx}) let match_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_match (a, b)) let try_ ?loc ?attrs a b = mk ?loc ?attrs (Pexp_try (a, b)) diff --git a/compiler/ml/ast_helper.mli b/compiler/ml/ast_helper.mli index 73dda41177..467050bb5b 100644 --- a/compiler/ml/ast_helper.mli +++ b/compiler/ml/ast_helper.mli @@ -149,7 +149,7 @@ module Exp : sig ?loc:loc -> ?attrs:attrs -> ?partial:bool -> - ?transformed_jsx:jsx_element -> + ?transformed_jsx:bool -> expression -> (arg_label * expression) list -> expression diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index 56b465d24e..dbaea2b466 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -294,7 +294,7 @@ module E = struct (map_opt (sub.expr sub) def) (sub.pat sub p) (sub.expr sub e) | Pexp_apply {funct = e; args = l; partial; transformed_jsx} -> - apply ~loc ~attrs ~partial ?transformed_jsx (sub.expr sub e) + apply ~loc ~attrs ~partial ~transformed_jsx (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) | Pexp_match (e, pel) -> match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index bf9fc0c754..0692f0aedb 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -357,7 +357,7 @@ type lambda = | Lfunction of lfunction | Llet of let_kind * value_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list * Location.t * Parsetree.jsx_element option + | Lprim of primitive * lambda list * Location.t * bool | Lswitch of lambda * lambda_switch * Location.t | Lstringswitch of lambda * (string * lambda) list * lambda option * Location.t @@ -383,7 +383,7 @@ and lambda_apply = { ap_args: lambda list; ap_loc: Location.t; ap_inlined: inline_attribute; - ap_transformed_jsx: Parsetree.jsx_element option; + ap_transformed_jsx: bool; } and lambda_switch = { @@ -618,14 +618,14 @@ let rec patch_guarded patch = function let rec transl_normal_path = function | Path.Pident id -> - if Ident.global id then Lprim (Pgetglobal id, [], Location.none, None) + if Ident.global id then Lprim (Pgetglobal id, [], Location.none, false) else Lvar id | Pdot (p, s, pos) -> Lprim ( Pfield (pos, Fld_module {name = s}), [transl_normal_path p], Location.none, - None ) + false ) | Papply _ -> assert false (* Translation of identifiers *) diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 6777d4798a..12ff51c086 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -324,7 +324,7 @@ type lambda = | Lfunction of lfunction | Llet of let_kind * value_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list * Location.t * Parsetree.jsx_element option + | Lprim of primitive * lambda list * Location.t * bool | Lswitch of lambda * lambda_switch * Location.t (* switch on strings, clauses are sorted by string order, strings are pairwise distinct *) @@ -352,7 +352,7 @@ and lambda_apply = { ap_args: lambda list; ap_loc: Location.t; ap_inlined: inline_attribute; (* specified with the [@inlined] attribute *) - ap_transformed_jsx: Parsetree.jsx_element option; + ap_transformed_jsx: bool; } and lambda_switch = { diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index 93a72ca4b8..dde5d74a62 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1194,7 +1194,7 @@ let make_field_args ~fld_info loc binding_kind arg first_pos last_pos argl = let rec make_args pos = if pos > last_pos then argl else - (Lprim (Pfield (pos, fld_info), [arg], loc, None), binding_kind) + (Lprim (Pfield (pos, fld_info), [arg], loc, false), binding_kind) :: make_args (pos + 1) in make_args first_pos @@ -1277,7 +1277,7 @@ let make_constr_matching p def ctx = function Pval_from_option_not_nest | _ -> Pval_from_option in - (Lprim (from_option, [arg], p.pat_loc, None), Alias) :: argl + (Lprim (from_option, [arg], p.pat_loc, false), Alias) :: argl | Cstr_constant _ | Cstr_block _ -> make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl ~fld_info:(if cstr.cstr_name = "::" then Fld_cons else Fld_variant) @@ -1336,7 +1336,7 @@ let make_variant_matching_nonconst p lab def ctx = function { cases = []; args = - ( Lprim (Pfield (1, Fld_poly_var_content), [arg], p.pat_loc, None), + ( Lprim (Pfield (1, Fld_poly_var_content), [arg], p.pat_loc, false), Alias ) :: argl; default = def; @@ -1427,9 +1427,9 @@ let get_mod_field modname field = in Lprim ( Pfield (p, Fld_module {name = field}), - [Lprim (Pgetglobal mod_ident, [], Location.none, None)], + [Lprim (Pgetglobal mod_ident, [], Location.none, false)], Location.none, - None ) + false ) with Not_found -> fatal_error ("Module " ^ modname ^ " unavailable.")) let code_force = get_mod_field Primitive_modules.lazy_ "force" @@ -1451,7 +1451,7 @@ let inline_lazy_force arg loc = ap_inlined = Default_inline; ap_args = [arg]; ap_loc = loc; - ap_transformed_jsx = None; + ap_transformed_jsx = false; } let make_lazy_matching def = function | [] -> fatal_error "Matching.make_lazy_matching" @@ -1486,7 +1486,7 @@ let make_tuple_matching loc arity def = function let rec make_args pos = if pos >= arity then argl else - (Lprim (Pfield (pos, Fld_tuple), [arg], loc, None), Alias) + (Lprim (Pfield (pos, Fld_tuple), [arg], loc, false), Alias) :: make_args (pos + 1) in { @@ -1535,20 +1535,21 @@ let make_record_matching loc all_labels def = function match lbl.lbl_repres with | Record_float_unused -> assert false | Record_regular -> - Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc, None) + Lprim + (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc, false) | Record_inlined _ -> Lprim ( Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [arg], loc, - None ) + false ) | Record_unboxed _ -> arg | Record_extension -> Lprim ( Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), [arg], loc, - None ) + false ) in let str = match lbl.lbl_mut with @@ -1596,7 +1597,7 @@ let make_array_matching p def ctx = function ( Parrayrefu, [arg; Lconst (Const_base (Const_int pos))], p.pat_loc, - None ), + false ), StrictOpt ) :: make_args (pos + 1) in @@ -1649,7 +1650,7 @@ let make_string_test_sequence loc arg sw d = (fun (s, lam) k -> Lifthenelse ( Lprim - (Pstringcomp Cneq, [arg; Lconst (Const_immstring s)], loc, None), + (Pstringcomp Cneq, [arg; Lconst (Const_immstring s)], loc, false), k, lam )) sw d) @@ -1667,9 +1668,9 @@ let zero_lam = Lconst (Const_base (Const_int 0)) let tree_way_test loc arg lt eq gt = Lifthenelse - ( Lprim (Pintcomp Clt, [arg; zero_lam], loc, None), + ( Lprim (Pintcomp Clt, [arg; zero_lam], loc, false), lt, - Lifthenelse (Lprim (Pintcomp Clt, [zero_lam; arg], loc, None), gt, eq) ) + Lifthenelse (Lprim (Pintcomp Clt, [zero_lam; arg], loc, false), gt, eq) ) (* Dichotomic tree *) @@ -1680,7 +1681,7 @@ let rec do_make_string_test_tree loc arg sw delta d = else let lt, (s, act), gt = split len sw in bind_sw - (Lprim (Pstringcomp Ceq, [arg; Lconst (Const_immstring s)], loc, None)) + (Lprim (Pstringcomp Ceq, [arg; Lconst (Const_immstring s)], loc, false)) (fun r -> tree_way_test loc r (do_make_string_test_tree loc arg lt delta d) @@ -1767,7 +1768,7 @@ let rec do_tests_fail loc fail tst arg = function | [] -> fail | (c, act) :: rem -> Lifthenelse - ( Lprim (tst, [arg; Lconst (Const_base c)], loc, None), + ( Lprim (tst, [arg; Lconst (Const_base c)], loc, false), do_tests_fail loc fail tst arg rem, act ) @@ -1776,7 +1777,7 @@ let rec do_tests_nofail loc tst arg = function | [(_, act)] -> act | (c, act) :: rem -> Lifthenelse - ( Lprim (tst, [arg; Lconst (Const_base c)], loc, None), + ( Lprim (tst, [arg; Lconst (Const_base c)], loc, false), do_tests_nofail loc tst arg rem, act ) @@ -1797,7 +1798,7 @@ let make_test_sequence loc fail tst lt_tst arg const_lambda_list = in Lifthenelse ( Lprim - (lt_tst, [arg; Lconst (Const_base (fst (List.hd list2)))], loc, None), + (lt_tst, [arg; Lconst (Const_base (fst (List.hd list2)))], loc, false), make_test_sequence list1, make_test_sequence list2 ) in @@ -1815,11 +1816,11 @@ module SArg = struct type act = Lambda.lambda - let make_prim p args = Lprim (p, args, Location.none, None) + let make_prim p args = Lprim (p, args, Location.none, false) let make_offset arg n = match n with | 0 -> arg - | _ -> Lprim (Poffsetint n, [arg], Location.none, None) + | _ -> Lprim (Poffsetint n, [arg], Location.none, false) let bind arg body = let newvar, newarg = @@ -1831,8 +1832,8 @@ module SArg = struct in bind Alias newvar arg (body newarg) let make_const i = Lconst (Const_base (Const_int i)) - let make_isout h arg = Lprim (Pisout, [h; arg], Location.none, None) - let make_isin h arg = Lprim (Pnot, [make_isout h arg], Location.none, None) + let make_isout h arg = Lprim (Pisout, [h; arg], Location.none, false) + let make_isin h arg = Lprim (Pnot, [make_isout h arg], Location.none, false) let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) let make_switch loc arg cases acts ~offset sw_names = let l = ref [] in @@ -2227,7 +2228,7 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def (fun (path, act) rem -> let ext = transl_extension_path ex_pat.pat_env path in Lifthenelse - ( Lprim (Pextension_slot_eq, [Lvar tag; ext], loc, None), + ( Lprim (Pextension_slot_eq, [Lvar tag; ext], loc, false), act, rem )) extension_cases default @@ -2259,13 +2260,13 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def case *) let arg = if Datarepr.constructor_has_optional_shape cstr then - Lprim (Pis_not_none, [arg], loc, None) + Lprim (Pis_not_none, [arg], loc, false) else Lprim ( Pjscomp Cneq, [arg; Lconst (Const_base (Const_int 0))], loc, - None ) + false ) in Lifthenelse (arg, act2, act1) | 2, 0, [(i1, act1); (_, act2)], [] @@ -2289,7 +2290,7 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def match act0 with | Some act when false (* relies on tag being an int *) -> Lifthenelse - ( Lprim (Pisint, [arg], loc, None), + ( Lprim (Pisint, [arg], loc, false), call_switcher loc fail_opt arg 0 (n - 1) consts sw_names, act ) (* Emit a switch, as bytecode implements this sophisticated instruction *) @@ -2328,7 +2329,7 @@ let call_switcher_variant_constr loc fail arg int_lambda_list names = ( Alias, Pgenval, v, - Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc, None), + Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc, false), call_switcher loc fail (Lvar v) min_int max_int (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) names ) @@ -2374,7 +2375,7 @@ let combine_variant names loc row arg partial ctx def row.row_fields else num_constr := max_int; let test_int_or_block arg if_int if_block = - Lifthenelse (Lprim (Pis_poly_var_block, [arg], loc, None), if_block, if_int) + Lifthenelse (Lprim (Pis_poly_var_block, [arg], loc, false), if_block, if_int) in let sig_complete = List.length tag_lambda_list = !num_constr and one_action = same_actions tag_lambda_list in @@ -2424,7 +2425,7 @@ let combine_array names loc arg partial ctx def (len_lambda_list, total1, _pats) let switch = call_switcher loc fail (Lvar newvar) 0 max_int len_lambda_list names in - bind Alias newvar (Lprim (Parraylength, [arg], loc, None)) switch + bind Alias newvar (Lprim (Parraylength, [arg], loc, false)) switch in (lambda1, jumps_union local_jumps total1) @@ -2853,10 +2854,10 @@ let partial_function loc () = ] )); ], loc, - None ); + false ); ], loc, - None ) + false ) let for_function loc repr param pat_act_list partial = compile_matching repr (partial_function loc) param pat_act_list partial @@ -2864,7 +2865,7 @@ let for_function loc repr param pat_act_list partial = (* In the following two cases, exhaustiveness info is not available! *) let for_trywith param pat_act_list = compile_matching None - (fun () -> Lprim (Praise Raise_reraise, [param], Location.none, None)) + (fun () -> Lprim (Praise Raise_reraise, [param], Location.none, false)) param pat_act_list Partial let simple_for_let loc param pat body = @@ -3031,14 +3032,14 @@ let do_for_multiple_match loc paraml pat_act_list partial = ( raise_num, { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc, None), Strict)]; + args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc, false), Strict)]; default = [([[omega]], raise_num)]; } ) | _ -> ( -1, { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc, None), Strict)]; + args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc, false), Strict)]; default = []; } ) in diff --git a/compiler/ml/parsetree.ml b/compiler/ml/parsetree.ml index 98a75e5a6c..7374827192 100644 --- a/compiler/ml/parsetree.ml +++ b/compiler/ml/parsetree.ml @@ -244,7 +244,7 @@ and expression_desc = funct: expression; args: (arg_label * expression) list; partial: bool; - transformed_jsx: jsx_element option; + transformed_jsx: bool; } (* E0 ~l1:E1 ... ~ln:En li can be empty (non labeled argument) or start with '?' diff --git a/compiler/ml/printast.ml b/compiler/ml/printast.ml index bb96c45693..66a53135c1 100644 --- a/compiler/ml/printast.ml +++ b/compiler/ml/printast.ml @@ -256,11 +256,7 @@ and expression i ppf x = if partial then line i ppf "partial\n"; expression i ppf e; list i label_x_expression ppf l; - Option.iter - (fun jsx -> - line i ppf "transformed_jsx:\n"; - expression (i + 1) ppf {x with pexp_desc = Pexp_jsx_element jsx}) - transformed_jsx + line i ppf "transformed_jsx: %b\n" transformed_jsx | Pexp_match (e, l) -> line i ppf "Pexp_match\n"; expression i ppf e; diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index cd71664b90..8a6acad180 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -151,7 +151,7 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = ( Strict, Pgenval, id, - Lprim (Pinit_mod, [loc; shape], Location.none, None), + Lprim (Pinit_mod, [loc; shape], Location.none, false), bind_inits rem acc ) in let rec bind_strict args acc = @@ -167,7 +167,7 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = | (_id, None, _rhs) :: rem -> patch_forwards rem | (id, Some (_loc, shape), rhs) :: rem -> Lsequence - ( Lprim (Pupdate_mod, [shape; Lvar id; rhs], Location.none, None), + ( Lprim (Pupdate_mod, [shape; Lvar id; rhs], Location.none, false), patch_forwards rem ) in bind_inits bindings (bind_strict bindings (patch_forwards bindings)) diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index ddb7f25847..7c9a50731e 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -44,7 +44,7 @@ let transl_extension_constructor env path ext = in let loc = ext.ext_loc in match ext.ext_kind with - | Text_decl _ -> Lprim (Pcreate_extension name, [], loc, None) + | Text_decl _ -> Lprim (Pcreate_extension name, [], loc, false) | Text_rebind (path, _lid) -> transl_extension_path ~loc env path (* Translation of primitives *) @@ -460,7 +460,7 @@ let transl_primitive loc p env ty = params = [param]; attr = default_function_attribute; loc; - body = Lprim (Pmakeblock Blk_tuple, [lam; Lvar param], loc, None); + body = Lprim (Pmakeblock Blk_tuple, [lam; Lvar param], loc, false); } | _ -> assert false) | _ -> @@ -471,7 +471,8 @@ let transl_primitive loc p env ty = :: make_params (n - 1) total in let prim_arity = p.prim_arity in - if p.prim_from_constructor || prim_arity = 0 then Lprim (prim, [], loc, None) + if p.prim_from_constructor || prim_arity = 0 then + Lprim (prim, [], loc, false) else let params = if prim_arity = 1 then [Ident.create "prim"] @@ -482,7 +483,7 @@ let transl_primitive loc p env ty = params; attr = default_function_attribute; loc; - body = Lprim (prim, List.map (fun id -> Lvar id) params, loc, None); + body = Lprim (prim, List.map (fun id -> Lvar id) params, loc, false); } let transl_primitive_application loc prim env ty args = @@ -630,10 +631,10 @@ let assert_failed exp = ] )); ], exp.exp_loc, - None ); + false ); ], exp.exp_loc, - None ) + false ) let rec cut n l = if n = 0 then ([], l) @@ -703,7 +704,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = ( prim (* could be replaced with Opaque in the future except arity 0*), [lambda], loc, - None ) + false ) | None -> lambda) | Texp_apply { @@ -717,16 +718,9 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = } when List.length oargs >= p.prim_arity && List.for_all (fun (_, arg) -> arg <> None) oargs -> ( - Format.fprintf Format.err_formatter - "transl_exp0 when Has transformed_jsx %b" - (Option.is_some transformed_jsx); let args, args' = cut p.prim_arity oargs in let wrap f = - if args' = [] then ( - Format.fprintf Format.err_formatter - "args' = [] Has transformed_jsx %b\n" - (Option.is_some transformed_jsx); - f) + if args' = [] then f else let inlined, _ = Translattribute.get_and_remove_inlined_attribute funct @@ -755,8 +749,6 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = wrap (Lprim (Praise k, [targ], e.exp_loc, transformed_jsx)) | Ploc kind, [] -> lam_of_loc kind e.exp_loc | Ploc kind, [arg1] -> - Format.fprintf Format.err_formatter "Ploc Has transformed_jsx %b" - (Option.is_some transformed_jsx); let lam = lam_of_loc kind arg1.exp_loc in Lprim (Pmakeblock Blk_tuple, lam :: argl, e.exp_loc, transformed_jsx) | Ploc _, _ -> assert false @@ -764,8 +756,6 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = match (prim, argl) with | _ -> wrap (Lprim (prim, argl, e.exp_loc, transformed_jsx)))) | Texp_apply {funct; args = oargs; partial; transformed_jsx} -> - Format.fprintf Format.err_formatter "transl_exp0 Has transformed_jsx %b" - (Option.is_some transformed_jsx); let inlined, funct = Translattribute.get_and_remove_inlined_attribute funct in @@ -794,7 +784,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Texp_tuple el -> ( let ll = transl_list el in try Lconst (Const_block (Blk_tuple, List.map extract_constant ll)) - with Not_constant -> Lprim (Pmakeblock Blk_tuple, ll, e.exp_loc, None)) + with Not_constant -> Lprim (Pmakeblock Blk_tuple, ll, e.exp_loc, false)) | Texp_construct ({txt = Lident "false"}, _, []) -> Lconst Const_false | Texp_construct ({txt = Lident "true"}, _, []) -> Lconst Const_true | Texp_construct (lid, cstr, args) -> ( @@ -849,13 +839,13 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = } in try Lconst (Const_block (tag_info, List.map extract_constant ll)) - with Not_constant -> Lprim (Pmakeblock tag_info, ll, e.exp_loc, None)) + with Not_constant -> Lprim (Pmakeblock tag_info, ll, e.exp_loc, false)) | Cstr_extension path -> Lprim ( Pmakeblock Blk_extension, transl_extension_path e.exp_env path :: ll, e.exp_loc, - None )) + false )) | Texp_extension_constructor (_, path) -> transl_extension_path e.exp_env path | Texp_variant (l, arg) -> ( let tag = Btype.hash_variant l in @@ -873,7 +863,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = ( Pmakeblock tag_info, [Lconst (Const_base (Const_int tag)); lam], e.exp_loc, - None ))) + false ))) | Texp_record {fields; representation; extended_expression} -> transl_record e.exp_loc e.exp_env fields representation extended_expression | Texp_field (arg, _, lbl) -> ( @@ -882,20 +872,20 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Record_float_unused -> assert false | Record_regular -> Lprim - (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [targ], e.exp_loc, None) + (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [targ], e.exp_loc, false) | Record_inlined _ -> Lprim ( Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [targ], e.exp_loc, - None ) + false ) | Record_unboxed _ -> targ | Record_extension -> Lprim ( Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), [targ], e.exp_loc, - None )) + false )) | Texp_setfield (arg, _, lbl, newval) -> let access = match lbl.lbl_repres with @@ -907,10 +897,10 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Record_extension -> Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) in - Lprim (access, [transl_exp arg; transl_exp newval], e.exp_loc, None) + Lprim (access, [transl_exp arg; transl_exp newval], e.exp_loc, false) | Texp_array expr_list -> let ll = transl_list expr_list in - Lprim (Pmakearray Mutable, ll, e.exp_loc, None) + Lprim (Pmakearray Mutable, ll, e.exp_loc, false) | Texp_ifthenelse (cond, ifso, Some ifnot) -> Lifthenelse (transl_exp cond, transl_exp ifso, transl_exp ifnot) | Texp_ifthenelse (cond, ifso, None) -> @@ -944,7 +934,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = (* when e needs no computation (constants, identifiers, ...), we optimize the translation just as Lazy.lazy_from_val would do *) - Lprim (Pmakeblock Blk_lazy_general, [transl_exp e], e.exp_loc, None) + Lprim (Pmakeblock Blk_lazy_general, [transl_exp e], e.exp_loc, false) and transl_list expr_list = List.map transl_exp expr_list @@ -970,11 +960,9 @@ and transl_case_try {c_lhs; c_guard; c_rhs} = and transl_cases_try cases = List.map transl_case_try cases and transl_apply ?(inlined = Default_inline) - ?(uncurried_partial_application = None) ?(transformed_jsx = None) lam sargs + ?(uncurried_partial_application = None) ?(transformed_jsx = false) lam sargs loc = let lapply ap_func ap_args = - Format.fprintf Format.err_formatter "Lapply transformed_jsx %b" - (Option.is_some transformed_jsx); Lapply { ap_loc = loc; @@ -1039,9 +1027,6 @@ and transl_apply ?(inlined = Default_inline) in let extra_args = Ext_list.map extra_ids (fun id -> Lvar id) in let ap_args = args @ extra_args in - Format.fprintf Format.err_formatter - "uncurried_partial_application transformed_jsx %b" - (Option.is_some transformed_jsx); let l0 = Lapply { @@ -1140,7 +1125,7 @@ and transl_record loc env fields repres opt_init_expr = (* could be replaced with Opaque in the future except arity 0*) [lambda], loc, - None ) + false ) else lambda | _ -> ( let size = Array.length fields in @@ -1177,7 +1162,7 @@ and transl_record loc env fields repres opt_init_expr = | Record_extension -> Pfield (i + 1, Lambda.fld_record_extension lbl) in - Lprim (access, [Lvar init_id], loc, None) + Lprim (access, [Lvar init_id], loc, false) | Overridden (_lid, expr) -> transl_exp expr) fields in @@ -1210,7 +1195,7 @@ and transl_record loc env fields repres opt_init_expr = with Not_constant -> ( match repres with | Record_regular -> - Lprim (Pmakeblock (Lambda.blk_record fields mut), ll, loc, None) + Lprim (Pmakeblock (Lambda.blk_record fields mut), ll, loc, false) | Record_float_unused -> assert false | Record_inlined {tag; name; num_nonconsts; attrs} -> Lprim @@ -1219,7 +1204,7 @@ and transl_record loc env fields repres opt_init_expr = ~attrs mut), ll, loc, - None ) + false ) | Record_unboxed _ -> ( match ll with | [v] -> v @@ -1236,7 +1221,7 @@ and transl_record loc env fields repres opt_init_expr = ( Pmakeblock (Lambda.blk_record_ext fields mut), slot :: ll, loc, - None )) + false )) in match opt_init_expr with | None -> lam @@ -1262,7 +1247,7 @@ and transl_record loc env fields repres opt_init_expr = Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) in Lsequence - (Lprim (upd, [Lvar copy_id; transl_exp expr], loc, None), cont) + (Lprim (upd, [Lvar copy_id; transl_exp expr], loc, false), cont) in match opt_init_expr with | None -> assert false @@ -1271,7 +1256,7 @@ and transl_record loc env fields repres opt_init_expr = ( Strict, Pgenval, copy_id, - Lprim (Pduprecord, [transl_exp init_expr], loc, None), + Lprim (Pduprecord, [transl_exp init_expr], loc, false), Array.fold_left update_field (Lvar copy_id) fields )) and transl_match e arg pat_expr_list exn_pat_expr_list partial = diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index 3474b94021..0b06c7b890 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -64,7 +64,7 @@ let rec apply_coercion loc strict (restr : Typedtree.module_coercion) arg = | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> Lambda.name_lambda strict arg (fun id -> let get_field_name name pos = - Lambda.Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc, None) + Lambda.Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc, false) in let lam = Lambda.Lprim @@ -72,9 +72,9 @@ let rec apply_coercion loc strict (restr : Typedtree.module_coercion) arg = Ext_list.map2 pos_cc_list runtime_fields (fun (pos, cc) name -> apply_coercion loc Alias cc (Lprim - (Pfield (pos, Fld_module {name}), [Lvar id], loc, None))), + (Pfield (pos, Fld_module {name}), [Lvar id], loc, false))), loc, - None ) + false ) in wrap_id_pos_list loc id_pos_list get_field_name lam) | Tcoerce_functor (cc_arg, cc_res) -> @@ -102,7 +102,7 @@ and apply_coercion_result loc strict funct param arg cc_res = ap_func = Lvar id; ap_args = [arg]; ap_inlined = Default_inline; - ap_transformed_jsx = None; + ap_transformed_jsx = false; }); }) @@ -279,7 +279,7 @@ and transl_module cc rootpath mexp = ap_func = transl_module Tcoerce_none None funct; ap_args = [transl_module ccarg None arg]; ap_inlined = inlined_attribute; - ap_transformed_jsx = None; + ap_transformed_jsx = false; }) | Tmod_constraint (arg, _, _, ccarg) -> transl_module (compose_coercions cc ccarg) rootpath arg @@ -309,7 +309,7 @@ and transl_structure loc fields cc rootpath final_env = function else Blk_module (List.rev_map (fun id -> id.Ident.name) fields)), block_fields, loc, - None ), + false ), List.length fields ) | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> (* Do not ignore id_pos_list ! *) @@ -346,7 +346,7 @@ and transl_structure loc fields cc rootpath final_env = function else Blk_module runtime_fields), result, loc, - None ) + false ) and id_pos_list = Ext_list.filter id_pos_list (fun (id, _, _) -> not (Lambda.IdentSet.mem id ids)) @@ -439,7 +439,7 @@ and transl_structure loc fields cc rootpath final_env = function ( Pfield (pos, Fld_module {name = Ident.name id}), [Lvar mid], incl.incl_loc, - None ), + false ), body ), size ) in diff --git a/compiler/ml/typedtree.ml b/compiler/ml/typedtree.ml index e47de1471a..f9769ee13b 100644 --- a/compiler/ml/typedtree.ml +++ b/compiler/ml/typedtree.ml @@ -87,7 +87,7 @@ and expression_desc = funct: expression; args: (Noloc.arg_label * expression option) list; partial: bool; - transformed_jsx: Parsetree.jsx_element option; + transformed_jsx: bool; } | Texp_match of expression * case list * case list * partial | Texp_try of expression * case list diff --git a/compiler/ml/typedtree.mli b/compiler/ml/typedtree.mli index 05fc52ca7a..f3368c9539 100644 --- a/compiler/ml/typedtree.mli +++ b/compiler/ml/typedtree.mli @@ -150,7 +150,7 @@ and expression_desc = funct: expression; args: (Noloc.arg_label * expression option) list; partial: bool; - transformed_jsx: Parsetree.jsx_element option; + transformed_jsx: bool; } (** E0 ~l1:E1 ... ~ln:En diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index 89aa370d3e..89bb301f2d 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -1232,8 +1232,7 @@ let append_children_prop (config : Jsx_common.jsx_config) mapper [(Nolabel, Exp.array (List.map (mapper.expr mapper) xs))] ); ] -let mk_react_jsx (config : Jsx_common.jsx_config) mapper - (transformed_jsx : jsx_element) loc attrs +let mk_react_jsx (config : Jsx_common.jsx_config) mapper loc attrs (component_description : componentDescription) (elementTag : expression) (props : jsx_props) (children : jsx_children) : expression = let more_than_one_children = @@ -1278,7 +1277,7 @@ let mk_react_jsx (config : Jsx_common.jsx_config) mapper [key_prop; (nolabel, unit_expr ~loc:Location.none)] ) in let args = [(nolabel, elementTag); (nolabel, props_record)] @ key_and_unit in - Exp.apply ~loc ~attrs ~transformed_jsx jsx_expr args + Exp.apply ~loc ~attrs ~transformed_jsx:true jsx_expr args (* In most situations, the component name is the make function from a module. However, if the name contains a lowercase letter, it means it probably an external component. @@ -1307,8 +1306,8 @@ let expr ~(config : Jsx_common.jsx_config) mapper expression = let fragment = Exp.ident ~loc {loc; txt = module_access_name config "jsxFragment"} in - mk_react_jsx config mapper jsx_element loc attrs FragmentComponent - fragment [] children + mk_react_jsx config mapper loc attrs FragmentComponent fragment [] + children | Jsx_unary_element {jsx_unary_element_tag_name = tag_name; jsx_unary_element_props = props} -> @@ -1316,13 +1315,13 @@ let expr ~(config : Jsx_common.jsx_config) mapper expression = if starts_with_lowercase name then (* For example 'input' *) let component_name_expr = constant_string ~loc:tag_name.loc name in - mk_react_jsx config mapper jsx_element loc attrs LowercasedComponent + mk_react_jsx config mapper loc attrs LowercasedComponent component_name_expr props (JSXChildrenItems []) else if starts_with_uppercase name then (* MyModule.make *) let make_id = mk_uppercase_tag_name_expr tag_name in - mk_react_jsx config mapper jsx_element loc attrs UppercasedComponent - make_id props (JSXChildrenItems []) + mk_react_jsx config mapper loc attrs UppercasedComponent make_id props + (JSXChildrenItems []) else Jsx_common.raise_error ~loc "JSX: element name is neither upper- or lowercase, got \"%s\"" @@ -1339,13 +1338,13 @@ let expr ~(config : Jsx_common.jsx_config) mapper expression = *) if starts_with_lowercase name then let component_name_expr = constant_string ~loc:tag_name.loc name in - mk_react_jsx config mapper jsx_element loc attrs LowercasedComponent + mk_react_jsx config mapper loc attrs LowercasedComponent component_name_expr props children else if starts_with_uppercase name then (* MyModule.make *) let make_id = mk_uppercase_tag_name_expr tag_name in - mk_react_jsx config mapper jsx_element loc attrs UppercasedComponent - make_id props children + mk_react_jsx config mapper loc attrs UppercasedComponent make_id props + children else Jsx_common.raise_error ~loc "JSX: element name is neither upper- or lowercase, got \"%s\"" diff --git a/compiler/syntax/src/res_parsetree_viewer.ml b/compiler/syntax/src/res_parsetree_viewer.ml index 171e624aa9..c23ed3b0f2 100644 --- a/compiler/syntax/src/res_parsetree_viewer.ml +++ b/compiler/syntax/src/res_parsetree_viewer.ml @@ -147,7 +147,7 @@ let rewrite_underscore_apply expr = funct = call_expr; args = new_args; partial = false; - transformed_jsx = None; + transformed_jsx = false; }; } | _ -> expr From d0bfedcf2d8ba57901a0966d806001d6d8ab7221 Mon Sep 17 00:00:00 2001 From: nojaf Date: Fri, 25 Apr 2025 09:13:17 +0200 Subject: [PATCH 09/31] Support fragments --- compiler/core/js_dump.ml | 51 ++-------------------------------------- 1 file changed, 2 insertions(+), 49 deletions(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 8acc16db8e..dba419bd18 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -996,60 +996,13 @@ and expression_desc cxt ~(level : int) f x : cxt = P.string f "..."; expression ~level:13 cxt f e) -(* - (* match jsx_element with - | Parsetree.Jsx_fragment {jsx_fragment_children = children} -> - P.string f "<>"; - (let children = - fields - |> List.find_map (fun (n, e) -> - if n = "children" then Some e else None) - in - children - |> Option.iter (fun c -> - P.string f "{"; - let _ = expression ~level:1 cxt f c in - P.string f "}")); - P.string f ""; - cxt - | Parsetree.Jsx_unary_element - {jsx_unary_element_tag_name = {txt = Longident.Lident tagName}} -> - Printf.eprintf "Crazy Tag: %s\n" tagName; - P.string f (Format.sprintf "<%s />" tagName); - cxt - | Parsetree.Jsx_container_element - { - jsx_container_element_tag_name_start = - {txt = Longident.Lident tagName}; - } -> - P.string f (Format.sprintf "<%s" tagName); - List.iter - (fun (n, x) -> - P.space f; - P.string f n; - P.string f "="; - P.string f "{"; - let _ = expression ~level:0 cxt f x in - P.string f "}") - fields; - P.string f ">"; - cxt *) - | _ -> - expression_desc cxt ~level f - (Call - ( e, - el, - {call_transformed_jsx = None; arity = Full; call_info = Call_ml} - ))) -*) - and print_jsx cxt ~(level : int) f (tag : J.expression) (fields : (string * J.expression) list) : cxt = let print_tag () = match tag.expression_desc with | J.Str {txt} -> P.string f txt + (* fragment *) + | J.Var (J.Qualified ({id = {name = "JsxRuntime"}}, Some "Fragment")) -> () | _ -> let _ = expression ~level cxt f tag in () From 3d2930e05533638e91ecf5b9650a6905856ac9d3 Mon Sep 17 00:00:00 2001 From: nojaf Date: Sat, 3 May 2025 14:23:49 +0200 Subject: [PATCH 10/31] Unwrap children --- compiler/core/js_dump.ml | 42 +++++++++++++++++++++++++++++---------- compiler/core/jsx_help.ml | 1 + 2 files changed, 33 insertions(+), 10 deletions(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index dba419bd18..4bbd8987f4 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -524,7 +524,10 @@ and expression_desc cxt ~(level : int) f x : cxt = when Ext_list.length_equal el i ]} *) - | Call (e, el, {call_transformed_jsx = true}) -> ( + | Call + ( ({expression_desc = J.Var (J.Qualified (_, Some fnName))} as e), + el, + {call_transformed_jsx = true} ) -> ( match el with | [ tag; @@ -539,7 +542,7 @@ and expression_desc cxt ~(level : int) f x : cxt = | Undefined _ when opt -> None | _ -> Some (f, x)) in - print_jsx cxt ~level f tag fields + print_jsx cxt ~level f fnName tag fields | [ tag; { @@ -555,7 +558,7 @@ and expression_desc cxt ~(level : int) f x : cxt = | _ -> Some (f, x)) in let fields = ("key", key) :: fields in - print_jsx cxt ~level f tag fields + print_jsx cxt ~level f fnName tag fields | _ -> expression_desc cxt ~level f (Call @@ -996,7 +999,7 @@ and expression_desc cxt ~(level : int) f x : cxt = P.string f "..."; expression ~level:13 cxt f e) -and print_jsx cxt ~(level : int) f (tag : J.expression) +and print_jsx cxt ~(level : int) f (fnName : string) (tag : J.expression) (fields : (string * J.expression) list) : cxt = let print_tag () = match tag.expression_desc with @@ -1008,7 +1011,17 @@ and print_jsx cxt ~(level : int) f (tag : J.expression) () in let children_opt = - List.find_map (fun (n, e) -> if n = "children" then Some e else None) fields + List.find_map + (fun (n, e) -> + if n = "children" then + if fnName = "jsxs" then + match e.J.expression_desc with + | J.Optional_block ({expression_desc = J.Array (xs, _)}, _) -> + Some xs + | _ -> Some [e] + else Some [e] + else None) + fields in let print_props () = let props = List.filter (fun (n, _) -> n <> "children") fields in @@ -1029,8 +1042,8 @@ and print_jsx cxt ~(level : int) f (tag : J.expression) print_props (); P.string f "/>" | Some children -> - let child_is_jsx = - match children.expression_desc with + let child_is_jsx child = + match child.J.expression_desc with | J.Call (_, _, {call_transformed_jsx = is_jsx}) -> is_jsx | _ -> false in @@ -1039,9 +1052,18 @@ and print_jsx cxt ~(level : int) f (tag : J.expression) print_tag (); print_props (); P.string f ">"; - if not child_is_jsx then P.string f "{"; - let _ = expression ~level cxt f children in - if not child_is_jsx then P.string f "}"; + + let _ = + children + |> List.fold_left + (fun acc e -> + if not (child_is_jsx e) then P.string f "{"; + let next = expression ~level acc f e in + if not (child_is_jsx e) then P.string f "}"; + next) + cxt + in + P.string f ""); diff --git a/compiler/core/jsx_help.ml b/compiler/core/jsx_help.ml index a1a8f1c650..936ba4fd60 100644 --- a/compiler/core/jsx_help.ml +++ b/compiler/core/jsx_help.ml @@ -17,6 +17,7 @@ let j_exp_to_string (e : J.expression) = match e.J.expression_desc with | J.Object _ -> "Object" | J.Str _ -> "String" + | J.Var (J.Qualified (_, Some o)) -> "Var_" ^ o | J.Var _ -> "Var" | J.Call _ -> "Call" | J.Fun _ -> "Fun" From 547dfcaa267c075050a2a562a4a1fd446f8c0b8b Mon Sep 17 00:00:00 2001 From: nojaf Date: Sat, 3 May 2025 14:42:03 +0200 Subject: [PATCH 11/31] Poor man feature flag --- compiler/bsc/rescript_compiler_main.ml | 2 +- compiler/common/js_config.ml | 5 +++-- compiler/common/js_config.mli | 2 +- compiler/syntax/src/jsx_ppx.ml | 4 ++-- compiler/syntax/src/jsx_v4.ml | 2 +- 5 files changed, 8 insertions(+), 7 deletions(-) diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index a5950f198e..53b688f8dc 100644 --- a/compiler/bsc/rescript_compiler_main.ml +++ b/compiler/bsc/rescript_compiler_main.ml @@ -237,7 +237,7 @@ let buckle_script_flags : (string * Bsc_args.spec * string) array = "*internal* Opens the module before typing" ); ( "-bs-jsx", string_call (fun i -> - if i <> "3" && i <> "4" then + if i <> "3" && i <> "4" && i <> "5" then Bsc_args.bad_arg (" Not supported jsx version : " ^ i); Js_config.jsx_version := Js_config.jsx_version_of_int @@ int_of_string i), diff --git a/compiler/common/js_config.ml b/compiler/common/js_config.ml index bf062d0f21..d207217487 100644 --- a/compiler/common/js_config.ml +++ b/compiler/common/js_config.ml @@ -24,7 +24,7 @@ (** Browser is not set via command line only for internal use *) -type jsx_version = Jsx_v4 +type jsx_version = Jsx_v4 | Jsx_preserve type jsx_module = React | Generic of {module_name: string} let no_version_header = ref false @@ -56,13 +56,14 @@ let no_stdlib = ref false let no_export = ref false let int_of_jsx_version = function | Jsx_v4 -> 4 - + | Jsx_preserve -> 5 let string_of_jsx_module = function | React -> "react" | Generic {module_name} -> module_name let jsx_version_of_int = function | 4 -> Some Jsx_v4 + | 5 -> Some Jsx_preserve | _ -> None let jsx_module_of_string = function diff --git a/compiler/common/js_config.mli b/compiler/common/js_config.mli index ec6e1829da..295273fd7d 100644 --- a/compiler/common/js_config.mli +++ b/compiler/common/js_config.mli @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type jsx_version = Jsx_v4 +type jsx_version = Jsx_v4 | Jsx_preserve type jsx_module = React | Generic of {module_name: string} (* val get_packages_info : diff --git a/compiler/syntax/src/jsx_ppx.ml b/compiler/syntax/src/jsx_ppx.ml index 8bd2ffd7a0..44a116178d 100644 --- a/compiler/syntax/src/jsx_ppx.ml +++ b/compiler/syntax/src/jsx_ppx.ml @@ -77,12 +77,12 @@ let get_mapper ~config = let expr mapper e = match config.version with - | 4 -> expr4 mapper e + | 4 | 5 -> expr4 mapper e | _ -> default_mapper.expr mapper e in let module_binding mapper mb = match config.version with - | 4 -> module_binding4 mapper mb + | 4 | 5 -> module_binding4 mapper mb | _ -> default_mapper.module_binding mapper mb in let save_config () = diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index 89bb301f2d..3b2e0cfa15 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -1277,7 +1277,7 @@ let mk_react_jsx (config : Jsx_common.jsx_config) mapper loc attrs [key_prop; (nolabel, unit_expr ~loc:Location.none)] ) in let args = [(nolabel, elementTag); (nolabel, props_record)] @ key_and_unit in - Exp.apply ~loc ~attrs ~transformed_jsx:true jsx_expr args + Exp.apply ~loc ~attrs ~transformed_jsx:(config.version = 5) jsx_expr args (* In most situations, the component name is the make function from a module. However, if the name contains a lowercase letter, it means it probably an external component. From 09950f126c405e2302177d5c8371f3a32e9defd6 Mon Sep 17 00:00:00 2001 From: nojaf Date: Sat, 3 May 2025 14:45:40 +0200 Subject: [PATCH 12/31] Remove duplicated in --- compiler/core/js_dump.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 4bbd8987f4..d3e94754e6 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -723,7 +723,6 @@ and expression_desc cxt ~(level : int) f x : cxt = P.cond_paren_group f (level > 12) (fun _ -> let cxt = expression ~level:0 cxt f prop in P.string f " in "; - P.string f " in "; expression ~level:0 cxt f obj) | Typeof e -> P.string f "typeof"; From 0ab69879905bb2d0719a34e9fd30a1c7719eea74 Mon Sep 17 00:00:00 2001 From: nojaf Date: Sat, 3 May 2025 14:50:06 +0200 Subject: [PATCH 13/31] Older camls --- compiler/core/js_dump.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index d3e94754e6..ed3a31ecb8 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -1024,7 +1024,7 @@ and print_jsx cxt ~(level : int) f (fnName : string) (tag : J.expression) in let print_props () = let props = List.filter (fun (n, _) -> n <> "children") fields in - if not (List.is_empty props) then + if List.length props > 0 then (List.iter (fun (n, x) -> P.space f; P.string f n; From 8e4811be59642cc1ae5e017523b87a2ede4adf2f Mon Sep 17 00:00:00 2001 From: nojaf Date: Sat, 3 May 2025 15:28:03 +0200 Subject: [PATCH 14/31] Revert "Poor man feature flag" This reverts commit 547dfcaa267c075050a2a562a4a1fd446f8c0b8b. --- compiler/bsc/rescript_compiler_main.ml | 2 +- compiler/common/js_config.ml | 5 ++--- compiler/common/js_config.mli | 2 +- compiler/syntax/src/jsx_ppx.ml | 4 ++-- compiler/syntax/src/jsx_v4.ml | 2 +- 5 files changed, 7 insertions(+), 8 deletions(-) diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index 53b688f8dc..a5950f198e 100644 --- a/compiler/bsc/rescript_compiler_main.ml +++ b/compiler/bsc/rescript_compiler_main.ml @@ -237,7 +237,7 @@ let buckle_script_flags : (string * Bsc_args.spec * string) array = "*internal* Opens the module before typing" ); ( "-bs-jsx", string_call (fun i -> - if i <> "3" && i <> "4" && i <> "5" then + if i <> "3" && i <> "4" then Bsc_args.bad_arg (" Not supported jsx version : " ^ i); Js_config.jsx_version := Js_config.jsx_version_of_int @@ int_of_string i), diff --git a/compiler/common/js_config.ml b/compiler/common/js_config.ml index d207217487..bf062d0f21 100644 --- a/compiler/common/js_config.ml +++ b/compiler/common/js_config.ml @@ -24,7 +24,7 @@ (** Browser is not set via command line only for internal use *) -type jsx_version = Jsx_v4 | Jsx_preserve +type jsx_version = Jsx_v4 type jsx_module = React | Generic of {module_name: string} let no_version_header = ref false @@ -56,14 +56,13 @@ let no_stdlib = ref false let no_export = ref false let int_of_jsx_version = function | Jsx_v4 -> 4 - | Jsx_preserve -> 5 + let string_of_jsx_module = function | React -> "react" | Generic {module_name} -> module_name let jsx_version_of_int = function | 4 -> Some Jsx_v4 - | 5 -> Some Jsx_preserve | _ -> None let jsx_module_of_string = function diff --git a/compiler/common/js_config.mli b/compiler/common/js_config.mli index 295273fd7d..ec6e1829da 100644 --- a/compiler/common/js_config.mli +++ b/compiler/common/js_config.mli @@ -22,7 +22,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -type jsx_version = Jsx_v4 | Jsx_preserve +type jsx_version = Jsx_v4 type jsx_module = React | Generic of {module_name: string} (* val get_packages_info : diff --git a/compiler/syntax/src/jsx_ppx.ml b/compiler/syntax/src/jsx_ppx.ml index 44a116178d..8bd2ffd7a0 100644 --- a/compiler/syntax/src/jsx_ppx.ml +++ b/compiler/syntax/src/jsx_ppx.ml @@ -77,12 +77,12 @@ let get_mapper ~config = let expr mapper e = match config.version with - | 4 | 5 -> expr4 mapper e + | 4 -> expr4 mapper e | _ -> default_mapper.expr mapper e in let module_binding mapper mb = match config.version with - | 4 | 5 -> module_binding4 mapper mb + | 4 -> module_binding4 mapper mb | _ -> default_mapper.module_binding mapper mb in let save_config () = diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index 3b2e0cfa15..89bb301f2d 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -1277,7 +1277,7 @@ let mk_react_jsx (config : Jsx_common.jsx_config) mapper loc attrs [key_prop; (nolabel, unit_expr ~loc:Location.none)] ) in let args = [(nolabel, elementTag); (nolabel, props_record)] @ key_and_unit in - Exp.apply ~loc ~attrs ~transformed_jsx:(config.version = 5) jsx_expr args + Exp.apply ~loc ~attrs ~transformed_jsx:true jsx_expr args (* In most situations, the component name is the make function from a module. However, if the name contains a lowercase letter, it means it probably an external component. From aa94f6fdbed6156c46ac4511fa1029a8fbcd553d Mon Sep 17 00:00:00 2001 From: nojaf Date: Sat, 3 May 2025 15:38:40 +0200 Subject: [PATCH 15/31] Add new -bs-jsx-preserve flag --- compiler/bsc/rescript_compiler_main.ml | 3 + compiler/common/js_config.ml | 1 + compiler/common/js_config.mli | 2 + compiler/frontend/ppx_entry.ml | 6 +- compiler/syntax/cli/res_cli.ml | 14 +++-- compiler/syntax/src/jsx_common.ml | 1 + compiler/syntax/src/jsx_ppx.ml | 10 ++-- compiler/syntax/src/jsx_ppx.mli | 2 + compiler/syntax/src/jsx_v4.ml | 2 +- tests/tests/src/nojaf.mjs | 24 ++++++++ tests/tests/src/nojaf.res | 80 ++++++++++++++++++++++++++ 11 files changed, 133 insertions(+), 12 deletions(-) create mode 100644 tests/tests/src/nojaf.mjs create mode 100644 tests/tests/src/nojaf.res diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index a5950f198e..485ce59351 100644 --- a/compiler/bsc/rescript_compiler_main.ml +++ b/compiler/bsc/rescript_compiler_main.ml @@ -255,6 +255,9 @@ let buckle_script_flags : (string * Bsc_args.spec * string) array = ( "-bs-jsx-mode", string_call ignore, "*internal* Set jsx mode, this is no longer used and is a no-op." ); + ( "-bs-jsx-preserve", + unit_call (fun _ -> Js_config.jsx_preserve := true), + "*internal* Preserve jsx" ); ( "-bs-package-output", string_call Js_packages_state.update_npm_package_path, "*internal* Set npm-output-path: [opt_module]:path, for example: \ diff --git a/compiler/common/js_config.ml b/compiler/common/js_config.ml index bf062d0f21..8c92235f04 100644 --- a/compiler/common/js_config.ml +++ b/compiler/common/js_config.ml @@ -50,6 +50,7 @@ let force_cmi = ref false let force_cmj = ref false let jsx_version = ref None let jsx_module = ref React +let jsx_preserve = ref false let js_stdout = ref true let all_module_aliases = ref false let no_stdlib = ref false diff --git a/compiler/common/js_config.mli b/compiler/common/js_config.mli index ec6e1829da..253b567a34 100644 --- a/compiler/common/js_config.mli +++ b/compiler/common/js_config.mli @@ -80,6 +80,8 @@ val jsx_version : jsx_version option ref val jsx_module : jsx_module ref +val jsx_preserve : bool ref + val js_stdout : bool ref val all_module_aliases : bool ref diff --git a/compiler/frontend/ppx_entry.ml b/compiler/frontend/ppx_entry.ml index e86949064f..4f6624efca 100644 --- a/compiler/frontend/ppx_entry.ml +++ b/compiler/frontend/ppx_entry.ml @@ -34,7 +34,8 @@ let rewrite_signature (ast : Parsetree.signature) : Parsetree.signature = let open Js_config in let jsx_version = int_of_jsx_version jsx_version_ in let jsx_module = string_of_jsx_module !jsx_module in - Jsx_ppx.rewrite_signature ~jsx_version ~jsx_module ast + let jsx_preserve = !jsx_preserve in + Jsx_ppx.rewrite_signature ~jsx_version ~jsx_module ~jsx_preserve ast in if !Js_config.no_builtin_ppx then ast else @@ -53,7 +54,8 @@ let rewrite_implementation (ast : Parsetree.structure) : Parsetree.structure = let open Js_config in let jsx_version = int_of_jsx_version jsx_version_ in let jsx_module = string_of_jsx_module !jsx_module in - Jsx_ppx.rewrite_implementation ~jsx_version ~jsx_module ast + let jsx_preserve = !jsx_preserve in + Jsx_ppx.rewrite_implementation ~jsx_version ~jsx_module ~jsx_preserve ast in if !Js_config.no_builtin_ppx then ast else diff --git a/compiler/syntax/cli/res_cli.ml b/compiler/syntax/cli/res_cli.ml index 572ddd95f3..c52bce4770 100644 --- a/compiler/syntax/cli/res_cli.ml +++ b/compiler/syntax/cli/res_cli.ml @@ -163,6 +163,7 @@ module ResClflags : sig val interface : bool ref val jsx_version : int ref val jsx_module : string ref + val jsx_preserve : bool ref val typechecker : bool ref val test_ast_conversion : bool ref @@ -175,6 +176,7 @@ end = struct let interface = ref false let jsx_version = ref (-1) let jsx_module = ref "react" + let jsx_preserve = ref false let file = ref "" let typechecker = ref false let test_ast_conversion = ref false @@ -225,7 +227,7 @@ module CliArgProcessor = struct [@@unboxed] let process_file ~is_interface ~width ~recover ~target ~jsx_version - ~jsx_module ~typechecker ~test_ast_conversion filename = + ~jsx_module ~jsx_preserve ~typechecker ~test_ast_conversion filename = let len = String.length filename in let process_interface = is_interface @@ -277,7 +279,8 @@ module CliArgProcessor = struct Ast_mapper_from0.default_mapper tree0 in let parsetree = - Jsx_ppx.rewrite_signature ~jsx_version ~jsx_module parsetree + Jsx_ppx.rewrite_signature ~jsx_version ~jsx_module ~jsx_preserve + parsetree in print_engine.print_interface ~width ~filename ~comments:parse_result.comments parsetree @@ -302,7 +305,8 @@ module CliArgProcessor = struct Ast_mapper_from0.default_mapper tree0 in let parsetree = - Jsx_ppx.rewrite_implementation ~jsx_version ~jsx_module parsetree + Jsx_ppx.rewrite_implementation ~jsx_version ~jsx_module ~jsx_preserve + parsetree in print_engine.print_implementation ~width ~filename ~comments:parse_result.comments parsetree @@ -315,7 +319,7 @@ let () = CliArgProcessor.process_file ~is_interface:!ResClflags.interface ~width:!ResClflags.width ~recover:!ResClflags.recover ~target:!ResClflags.print ~jsx_version:!ResClflags.jsx_version - ~jsx_module:!ResClflags.jsx_module ~typechecker:!ResClflags.typechecker - !ResClflags.file + ~jsx_module:!ResClflags.jsx_module ~jsx_preserve:!ResClflags.jsx_preserve + ~typechecker:!ResClflags.typechecker !ResClflags.file ~test_ast_conversion:!ResClflags.test_ast_conversion) [@@raises exit] diff --git a/compiler/syntax/src/jsx_common.ml b/compiler/syntax/src/jsx_common.ml index 6937bd14d0..427ad17818 100644 --- a/compiler/syntax/src/jsx_common.ml +++ b/compiler/syntax/src/jsx_common.ml @@ -6,6 +6,7 @@ type jsx_config = { mutable module_: string; mutable nested_modules: string list; mutable has_component: bool; + mutable preserve: bool; } (* Helper method to look up the [@react.component] attribute *) diff --git a/compiler/syntax/src/jsx_ppx.ml b/compiler/syntax/src/jsx_ppx.ml index 8bd2ffd7a0..d42a0be729 100644 --- a/compiler/syntax/src/jsx_ppx.ml +++ b/compiler/syntax/src/jsx_ppx.ml @@ -135,27 +135,29 @@ let get_mapper ~config = {default_mapper with expr; module_binding; signature; structure} -let rewrite_implementation ~jsx_version ~jsx_module (code : Parsetree.structure) - : Parsetree.structure = +let rewrite_implementation ~jsx_version ~jsx_module ~jsx_preserve + (code : Parsetree.structure) : Parsetree.structure = let config = { Jsx_common.version = jsx_version; module_ = jsx_module; nested_modules = []; has_component = false; + preserve = jsx_preserve; } in let mapper = get_mapper ~config in mapper.structure mapper code -let rewrite_signature ~jsx_version ~jsx_module (code : Parsetree.signature) : - Parsetree.signature = +let rewrite_signature ~jsx_version ~jsx_module ~jsx_preserve + (code : Parsetree.signature) : Parsetree.signature = let config = { Jsx_common.version = jsx_version; module_ = jsx_module; nested_modules = []; has_component = false; + preserve = jsx_preserve; } in let mapper = get_mapper ~config in diff --git a/compiler/syntax/src/jsx_ppx.mli b/compiler/syntax/src/jsx_ppx.mli index de5bd83f8f..7ed522defe 100644 --- a/compiler/syntax/src/jsx_ppx.mli +++ b/compiler/syntax/src/jsx_ppx.mli @@ -11,11 +11,13 @@ val rewrite_implementation : jsx_version:int -> jsx_module:string -> + jsx_preserve:bool -> Parsetree.structure -> Parsetree.structure val rewrite_signature : jsx_version:int -> jsx_module:string -> + jsx_preserve:bool -> Parsetree.signature -> Parsetree.signature diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index 89bb301f2d..da69cef6a1 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -1277,7 +1277,7 @@ let mk_react_jsx (config : Jsx_common.jsx_config) mapper loc attrs [key_prop; (nolabel, unit_expr ~loc:Location.none)] ) in let args = [(nolabel, elementTag); (nolabel, props_record)] @ key_and_unit in - Exp.apply ~loc ~attrs ~transformed_jsx:true jsx_expr args + Exp.apply ~loc ~attrs ~transformed_jsx:config.preserve jsx_expr args (* In most situations, the component name is the make function from a module. However, if the name contains a lowercase letter, it means it probably an external component. diff --git a/tests/tests/src/nojaf.mjs b/tests/tests/src/nojaf.mjs new file mode 100644 index 0000000000..97c6beefe0 --- /dev/null +++ b/tests/tests/src/nojaf.mjs @@ -0,0 +1,24 @@ +// Generated by ReScript, PLEASE EDIT WITH CARE + +import * as JsxRuntime from "react/jsx-runtime"; + +let React = {}; + +let ReactDOM = {}; + +function Nojaf$Icon(props) { + return ; +} + +let Icon = { + make: Nojaf$Icon +}; + +

{"Hello, world!"}

; + +export { + React, + ReactDOM, + Icon, +} +/* Not a pure module */ diff --git a/tests/tests/src/nojaf.res b/tests/tests/src/nojaf.res new file mode 100644 index 0000000000..20b4dd1b45 --- /dev/null +++ b/tests/tests/src/nojaf.res @@ -0,0 +1,80 @@ +@@config({ + flags: ["-bs-jsx", "4", "-bs-jsx-preserve"], +}) + +module React = { + type element = Jsx.element + + @val external null: element = "null" + + external float: float => element = "%identity" + external int: int => element = "%identity" + external string: string => element = "%identity" + + external array: array => element = "%identity" + + type componentLike<'props, 'return> = Jsx.componentLike<'props, 'return> + + type component<'props> = Jsx.component<'props> + + external component: componentLike<'props, element> => component<'props> = "%identity" + + @module("react") + external createElement: (component<'props>, 'props) => element = "createElement" + + @module("react") + external cloneElement: (element, 'props) => element = "cloneElement" + + @module("react") + external isValidElement: 'a => bool = "isValidElement" + + @variadic @module("react") + external createElementVariadic: (component<'props>, 'props, array) => element = + "createElement" + + @module("react/jsx-runtime") + external jsx: (component<'props>, 'props) => element = "jsx" + + @module("react/jsx-runtime") + external jsxKeyed: (component<'props>, 'props, ~key: string=?, @ignore unit) => element = "jsx" + + @module("react/jsx-runtime") + external jsxs: (component<'props>, 'props) => element = "jsxs" + + @module("react/jsx-runtime") + external jsxsKeyed: (component<'props>, 'props, ~key: string=?, @ignore unit) => element = "jsxs" + + type fragmentProps = {children?: element} + + @module("react/jsx-runtime") external jsxFragment: component = "Fragment" +} + +module ReactDOM = { + external someElement: React.element => option = "%identity" + + @module("react/jsx-runtime") + external jsx: (string, JsxDOM.domProps) => Jsx.element = "jsx" + + @module("react/jsx-runtime") + external jsxKeyed: (string, JsxDOM.domProps, ~key: string=?, @ignore unit) => Jsx.element = "jsx" + + @module("react/jsx-runtime") + external jsxs: (string, JsxDOM.domProps) => Jsx.element = "jsxs" + + @module("react/jsx-runtime") + external jsxsKeyed: (string, JsxDOM.domProps, ~key: string=?, @ignore unit) => Jsx.element = + "jsxs" +} + +module Icon = { + @react.component + let make = () => { + + } +} + +let _ = +
+

{React.string("Hello, world!")}

+ +
From e30cab34b30bc571ecb930e682e74e899252909b Mon Sep 17 00:00:00 2001 From: nojaf Date: Sun, 4 May 2025 11:28:37 +0200 Subject: [PATCH 16/31] WIP, deal with prop spreading --- compiler/core/js_dump.ml | 69 +++++++++++++++++++++++++++++++++++++++ tests/tests/src/nojaf.mjs | 32 ++++++++++++++++-- tests/tests/src/nojaf.res | 30 ++++++++++++++++- 3 files changed, 128 insertions(+), 3 deletions(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index ed3a31ecb8..f0fca503ae 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -543,6 +543,7 @@ and expression_desc cxt ~(level : int) f x : cxt = | _ -> Some (f, x)) in print_jsx cxt ~level f fnName tag fields + (* jsxKeyed call *) | [ tag; { @@ -559,6 +560,9 @@ and expression_desc cxt ~(level : int) f x : cxt = in let fields = ("key", key) :: fields in print_jsx cxt ~level f fnName tag fields + (* In the case of prop spreading *) + | [tag; ({expression_desc = J.Seq _} as props)] -> + print_jsx_prop_spreading cxt ~level f fnName tag props | _ -> expression_desc cxt ~level f (Call @@ -1069,6 +1073,71 @@ and print_jsx cxt ~(level : int) f (fnName : string) (tag : J.expression) cxt +(* TODO: clean up the code , a lot of code is duplicated *) +and print_jsx_prop_spreading cxt ~level f fnName tag props = + (* TODO: the children as somewhere present in the props Seq *) + let print_tag () = + match tag.expression_desc with + | J.Str {txt} -> P.string f txt + (* fragment *) + | J.Var (J.Qualified ({id = {name = "JsxRuntime"}}, Some "Fragment")) -> () + | _ -> + let _ = expression ~level cxt f tag in + () + in + (* let children_opt = + List.find_map + (fun (n, e) -> + if n = "children" then + if fnName = "jsxs" then + match e.J.expression_desc with + | J.Optional_block ({expression_desc = J.Array (xs, _)}, _) -> + Some xs + | _ -> Some [e] + else Some [e] + else None) + fields + in *) + let print_props () = + P.string f " {...("; + let _ = expression ~level:0 cxt f props in + P.string f ")}" + in + (match None with + | None -> + P.string f "<"; + print_tag (); + print_props (); + P.string f "/>" + | Some children -> + let child_is_jsx child = + match child.J.expression_desc with + | J.Call (_, _, {call_transformed_jsx = is_jsx}) -> is_jsx + | _ -> false + in + + P.string f "<"; + print_tag (); + print_props (); + P.string f ">"; + + let _ = + children + |> List.fold_left + (fun acc e -> + if not (child_is_jsx e) then P.string f "{"; + let next = expression ~level acc f e in + if not (child_is_jsx e) then P.string f "}"; + next) + cxt + in + + P.string f ""); + + cxt + and property_name_and_value_list cxt f (l : J.property_map) = iter_lst cxt f l (fun cxt f (pn, e) -> diff --git a/tests/tests/src/nojaf.mjs b/tests/tests/src/nojaf.mjs index 97c6beefe0..621350a58b 100644 --- a/tests/tests/src/nojaf.mjs +++ b/tests/tests/src/nojaf.mjs @@ -1,5 +1,6 @@ // Generated by ReScript, PLEASE EDIT WITH CARE +import * as Primitive_option from "rescript/lib/es6/Primitive_option.js"; import * as JsxRuntime from "react/jsx-runtime"; let React = {}; @@ -14,11 +15,38 @@ let Icon = { make: Nojaf$Icon }; -

{"Hello, world!"}

; +let _single_element_child =

{"Hello, world!"}

; + +let _multiple_element_children =

{"Hello, world!"}

; + +let _single_element_fragment = <>{Primitive_option.some()}; + +let _multiple_element_fragment = <>; + +let _unary_element_with_props = ; + +let _container_element_with_props_and_children =
{"Hello, world!"}
; + +let baseProps = { + className: "foo", + title: "foo" +}; + +let newrecord = {...baseProps}; + +let _unary_element_with_spread_props = ; export { React, ReactDOM, Icon, + _single_element_child, + _multiple_element_children, + _single_element_fragment, + _multiple_element_fragment, + _unary_element_with_props, + _container_element_with_props_and_children, + baseProps, + _unary_element_with_spread_props, } -/* Not a pure module */ +/* _single_element_child Not a pure module */ diff --git a/tests/tests/src/nojaf.res b/tests/tests/src/nojaf.res index 20b4dd1b45..df87b3fd9d 100644 --- a/tests/tests/src/nojaf.res +++ b/tests/tests/src/nojaf.res @@ -73,8 +73,36 @@ module Icon = { } } -let _ = +let _single_element_child = +
+

{React.string("Hello, world!")}

+
+ +let _multiple_element_children =

{React.string("Hello, world!")}

+ +let _single_element_fragment = + <> + + + +let _multiple_element_fragment = + <> + + + + +let _unary_element_with_props = + +let _container_element_with_props_and_children = +
{React.string("Hello, world!")}
+ +let baseProps: JsxDOM.domProps = { + title: "foo", + className: "foo", +} + +let _unary_element_with_spread_props = From 773124f8ae01704dd8849b64e360b5cc1ffc485b Mon Sep 17 00:00:00 2001 From: nojaf Date: Sun, 4 May 2025 12:00:07 +0200 Subject: [PATCH 17/31] Deal with prop spreading --- compiler/core/js_dump.ml | 60 ++++++++++++++++++++++++++++++++------- tests/tests/src/nojaf.mjs | 9 +++++- tests/tests/src/nojaf.res | 6 ++++ 3 files changed, 64 insertions(+), 11 deletions(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index f0fca503ae..53cb30effc 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -1075,7 +1075,30 @@ and print_jsx cxt ~(level : int) f (fnName : string) (tag : J.expression) (* TODO: clean up the code , a lot of code is duplicated *) and print_jsx_prop_spreading cxt ~level f fnName tag props = - (* TODO: the children as somewhere present in the props Seq *) + (* The spreading expression is going to look something like: + (newrecord.type = "text", newrecord.tabIndex = 0, newrecord.children = 5, newrecord) + Where there are some assignments to the props object and then the props object is returned. + We want to extract the assignments and turn them into props. + And so capture the object we need to spread. + *) + let fields, spread = + let rec visit acc e = + match e.J.expression_desc with + | J.Seq + ( { + J.expression_desc = + J.Bin + ( Js_op.Eq, + {J.expression_desc = J.Static_index (_, name, _)}, + value ); + }, + rest ) -> + visit ((name, value) :: acc) rest + | _ -> (List.rev acc, e) + in + visit [] props + in + let print_tag () = match tag.expression_desc with | J.Str {txt} -> P.string f txt @@ -1085,7 +1108,7 @@ and print_jsx_prop_spreading cxt ~level f fnName tag props = let _ = expression ~level cxt f tag in () in - (* let children_opt = + let children_opt = List.find_map (fun (n, e) -> if n = "children" then @@ -1097,17 +1120,32 @@ and print_jsx_prop_spreading cxt ~level f fnName tag props = else Some [e] else None) fields - in *) - let print_props () = - P.string f " {...("; - let _ = expression ~level:0 cxt f props in - P.string f ")}" in - (match None with + let print_props fields = + let props = List.filter (fun (n, _) -> n <> "children") fields in + if List.length props > 0 then + (List.iter (fun (n, x) -> + P.space f; + P.string f n; + P.string f "="; + P.string f "{"; + let _ = expression ~level:0 cxt f x in + P.string f "}")) + props + in + let print_spreaded_props () = + (* Spread the object first, as that is what happens in ReScript *) + P.string f " {..."; + let _ = expression ~level:0 cxt f spread in + P.string f "} "; + (* Then print the rest of the props *) + print_props fields + in + (match children_opt with | None -> P.string f "<"; print_tag (); - print_props (); + print_spreaded_props (); P.string f "/>" | Some children -> let child_is_jsx child = @@ -1118,7 +1156,7 @@ and print_jsx_prop_spreading cxt ~level f fnName tag props = P.string f "<"; print_tag (); - print_props (); + print_spreaded_props (); P.string f ">"; let _ = @@ -1128,6 +1166,8 @@ and print_jsx_prop_spreading cxt ~level f fnName tag props = if not (child_is_jsx e) then P.string f "{"; let next = expression ~level acc f e in if not (child_is_jsx e) then P.string f "}"; + (* Can we some indent this? *) + P.newline f; next) cxt in diff --git a/tests/tests/src/nojaf.mjs b/tests/tests/src/nojaf.mjs index 621350a58b..893d07525f 100644 --- a/tests/tests/src/nojaf.mjs +++ b/tests/tests/src/nojaf.mjs @@ -34,7 +34,13 @@ let baseProps = { let newrecord = {...baseProps}; -let _unary_element_with_spread_props = ; +let _unary_element_with_spread_props = ; + +let newrecord$1 = {...baseProps}; + +let _container_with_spread_props =
{"Hello, world!"} + +
; export { React, @@ -48,5 +54,6 @@ export { _container_element_with_props_and_children, baseProps, _unary_element_with_spread_props, + _container_with_spread_props, } /* _single_element_child Not a pure module */ diff --git a/tests/tests/src/nojaf.res b/tests/tests/src/nojaf.res index df87b3fd9d..f0df982c09 100644 --- a/tests/tests/src/nojaf.res +++ b/tests/tests/src/nojaf.res @@ -106,3 +106,9 @@ let baseProps: JsxDOM.domProps = { } let _unary_element_with_spread_props = + +let _container_with_spread_props = +
+ {React.string("Hello, world!")} + +
From 46d3d50783c6d2cdc7fe595add4f0ca0a3e119b3 Mon Sep 17 00:00:00 2001 From: Cristiano Calcagno Date: Sun, 4 May 2025 12:12:33 +0200 Subject: [PATCH 18/31] Clean up Lprim and move the information to the call primitive. --- compiler/core/lam_convert.ml | 38 +++++------ compiler/core/polyvar_pattern_match.ml | 11 ++-- compiler/frontend/external_ffi_types.ml | 1 + compiler/ml/lambda.ml | 13 ++-- compiler/ml/lambda.mli | 2 +- compiler/ml/matching.ml | 88 ++++++++++--------------- compiler/ml/primitive.ml | 4 ++ compiler/ml/primitive.mli | 3 + compiler/ml/printlambda.ml | 2 +- compiler/ml/transl_recmodule.ml | 6 +- compiler/ml/translattribute.ml | 4 +- compiler/ml/translcore.ml | 75 +++++++++------------ compiler/ml/translmod.ml | 17 ++--- 13 files changed, 114 insertions(+), 150 deletions(-) diff --git a/compiler/core/lam_convert.ml b/compiler/core/lam_convert.ml index 9bac6891f4..a6be3cc311 100644 --- a/compiler/core/lam_convert.ml +++ b/compiler/core/lam_convert.ml @@ -348,8 +348,8 @@ let rec rename_optional_parameters map params (body : Lambda.lambda) = value_kind, id, Lifthenelse - ( Lprim (p, [Lvar ({name = "*opt*"} as opt)], p_loc, p_tj), - Lprim (p1, [Lvar ({name = "*opt*"} as opt2)], x_loc, x_tj), + ( Lprim (p, [Lvar ({name = "*opt*"} as opt)], p_loc), + Lprim (p1, [Lvar ({name = "*opt*"} as opt2)], x_loc), f ), rest ) when Ident.same opt opt2 && List.mem opt params -> @@ -361,8 +361,8 @@ let rec rename_optional_parameters map params (body : Lambda.lambda) = value_kind, id, Lifthenelse - ( Lprim (p, [Lvar new_id], p_loc, p_tj), - Lprim (p1, [Lvar new_id], x_loc, x_tj), + ( Lprim (p, [Lvar new_id], p_loc), + Lprim (p1, [Lvar new_id], x_loc), f ), rest ) ) | _ -> (map, body) @@ -373,9 +373,8 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : let exit_map = Hash_int.create 0 in let may_depends = Lam_module_ident.Hash_set.create 0 in - let rec convert_ccall ?(transformed_jsx = false) - (a_prim : Primitive.description) (args : Lambda.lambda list) loc - ~dynamic_import : Lam.t = + let rec convert_ccall (a_prim : Primitive.description) + (args : Lambda.lambda list) loc ~dynamic_import : Lam.t = let prim_name = a_prim.prim_name in match External_ffi_types.from_string a_prim.prim_native_name with | Ffi_obj_create labels -> @@ -388,8 +387,8 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : | Param_number i -> Ext_list.init i (fun _ -> External_arg_spec.dummy) in let args = Ext_list.map args convert_aux in - Lam.handle_bs_non_obj_ffi ~transformed_jsx arg_types result_type ffi args - loc prim_name ~dynamic_import + Lam.handle_bs_non_obj_ffi ~transformed_jsx:a_prim.transformed_jsx + arg_types result_type ffi args loc prim_name ~dynamic_import | Ffi_inline_const i -> Lam.const i | Ffi_normal -> Location.raise_errorf ~loc @@ -448,21 +447,20 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : let lam = Lam.letrec bindings body in Lam_scc.scc bindings lam body (* inlining will affect how mututal recursive behave *) - | Lprim (Prevapply, [x; f], outer_loc, _) - | Lprim (Pdirapply, [f; x], outer_loc, _) -> + | Lprim (Prevapply, [x; f], outer_loc) | Lprim (Pdirapply, [f; x], outer_loc) + -> convert_pipe f x outer_loc - | Lprim (Prevapply, _, _, _) -> assert false - | Lprim (Pdirapply, _, _, _) -> assert false - | Lprim (Pccall a, args, loc, transformed_jsx) -> - convert_ccall ~transformed_jsx a args loc ~dynamic_import - | Lprim (Pjs_raw_expr, args, loc, _) -> ( + | Lprim (Prevapply, _, _) -> assert false + | Lprim (Pdirapply, _, _) -> assert false + | Lprim (Pccall a, args, loc) -> convert_ccall a args loc ~dynamic_import + | Lprim (Pjs_raw_expr, args, loc) -> ( match args with | [Lconst (Const_base (Const_string (code, _)))] -> (* js parsing here *) let kind = Classify_function.classify code in prim ~primitive:(Praw_js_code {code; code_info = Exp kind}) ~args:[] loc | _ -> assert false) - | Lprim (Pjs_raw_stmt, args, loc, _) -> ( + | Lprim (Pjs_raw_stmt, args, loc) -> ( match args with | [Lconst (Const_base (Const_string (code, _)))] -> let kind = Classify_function.classify_stmt code in @@ -470,7 +468,7 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : ~primitive:(Praw_js_code {code; code_info = Stmt kind}) ~args:[] loc | _ -> assert false) - | Lprim (Pgetglobal id, args, _, _) -> + | Lprim (Pgetglobal id, args, _) -> let args = Ext_list.map args convert_aux in if Ident.is_predef_exn id then Lam.const (Const_string {s = id.name; unicode = false}) @@ -478,10 +476,10 @@ let convert (exports : Set_ident.t) (lam : Lambda.lambda) : may_depend may_depends (Lam_module_ident.of_ml ~dynamic_import id); assert (args = []); Lam.global_module ~dynamic_import id) - | Lprim (Pimport, args, loc, _) -> + | Lprim (Pimport, args, loc) -> let args = Ext_list.map args (convert_aux ~dynamic_import:true) in lam_prim ~primitive:Pimport ~args loc - | Lprim (primitive, args, loc, tj) -> + | Lprim (primitive, args, loc) -> let args = Ext_list.map args (convert_aux ~dynamic_import) in lam_prim ~primitive ~args loc | Lswitch (e, s, _loc) -> convert_switch e s diff --git a/compiler/core/polyvar_pattern_match.ml b/compiler/core/polyvar_pattern_match.ml index 0fd5bd585d..fea0b53f1d 100644 --- a/compiler/core/polyvar_pattern_match.ml +++ b/compiler/core/polyvar_pattern_match.ml @@ -65,8 +65,7 @@ let or_list (arg : lam) (hash_names : (int * string) list) = Lprim ( Pintcomp Ceq, [arg; Lconst (Const_pointer (hash, Pt_variant {name}))], - Location.none, - false ) + Location.none ) in Ext_list.fold_left rest init (fun acc (hash, name) -> Lambda.Lprim @@ -76,11 +75,9 @@ let or_list (arg : lam) (hash_names : (int * string) list) = Lprim ( Pintcomp Ceq, [arg; Lconst (Const_pointer (hash, Pt_variant {name}))], - Location.none, - false ); + Location.none ); ], - Location.none, - false )) + Location.none )) | _ -> assert false let make_test_sequence_variant_constant (fail : lam option) (arg : lam) @@ -114,5 +111,5 @@ let call_switcher_variant_constr (loc : Location.t) (fail : lam option) ( Alias, Pgenval, v, - Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc, false), + Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc), call_switcher_variant_constant loc fail (Lvar v) int_lambda_list names ) diff --git a/compiler/frontend/external_ffi_types.ml b/compiler/frontend/external_ffi_types.ml index 35419958fd..9016341603 100644 --- a/compiler/frontend/external_ffi_types.ml +++ b/compiler/frontend/external_ffi_types.ml @@ -246,6 +246,7 @@ let () = prim_native_name; prim_alloc = _; prim_from_constructor = _; + transformed_jsx = _; } : Primitive.description) (p2 : Primitive.description) diff --git a/compiler/ml/lambda.ml b/compiler/ml/lambda.ml index 0692f0aedb..dfb8c33d1b 100644 --- a/compiler/ml/lambda.ml +++ b/compiler/ml/lambda.ml @@ -357,7 +357,7 @@ type lambda = | Lfunction of lfunction | Llet of let_kind * value_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list * Location.t * bool + | Lprim of primitive * lambda list * Location.t | Lswitch of lambda * lambda_switch * Location.t | Lstringswitch of lambda * (string * lambda) list * lambda option * Location.t @@ -462,7 +462,7 @@ let make_key e = let ex = tr_rec env ex in let y = make_key x in Llet (str, k, y, ex, tr_rec (Ident.add x (Lvar y) env) e) - | Lprim (p, es, _, tj) -> Lprim (p, tr_recs env es, Location.none, tj) + | Lprim (p, es, _) -> Lprim (p, tr_recs env es, Location.none) | Lswitch (e, sw, loc) -> Lswitch (tr_rec env e, tr_sw env sw, loc) | Lstringswitch (e, sw, d, _) -> Lstringswitch @@ -520,7 +520,7 @@ let iter f = function | Lletrec (decl, body) -> f body; List.iter (fun (_id, exp) -> f exp) decl - | Lprim (_p, args, _loc, _tj) -> List.iter f args + | Lprim (_p, args, _loc) -> List.iter f args | Lswitch (arg, sw, _) -> f arg; List.iter (fun (_key, case) -> f case) sw.sw_consts; @@ -618,14 +618,13 @@ let rec patch_guarded patch = function let rec transl_normal_path = function | Path.Pident id -> - if Ident.global id then Lprim (Pgetglobal id, [], Location.none, false) + if Ident.global id then Lprim (Pgetglobal id, [], Location.none) else Lvar id | Pdot (p, s, pos) -> Lprim ( Pfield (pos, Fld_module {name = s}), [transl_normal_path p], - Location.none, - false ) + Location.none ) | Papply _ -> assert false (* Translation of identifiers *) @@ -659,7 +658,7 @@ let subst_lambda s lam = Lfunction {params; body = subst body; attr; loc} | Llet (str, k, id, arg, body) -> Llet (str, k, id, subst arg, subst body) | Lletrec (decl, body) -> Lletrec (List.map subst_decl decl, subst body) - | Lprim (p, args, loc, tj) -> Lprim (p, List.map subst args, loc, tj) + | Lprim (p, args, loc) -> Lprim (p, List.map subst args, loc) | Lswitch (arg, sw, loc) -> Lswitch ( subst arg, diff --git a/compiler/ml/lambda.mli b/compiler/ml/lambda.mli index 12ff51c086..5927479bcc 100644 --- a/compiler/ml/lambda.mli +++ b/compiler/ml/lambda.mli @@ -324,7 +324,7 @@ type lambda = | Lfunction of lfunction | Llet of let_kind * value_kind * Ident.t * lambda * lambda | Lletrec of (Ident.t * lambda) list * lambda - | Lprim of primitive * lambda list * Location.t * bool + | Lprim of primitive * lambda list * Location.t | Lswitch of lambda * lambda_switch * Location.t (* switch on strings, clauses are sorted by string order, strings are pairwise distinct *) diff --git a/compiler/ml/matching.ml b/compiler/ml/matching.ml index dde5d74a62..d450ab305d 100644 --- a/compiler/ml/matching.ml +++ b/compiler/ml/matching.ml @@ -1194,7 +1194,7 @@ let make_field_args ~fld_info loc binding_kind arg first_pos last_pos argl = let rec make_args pos = if pos > last_pos then argl else - (Lprim (Pfield (pos, fld_info), [arg], loc, false), binding_kind) + (Lprim (Pfield (pos, fld_info), [arg], loc), binding_kind) :: make_args (pos + 1) in make_args first_pos @@ -1277,7 +1277,7 @@ let make_constr_matching p def ctx = function Pval_from_option_not_nest | _ -> Pval_from_option in - (Lprim (from_option, [arg], p.pat_loc, false), Alias) :: argl + (Lprim (from_option, [arg], p.pat_loc), Alias) :: argl | Cstr_constant _ | Cstr_block _ -> make_field_args p.pat_loc Alias arg 0 (cstr.cstr_arity - 1) argl ~fld_info:(if cstr.cstr_name = "::" then Fld_cons else Fld_variant) @@ -1336,8 +1336,7 @@ let make_variant_matching_nonconst p lab def ctx = function { cases = []; args = - ( Lprim (Pfield (1, Fld_poly_var_content), [arg], p.pat_loc, false), - Alias ) + (Lprim (Pfield (1, Fld_poly_var_content), [arg], p.pat_loc), Alias) :: argl; default = def; }; @@ -1427,9 +1426,8 @@ let get_mod_field modname field = in Lprim ( Pfield (p, Fld_module {name = field}), - [Lprim (Pgetglobal mod_ident, [], Location.none, false)], - Location.none, - false ) + [Lprim (Pgetglobal mod_ident, [], Location.none)], + Location.none ) with Not_found -> fatal_error ("Module " ^ modname ^ " unavailable.")) let code_force = get_mod_field Primitive_modules.lazy_ "force" @@ -1486,7 +1484,7 @@ let make_tuple_matching loc arity def = function let rec make_args pos = if pos >= arity then argl else - (Lprim (Pfield (pos, Fld_tuple), [arg], loc, false), Alias) + (Lprim (Pfield (pos, Fld_tuple), [arg], loc), Alias) :: make_args (pos + 1) in { @@ -1535,21 +1533,16 @@ let make_record_matching loc all_labels def = function match lbl.lbl_repres with | Record_float_unused -> assert false | Record_regular -> - Lprim - (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc, false) + Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [arg], loc) | Record_inlined _ -> Lprim - ( Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), - [arg], - loc, - false ) + (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [arg], loc) | Record_unboxed _ -> arg | Record_extension -> Lprim ( Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), [arg], - loc, - false ) + loc ) in let str = match lbl.lbl_mut with @@ -1594,10 +1587,7 @@ let make_array_matching p def ctx = function if pos >= len then argl else ( Lprim - ( Parrayrefu, - [arg; Lconst (Const_base (Const_int pos))], - p.pat_loc, - false ), + (Parrayrefu, [arg; Lconst (Const_base (Const_int pos))], p.pat_loc), StrictOpt ) :: make_args (pos + 1) in @@ -1649,8 +1639,7 @@ let make_string_test_sequence loc arg sw d = List.fold_right (fun (s, lam) k -> Lifthenelse - ( Lprim - (Pstringcomp Cneq, [arg; Lconst (Const_immstring s)], loc, false), + ( Lprim (Pstringcomp Cneq, [arg; Lconst (Const_immstring s)], loc), k, lam )) sw d) @@ -1668,9 +1657,9 @@ let zero_lam = Lconst (Const_base (Const_int 0)) let tree_way_test loc arg lt eq gt = Lifthenelse - ( Lprim (Pintcomp Clt, [arg; zero_lam], loc, false), + ( Lprim (Pintcomp Clt, [arg; zero_lam], loc), lt, - Lifthenelse (Lprim (Pintcomp Clt, [zero_lam; arg], loc, false), gt, eq) ) + Lifthenelse (Lprim (Pintcomp Clt, [zero_lam; arg], loc), gt, eq) ) (* Dichotomic tree *) @@ -1681,7 +1670,7 @@ let rec do_make_string_test_tree loc arg sw delta d = else let lt, (s, act), gt = split len sw in bind_sw - (Lprim (Pstringcomp Ceq, [arg; Lconst (Const_immstring s)], loc, false)) + (Lprim (Pstringcomp Ceq, [arg; Lconst (Const_immstring s)], loc)) (fun r -> tree_way_test loc r (do_make_string_test_tree loc arg lt delta d) @@ -1768,7 +1757,7 @@ let rec do_tests_fail loc fail tst arg = function | [] -> fail | (c, act) :: rem -> Lifthenelse - ( Lprim (tst, [arg; Lconst (Const_base c)], loc, false), + ( Lprim (tst, [arg; Lconst (Const_base c)], loc), do_tests_fail loc fail tst arg rem, act ) @@ -1777,7 +1766,7 @@ let rec do_tests_nofail loc tst arg = function | [(_, act)] -> act | (c, act) :: rem -> Lifthenelse - ( Lprim (tst, [arg; Lconst (Const_base c)], loc, false), + ( Lprim (tst, [arg; Lconst (Const_base c)], loc), do_tests_nofail loc tst arg rem, act ) @@ -1797,8 +1786,7 @@ let make_test_sequence loc fail tst lt_tst arg const_lambda_list = cut (List.length const_lambda_list / 2) const_lambda_list in Lifthenelse - ( Lprim - (lt_tst, [arg; Lconst (Const_base (fst (List.hd list2)))], loc, false), + ( Lprim (lt_tst, [arg; Lconst (Const_base (fst (List.hd list2)))], loc), make_test_sequence list1, make_test_sequence list2 ) in @@ -1816,11 +1804,11 @@ module SArg = struct type act = Lambda.lambda - let make_prim p args = Lprim (p, args, Location.none, false) + let make_prim p args = Lprim (p, args, Location.none) let make_offset arg n = match n with | 0 -> arg - | _ -> Lprim (Poffsetint n, [arg], Location.none, false) + | _ -> Lprim (Poffsetint n, [arg], Location.none) let bind arg body = let newvar, newarg = @@ -1832,8 +1820,8 @@ module SArg = struct in bind Alias newvar arg (body newarg) let make_const i = Lconst (Const_base (Const_int i)) - let make_isout h arg = Lprim (Pisout, [h; arg], Location.none, false) - let make_isin h arg = Lprim (Pnot, [make_isout h arg], Location.none, false) + let make_isout h arg = Lprim (Pisout, [h; arg], Location.none) + let make_isin h arg = Lprim (Pnot, [make_isout h arg], Location.none) let make_if cond ifso ifnot = Lifthenelse (cond, ifso, ifnot) let make_switch loc arg cases acts ~offset sw_names = let l = ref [] in @@ -2228,9 +2216,7 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def (fun (path, act) rem -> let ext = transl_extension_path ex_pat.pat_env path in Lifthenelse - ( Lprim (Pextension_slot_eq, [Lvar tag; ext], loc, false), - act, - rem )) + (Lprim (Pextension_slot_eq, [Lvar tag; ext], loc), act, rem)) extension_cases default in Llet (Alias, Pgenval, tag, arg, tests) @@ -2260,13 +2246,9 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def case *) let arg = if Datarepr.constructor_has_optional_shape cstr then - Lprim (Pis_not_none, [arg], loc, false) + Lprim (Pis_not_none, [arg], loc) else - Lprim - ( Pjscomp Cneq, - [arg; Lconst (Const_base (Const_int 0))], - loc, - false ) + Lprim (Pjscomp Cneq, [arg; Lconst (Const_base (Const_int 0))], loc) in Lifthenelse (arg, act2, act1) | 2, 0, [(i1, act1); (_, act2)], [] @@ -2290,7 +2272,7 @@ let combine_constructor sw_names loc arg ex_pat cstr partial ctx def match act0 with | Some act when false (* relies on tag being an int *) -> Lifthenelse - ( Lprim (Pisint, [arg], loc, false), + ( Lprim (Pisint, [arg], loc), call_switcher loc fail_opt arg 0 (n - 1) consts sw_names, act ) (* Emit a switch, as bytecode implements this sophisticated instruction *) @@ -2329,7 +2311,7 @@ let call_switcher_variant_constr loc fail arg int_lambda_list names = ( Alias, Pgenval, v, - Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc, false), + Lprim (Pfield (0, Fld_poly_var_tag), [arg], loc), call_switcher loc fail (Lvar v) min_int max_int (List.map (fun (a, (_, c)) -> (a, c)) int_lambda_list) names ) @@ -2375,7 +2357,7 @@ let combine_variant names loc row arg partial ctx def row.row_fields else num_constr := max_int; let test_int_or_block arg if_int if_block = - Lifthenelse (Lprim (Pis_poly_var_block, [arg], loc, false), if_block, if_int) + Lifthenelse (Lprim (Pis_poly_var_block, [arg], loc), if_block, if_int) in let sig_complete = List.length tag_lambda_list = !num_constr and one_action = same_actions tag_lambda_list in @@ -2425,7 +2407,7 @@ let combine_array names loc arg partial ctx def (len_lambda_list, total1, _pats) let switch = call_switcher loc fail (Lvar newvar) 0 max_int len_lambda_list names in - bind Alias newvar (Lprim (Parraylength, [arg], loc, false)) switch + bind Alias newvar (Lprim (Parraylength, [arg], loc)) switch in (lambda1, jumps_union local_jumps total1) @@ -2506,7 +2488,7 @@ let compile_test compile_fun partial divide combine ctx to_match = let rec approx_present v = function | Lconst _ -> false | Lstaticraise (_, args) -> List.exists (fun lam -> approx_present v lam) args - | Lprim (_, args, _, _) -> List.exists (fun lam -> approx_present v lam) args + | Lprim (_, args, _) -> List.exists (fun lam -> approx_present v lam) args | Llet (Alias, _k, _, l1, l2) -> approx_present v l1 || approx_present v l2 | Lvar vv -> Ident.same v vv | _ -> true @@ -2853,11 +2835,9 @@ let partial_function loc () = Const_base (Const_int char); ] )); ], - loc, - false ); + loc ); ], - loc, - false ) + loc ) let for_function loc repr param pat_act_list partial = compile_matching repr (partial_function loc) param pat_act_list partial @@ -2865,7 +2845,7 @@ let for_function loc repr param pat_act_list partial = (* In the following two cases, exhaustiveness info is not available! *) let for_trywith param pat_act_list = compile_matching None - (fun () -> Lprim (Praise Raise_reraise, [param], Location.none, false)) + (fun () -> Lprim (Praise Raise_reraise, [param], Location.none)) param pat_act_list Partial let simple_for_let loc param pat body = @@ -3032,14 +3012,14 @@ let do_for_multiple_match loc paraml pat_act_list partial = ( raise_num, { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc, false), Strict)]; + args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc), Strict)]; default = [([[omega]], raise_num)]; } ) | _ -> ( -1, { cases = List.map (fun (pat, act) -> ([pat], act)) pat_act_list; - args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc, false), Strict)]; + args = [(Lprim (Pmakeblock Blk_tuple, paraml, loc), Strict)]; default = []; } ) in diff --git a/compiler/ml/primitive.ml b/compiler/ml/primitive.ml index 602cb22089..3ddc60a488 100644 --- a/compiler/ml/primitive.ml +++ b/compiler/ml/primitive.ml @@ -25,8 +25,11 @@ type description = { prim_native_name: string; (* Name of C function for the nat. code gen. *) prim_from_constructor: bool; (* Is it from a type constructor instead of a concrete function type? *) + transformed_jsx: bool; } +let set_transformed_jsx d ~transformed_jsx = {d with transformed_jsx} + let coerce : (description -> description -> bool) ref = ref (fun (p1 : description) (p2 : description) -> p1 = p2) @@ -43,6 +46,7 @@ let parse_declaration valdecl ~arity ~from_constructor = prim_alloc = true; prim_native_name = native_name; prim_from_constructor = from_constructor; + transformed_jsx = false; } open Outcometree diff --git a/compiler/ml/primitive.mli b/compiler/ml/primitive.mli index 9166ae1a5c..8f5c58100d 100644 --- a/compiler/ml/primitive.mli +++ b/compiler/ml/primitive.mli @@ -22,8 +22,11 @@ type description = private { prim_native_name: string; (* Name of C function for the nat. code gen. *) prim_from_constructor: bool; (* Is it from a type constructor instead of a concrete function type? *) + transformed_jsx: bool; } +val set_transformed_jsx : description -> transformed_jsx:bool -> description + (* Invariant [List.length d.prim_native_repr_args = d.prim_arity] *) val parse_declaration : diff --git a/compiler/ml/printlambda.ml b/compiler/ml/printlambda.ml index e069e7173b..f0ad4698bb 100644 --- a/compiler/ml/printlambda.ml +++ b/compiler/ml/printlambda.ml @@ -319,7 +319,7 @@ let rec lam ppf = function in fprintf ppf "@[<2>(letrec@ (@[%a@])@ %a)@]" bindings id_arg_list lam body - | Lprim (prim, largs, _, _) -> + | Lprim (prim, largs, _) -> let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(%a%a)@]" primitive prim lams largs | Lswitch (larg, sw, _loc) -> diff --git a/compiler/ml/transl_recmodule.ml b/compiler/ml/transl_recmodule.ml index 8a6acad180..17aa511aa2 100644 --- a/compiler/ml/transl_recmodule.ml +++ b/compiler/ml/transl_recmodule.ml @@ -151,7 +151,7 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = ( Strict, Pgenval, id, - Lprim (Pinit_mod, [loc; shape], Location.none, false), + Lprim (Pinit_mod, [loc; shape], Location.none), bind_inits rem acc ) in let rec bind_strict args acc = @@ -167,7 +167,7 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = | (_id, None, _rhs) :: rem -> patch_forwards rem | (id, Some (_loc, shape), rhs) :: rem -> Lsequence - ( Lprim (Pupdate_mod, [shape; Lvar id; rhs], Location.none, false), + ( Lprim (Pupdate_mod, [shape; Lvar id; rhs], Location.none), patch_forwards rem ) in bind_inits bindings (bind_strict bindings (patch_forwards bindings)) @@ -178,7 +178,7 @@ let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t = *) let rec is_function_or_const_block (lam : Lambda.lambda) acc = match lam with - | Lprim (Pmakeblock _, args, _, _) -> + | Lprim (Pmakeblock _, args, _) -> Ext_list.for_all args (fun x -> match x with | Lvar id -> Set_ident.mem acc id diff --git a/compiler/ml/translattribute.ml b/compiler/ml/translattribute.ml index 800d630d0c..ed63ecbdf1 100644 --- a/compiler/ml/translattribute.ml +++ b/compiler/ml/translattribute.ml @@ -76,8 +76,8 @@ let rec add_inline_attribute (expr : Lambda.lambda) loc attributes = Location.prerr_warning loc (Warnings.Duplicated_attribute "inline")); let attr = {attr with inline} in Lfunction {funct with attr} - | Lprim (((Pjs_fn_make _ | Pjs_fn_make_unit) as p), [e], l, tj), _ -> - Lambda.Lprim (p, [add_inline_attribute e loc attributes], l, tj) + | Lprim (((Pjs_fn_make _ | Pjs_fn_make_unit) as p), [e], l), _ -> + Lambda.Lprim (p, [add_inline_attribute e loc attributes], l) | expr, Always_inline -> Location.prerr_warning loc (Warnings.Misplaced_attribute "inline1"); expr diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml index 7c9a50731e..6340b8ca9d 100644 --- a/compiler/ml/translcore.ml +++ b/compiler/ml/translcore.ml @@ -44,7 +44,7 @@ let transl_extension_constructor env path ext = in let loc = ext.ext_loc in match ext.ext_kind with - | Text_decl _ -> Lprim (Pcreate_extension name, [], loc, false) + | Text_decl _ -> Lprim (Pcreate_extension name, [], loc) | Text_rebind (path, _lid) -> transl_extension_path ~loc env path (* Translation of primitives *) @@ -460,7 +460,7 @@ let transl_primitive loc p env ty = params = [param]; attr = default_function_attribute; loc; - body = Lprim (Pmakeblock Blk_tuple, [lam; Lvar param], loc, false); + body = Lprim (Pmakeblock Blk_tuple, [lam; Lvar param], loc); } | _ -> assert false) | _ -> @@ -471,8 +471,7 @@ let transl_primitive loc p env ty = :: make_params (n - 1) total in let prim_arity = p.prim_arity in - if p.prim_from_constructor || prim_arity = 0 then - Lprim (prim, [], loc, false) + if p.prim_from_constructor || prim_arity = 0 then Lprim (prim, [], loc) else let params = if prim_arity = 1 then [Ident.create "prim"] @@ -483,7 +482,7 @@ let transl_primitive loc p env ty = params; attr = default_function_attribute; loc; - body = Lprim (prim, List.map (fun id -> Lvar id) params, loc, false); + body = Lprim (prim, List.map (fun id -> Lvar id) params, loc); } let transl_primitive_application loc prim env ty args = @@ -630,11 +629,9 @@ let assert_failed exp = Const_base (Const_int char); ] )); ], - exp.exp_loc, - false ); + exp.exp_loc ); ], - exp.exp_loc, - false ) + exp.exp_loc ) let rec cut n l = if n = 0 then ([], l) @@ -703,8 +700,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = Lprim ( prim (* could be replaced with Opaque in the future except arity 0*), [lambda], - loc, - false ) + loc ) | None -> lambda) | Texp_apply { @@ -746,15 +742,19 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Raise_regular, Lvar id when Hashtbl.mem try_ids id -> Raise_reraise | _ -> k in - wrap (Lprim (Praise k, [targ], e.exp_loc, transformed_jsx)) + wrap (Lprim (Praise k, [targ], e.exp_loc)) | Ploc kind, [] -> lam_of_loc kind e.exp_loc | Ploc kind, [arg1] -> let lam = lam_of_loc kind arg1.exp_loc in - Lprim (Pmakeblock Blk_tuple, lam :: argl, e.exp_loc, transformed_jsx) + Lprim (Pmakeblock Blk_tuple, lam :: argl, e.exp_loc) | Ploc _, _ -> assert false | _, _ -> ( match (prim, argl) with - | _ -> wrap (Lprim (prim, argl, e.exp_loc, transformed_jsx)))) + | Pccall d, _ -> + wrap + (Lprim + (Pccall (set_transformed_jsx d ~transformed_jsx), argl, e.exp_loc)) + | _ -> wrap (Lprim (prim, argl, e.exp_loc)))) | Texp_apply {funct; args = oargs; partial; transformed_jsx} -> let inlined, funct = Translattribute.get_and_remove_inlined_attribute funct @@ -784,7 +784,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Texp_tuple el -> ( let ll = transl_list el in try Lconst (Const_block (Blk_tuple, List.map extract_constant ll)) - with Not_constant -> Lprim (Pmakeblock Blk_tuple, ll, e.exp_loc, false)) + with Not_constant -> Lprim (Pmakeblock Blk_tuple, ll, e.exp_loc)) | Texp_construct ({txt = Lident "false"}, _, []) -> Lconst Const_false | Texp_construct ({txt = Lident "true"}, _, []) -> Lconst Const_true | Texp_construct (lid, cstr, args) -> ( @@ -839,13 +839,12 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = } in try Lconst (Const_block (tag_info, List.map extract_constant ll)) - with Not_constant -> Lprim (Pmakeblock tag_info, ll, e.exp_loc, false)) + with Not_constant -> Lprim (Pmakeblock tag_info, ll, e.exp_loc)) | Cstr_extension path -> Lprim ( Pmakeblock Blk_extension, transl_extension_path e.exp_env path :: ll, - e.exp_loc, - false )) + e.exp_loc )) | Texp_extension_constructor (_, path) -> transl_extension_path e.exp_env path | Texp_variant (l, arg) -> ( let tag = Btype.hash_variant l in @@ -862,8 +861,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = Lprim ( Pmakeblock tag_info, [Lconst (Const_base (Const_int tag)); lam], - e.exp_loc, - false ))) + e.exp_loc ))) | Texp_record {fields; representation; extended_expression} -> transl_record e.exp_loc e.exp_env fields representation extended_expression | Texp_field (arg, _, lbl) -> ( @@ -871,21 +869,16 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = match lbl.lbl_repres with | Record_float_unused -> assert false | Record_regular -> - Lprim - (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [targ], e.exp_loc, false) + Lprim (Pfield (lbl.lbl_pos, Lambda.fld_record lbl), [targ], e.exp_loc) | Record_inlined _ -> Lprim - ( Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), - [targ], - e.exp_loc, - false ) + (Pfield (lbl.lbl_pos, Lambda.fld_record_inline lbl), [targ], e.exp_loc) | Record_unboxed _ -> targ | Record_extension -> Lprim ( Pfield (lbl.lbl_pos + 1, Lambda.fld_record_extension lbl), [targ], - e.exp_loc, - false )) + e.exp_loc )) | Texp_setfield (arg, _, lbl, newval) -> let access = match lbl.lbl_repres with @@ -897,10 +890,10 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = | Record_extension -> Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) in - Lprim (access, [transl_exp arg; transl_exp newval], e.exp_loc, false) + Lprim (access, [transl_exp arg; transl_exp newval], e.exp_loc) | Texp_array expr_list -> let ll = transl_list expr_list in - Lprim (Pmakearray Mutable, ll, e.exp_loc, false) + Lprim (Pmakearray Mutable, ll, e.exp_loc) | Texp_ifthenelse (cond, ifso, Some ifnot) -> Lifthenelse (transl_exp cond, transl_exp ifso, transl_exp ifnot) | Texp_ifthenelse (cond, ifso, None) -> @@ -934,7 +927,7 @@ and transl_exp0 (e : Typedtree.expression) : Lambda.lambda = (* when e needs no computation (constants, identifiers, ...), we optimize the translation just as Lazy.lazy_from_val would do *) - Lprim (Pmakeblock Blk_lazy_general, [transl_exp e], e.exp_loc, false) + Lprim (Pmakeblock Blk_lazy_general, [transl_exp e], e.exp_loc) and transl_list expr_list = List.map transl_exp expr_list @@ -1124,8 +1117,7 @@ and transl_record loc env fields repres opt_init_expr = ( Pjs_fn_make arity, (* could be replaced with Opaque in the future except arity 0*) [lambda], - loc, - false ) + loc ) else lambda | _ -> ( let size = Array.length fields in @@ -1162,7 +1154,7 @@ and transl_record loc env fields repres opt_init_expr = | Record_extension -> Pfield (i + 1, Lambda.fld_record_extension lbl) in - Lprim (access, [Lvar init_id], loc, false) + Lprim (access, [Lvar init_id], loc) | Overridden (_lid, expr) -> transl_exp expr) fields in @@ -1195,7 +1187,7 @@ and transl_record loc env fields repres opt_init_expr = with Not_constant -> ( match repres with | Record_regular -> - Lprim (Pmakeblock (Lambda.blk_record fields mut), ll, loc, false) + Lprim (Pmakeblock (Lambda.blk_record fields mut), ll, loc) | Record_float_unused -> assert false | Record_inlined {tag; name; num_nonconsts; attrs} -> Lprim @@ -1203,8 +1195,7 @@ and transl_record loc env fields repres opt_init_expr = (Lambda.blk_record_inlined fields name num_nonconsts ~tag ~attrs mut), ll, - loc, - false ) + loc ) | Record_unboxed _ -> ( match ll with | [v] -> v @@ -1218,10 +1209,7 @@ and transl_record loc env fields repres opt_init_expr = in let slot = transl_extension_path env path in Lprim - ( Pmakeblock (Lambda.blk_record_ext fields mut), - slot :: ll, - loc, - false )) + (Pmakeblock (Lambda.blk_record_ext fields mut), slot :: ll, loc)) in match opt_init_expr with | None -> lam @@ -1246,8 +1234,7 @@ and transl_record loc env fields repres opt_init_expr = | Record_extension -> Psetfield (lbl.lbl_pos + 1, Lambda.fld_record_extension_set lbl) in - Lsequence - (Lprim (upd, [Lvar copy_id; transl_exp expr], loc, false), cont) + Lsequence (Lprim (upd, [Lvar copy_id; transl_exp expr], loc), cont) in match opt_init_expr with | None -> assert false @@ -1256,7 +1243,7 @@ and transl_record loc env fields repres opt_init_expr = ( Strict, Pgenval, copy_id, - Lprim (Pduprecord, [transl_exp init_expr], loc, false), + Lprim (Pduprecord, [transl_exp init_expr], loc), Array.fold_left update_field (Lvar copy_id) fields )) and transl_match e arg pat_expr_list exn_pat_expr_list partial = diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml index 0b06c7b890..87471ac26b 100644 --- a/compiler/ml/translmod.ml +++ b/compiler/ml/translmod.ml @@ -64,17 +64,15 @@ let rec apply_coercion loc strict (restr : Typedtree.module_coercion) arg = | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> Lambda.name_lambda strict arg (fun id -> let get_field_name name pos = - Lambda.Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc, false) + Lambda.Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc) in let lam = Lambda.Lprim ( Pmakeblock (Blk_module runtime_fields), Ext_list.map2 pos_cc_list runtime_fields (fun (pos, cc) name -> apply_coercion loc Alias cc - (Lprim - (Pfield (pos, Fld_module {name}), [Lvar id], loc, false))), - loc, - false ) + (Lprim (Pfield (pos, Fld_module {name}), [Lvar id], loc))), + loc ) in wrap_id_pos_list loc id_pos_list get_field_name lam) | Tcoerce_functor (cc_arg, cc_res) -> @@ -308,8 +306,7 @@ and transl_structure loc fields cc rootpath final_env = function (if is_top_root_path then Blk_module_export !export_identifiers else Blk_module (List.rev_map (fun id -> id.Ident.name) fields)), block_fields, - loc, - false ), + loc ), List.length fields ) | Tcoerce_structure (pos_cc_list, id_pos_list, runtime_fields) -> (* Do not ignore id_pos_list ! *) @@ -345,8 +342,7 @@ and transl_structure loc fields cc rootpath final_env = function (if is_top_root_path then Blk_module_export !export_identifiers else Blk_module runtime_fields), result, - loc, - false ) + loc ) and id_pos_list = Ext_list.filter id_pos_list (fun (id, _, _) -> not (Lambda.IdentSet.mem id ids)) @@ -438,8 +434,7 @@ and transl_structure loc fields cc rootpath final_env = function Lprim ( Pfield (pos, Fld_module {name = Ident.name id}), [Lvar mid], - incl.incl_loc, - false ), + incl.incl_loc ), body ), size ) in From 1a20f3899b04ab4794e8f1b79841ec8296187b8c Mon Sep 17 00:00:00 2001 From: nojaf Date: Sun, 4 May 2025 12:13:41 +0200 Subject: [PATCH 19/31] Add test for spreading children --- tests/tests/src/nojaf.mjs | 15 +++++++++++++++ tests/tests/src/nojaf.res | 10 ++++++++++ 2 files changed, 25 insertions(+) diff --git a/tests/tests/src/nojaf.mjs b/tests/tests/src/nojaf.mjs index 893d07525f..616f830149 100644 --- a/tests/tests/src/nojaf.mjs +++ b/tests/tests/src/nojaf.mjs @@ -42,6 +42,18 @@ let _container_with_spread_props =
; +let baseChildren = [ + {"Hello, world!"}, + {"Hello, world!"} +]; + +let _container_with_spread_children =
{baseChildren}
; + +let newrecord$2 = {...baseProps}; + +let _container_with_spread_props_and_children =
{baseChildren} +
; + export { React, ReactDOM, @@ -55,5 +67,8 @@ export { baseProps, _unary_element_with_spread_props, _container_with_spread_props, + baseChildren, + _container_with_spread_children, + _container_with_spread_props_and_children, } /* _single_element_child Not a pure module */ diff --git a/tests/tests/src/nojaf.res b/tests/tests/src/nojaf.res index f0df982c09..ee80695818 100644 --- a/tests/tests/src/nojaf.res +++ b/tests/tests/src/nojaf.res @@ -112,3 +112,13 @@ let _container_with_spread_props = {React.string("Hello, world!")} + +let baseChildren = React.array([ + {React.string("Hello, world!")} , + {React.string("Hello, world!")} , +]) + +let _container_with_spread_children =
...baseChildren
+ +let _container_with_spread_props_and_children = +
...baseChildren
From 8929f37627f464d056aaa567baa11bf967aff1b7 Mon Sep 17 00:00:00 2001 From: nojaf Date: Sun, 4 May 2025 17:01:50 +0200 Subject: [PATCH 20/31] Refactor duplicate code --- compiler/core/js_dump.ml | 133 ++++++++------------------------------- 1 file changed, 26 insertions(+), 107 deletions(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 53cb30effc..2382515892 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -562,7 +562,24 @@ and expression_desc cxt ~(level : int) f x : cxt = print_jsx cxt ~level f fnName tag fields (* In the case of prop spreading *) | [tag; ({expression_desc = J.Seq _} as props)] -> - print_jsx_prop_spreading cxt ~level f fnName tag props + let fields, spread_props = + let rec visit acc e = + match e.J.expression_desc with + | J.Seq + ( { + J.expression_desc = + J.Bin + ( Js_op.Eq, + {J.expression_desc = J.Static_index (_, name, _)}, + value ); + }, + rest ) -> + visit ((name, value) :: acc) rest + | _ -> (List.rev acc, e) + in + visit [] props + in + print_jsx cxt ~level ~spread_props f fnName tag fields | _ -> expression_desc cxt ~level f (Call @@ -1002,7 +1019,8 @@ and expression_desc cxt ~(level : int) f x : cxt = P.string f "..."; expression ~level:13 cxt f e) -and print_jsx cxt ~(level : int) f (fnName : string) (tag : J.expression) +and print_jsx cxt ?(spread_props : J.expression option) ~(level : int) f + (fnName : string) (tag : J.expression) (fields : (string * J.expression) list) : cxt = let print_tag () = match tag.expression_desc with @@ -1028,6 +1046,12 @@ and print_jsx cxt ~(level : int) f (fnName : string) (tag : J.expression) in let print_props () = let props = List.filter (fun (n, _) -> n <> "children") fields in + (match spread_props with + | None -> () + | Some spread -> + P.string f " {..."; + let _ = expression ~level:0 cxt f spread in + P.string f "} "); if List.length props > 0 then (List.iter (fun (n, x) -> P.space f; @@ -1073,111 +1097,6 @@ and print_jsx cxt ~(level : int) f (fnName : string) (tag : J.expression) cxt -(* TODO: clean up the code , a lot of code is duplicated *) -and print_jsx_prop_spreading cxt ~level f fnName tag props = - (* The spreading expression is going to look something like: - (newrecord.type = "text", newrecord.tabIndex = 0, newrecord.children = 5, newrecord) - Where there are some assignments to the props object and then the props object is returned. - We want to extract the assignments and turn them into props. - And so capture the object we need to spread. - *) - let fields, spread = - let rec visit acc e = - match e.J.expression_desc with - | J.Seq - ( { - J.expression_desc = - J.Bin - ( Js_op.Eq, - {J.expression_desc = J.Static_index (_, name, _)}, - value ); - }, - rest ) -> - visit ((name, value) :: acc) rest - | _ -> (List.rev acc, e) - in - visit [] props - in - - let print_tag () = - match tag.expression_desc with - | J.Str {txt} -> P.string f txt - (* fragment *) - | J.Var (J.Qualified ({id = {name = "JsxRuntime"}}, Some "Fragment")) -> () - | _ -> - let _ = expression ~level cxt f tag in - () - in - let children_opt = - List.find_map - (fun (n, e) -> - if n = "children" then - if fnName = "jsxs" then - match e.J.expression_desc with - | J.Optional_block ({expression_desc = J.Array (xs, _)}, _) -> - Some xs - | _ -> Some [e] - else Some [e] - else None) - fields - in - let print_props fields = - let props = List.filter (fun (n, _) -> n <> "children") fields in - if List.length props > 0 then - (List.iter (fun (n, x) -> - P.space f; - P.string f n; - P.string f "="; - P.string f "{"; - let _ = expression ~level:0 cxt f x in - P.string f "}")) - props - in - let print_spreaded_props () = - (* Spread the object first, as that is what happens in ReScript *) - P.string f " {..."; - let _ = expression ~level:0 cxt f spread in - P.string f "} "; - (* Then print the rest of the props *) - print_props fields - in - (match children_opt with - | None -> - P.string f "<"; - print_tag (); - print_spreaded_props (); - P.string f "/>" - | Some children -> - let child_is_jsx child = - match child.J.expression_desc with - | J.Call (_, _, {call_transformed_jsx = is_jsx}) -> is_jsx - | _ -> false - in - - P.string f "<"; - print_tag (); - print_spreaded_props (); - P.string f ">"; - - let _ = - children - |> List.fold_left - (fun acc e -> - if not (child_is_jsx e) then P.string f "{"; - let next = expression ~level acc f e in - if not (child_is_jsx e) then P.string f "}"; - (* Can we some indent this? *) - P.newline f; - next) - cxt - in - - P.string f ""); - - cxt - and property_name_and_value_list cxt f (l : J.property_map) = iter_lst cxt f l (fun cxt f (pn, e) -> From cecf67d8094582916f2561ba4bad79e3d7808281 Mon Sep 17 00:00:00 2001 From: nojaf Date: Sun, 4 May 2025 17:08:12 +0200 Subject: [PATCH 21/31] Support keyed and prop spreading --- compiler/core/js_dump.ml | 21 +++++++++++++++++++++ tests/tests/src/nojaf.mjs | 17 ++++++++++++----- tests/tests/src/nojaf.res | 8 ++++++++ 3 files changed, 41 insertions(+), 5 deletions(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 2382515892..d9fa8a06b5 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -580,6 +580,27 @@ and expression_desc cxt ~(level : int) f x : cxt = visit [] props in print_jsx cxt ~level ~spread_props f fnName tag fields + (* In the case of prop spreading and keyed *) + | [tag; ({expression_desc = J.Seq _} as props); key] -> + let fields, spread_props = + let rec visit acc e = + match e.J.expression_desc with + | J.Seq + ( { + J.expression_desc = + J.Bin + ( Js_op.Eq, + {J.expression_desc = J.Static_index (_, name, _)}, + value ); + }, + rest ) -> + visit ((name, value) :: acc) rest + | _ -> (List.rev acc, e) + in + visit [] props + in + let fields = ("key", key) :: fields in + print_jsx cxt ~level ~spread_props f fnName tag fields | _ -> expression_desc cxt ~level f (Call diff --git a/tests/tests/src/nojaf.mjs b/tests/tests/src/nojaf.mjs index 616f830149..6bba235ca6 100644 --- a/tests/tests/src/nojaf.mjs +++ b/tests/tests/src/nojaf.mjs @@ -38,9 +38,7 @@ let _unary_element_with_spread_props = ; let newrecord$1 = {...baseProps}; -let _container_with_spread_props =
{"Hello, world!"} - -
; +let _container_with_spread_props =
{"Hello, world!"}
; let baseChildren = [ {"Hello, world!"}, @@ -51,8 +49,15 @@ let _container_with_spread_children =
{ let newrecord$2 = {...baseProps}; -let _container_with_spread_props_and_children =
{baseChildren} -
; +let _container_with_spread_props_and_children =
{baseChildren}
; + +let newrecord$3 = {...baseProps}; + +let _unary_element_with_spread_props_keyed = ; + +let newrecord$4 = {...baseProps}; + +let _container_with_spread_props_keyed =
{"Hello, world!"}
; export { React, @@ -70,5 +75,7 @@ export { baseChildren, _container_with_spread_children, _container_with_spread_props_and_children, + _unary_element_with_spread_props_keyed, + _container_with_spread_props_keyed, } /* _single_element_child Not a pure module */ diff --git a/tests/tests/src/nojaf.res b/tests/tests/src/nojaf.res index ee80695818..d864548bc1 100644 --- a/tests/tests/src/nojaf.res +++ b/tests/tests/src/nojaf.res @@ -122,3 +122,11 @@ let _container_with_spread_children =
...b let _container_with_spread_props_and_children =
...baseChildren
+ +let _unary_element_with_spread_props_keyed = + +let _container_with_spread_props_keyed = +
+ {React.string("Hello, world!")} + +
From 3fcf1dfeaecb7a1cecfd296b739a238f3efb7079 Mon Sep 17 00:00:00 2001 From: nojaf Date: Sun, 4 May 2025 17:09:10 +0200 Subject: [PATCH 22/31] Rename test file --- tests/tests/src/{nojaf.mjs => preserve_jsx_test.mjs} | 6 +++--- tests/tests/src/{nojaf.res => preserve_jsx_test.res} | 0 2 files changed, 3 insertions(+), 3 deletions(-) rename tests/tests/src/{nojaf.mjs => preserve_jsx_test.mjs} (95%) rename tests/tests/src/{nojaf.res => preserve_jsx_test.res} (100%) diff --git a/tests/tests/src/nojaf.mjs b/tests/tests/src/preserve_jsx_test.mjs similarity index 95% rename from tests/tests/src/nojaf.mjs rename to tests/tests/src/preserve_jsx_test.mjs index 6bba235ca6..59ca21c763 100644 --- a/tests/tests/src/nojaf.mjs +++ b/tests/tests/src/preserve_jsx_test.mjs @@ -7,17 +7,17 @@ let React = {}; let ReactDOM = {}; -function Nojaf$Icon(props) { +function Preserve_jsx_test$Icon(props) { return ; } let Icon = { - make: Nojaf$Icon + make: Preserve_jsx_test$Icon }; let _single_element_child =

{"Hello, world!"}

; -let _multiple_element_children =

{"Hello, world!"}

; +let _multiple_element_children =

{"Hello, world!"}

; let _single_element_fragment = <>{Primitive_option.some()}; diff --git a/tests/tests/src/nojaf.res b/tests/tests/src/preserve_jsx_test.res similarity index 100% rename from tests/tests/src/nojaf.res rename to tests/tests/src/preserve_jsx_test.res From 8b7eb454fce580517c2fa0c0d5b3cc6e0654ed11 Mon Sep 17 00:00:00 2001 From: nojaf Date: Sun, 4 May 2025 18:07:37 +0200 Subject: [PATCH 23/31] Keep key prop before spreading props. Also ensure test can run. --- compiler/core/js_dump.ml | 20 +- package.json | 1 + scripts/test.js | 25 +++ tests/tests/src/preserve_jsx_test.mjs | 102 +++++----- yarn.lock | 262 ++++++++++++++++++++++++++ 5 files changed, 345 insertions(+), 65 deletions(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index d9fa8a06b5..b48d2e9dc0 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -558,8 +558,7 @@ and expression_desc cxt ~(level : int) f x : cxt = | Undefined _ when opt -> None | _ -> Some (f, x)) in - let fields = ("key", key) :: fields in - print_jsx cxt ~level f fnName tag fields + print_jsx cxt ~level ~key f fnName tag fields (* In the case of prop spreading *) | [tag; ({expression_desc = J.Seq _} as props)] -> let fields, spread_props = @@ -599,8 +598,7 @@ and expression_desc cxt ~(level : int) f x : cxt = in visit [] props in - let fields = ("key", key) :: fields in - print_jsx cxt ~level ~spread_props f fnName tag fields + print_jsx cxt ~level ~spread_props ~key f fnName tag fields | _ -> expression_desc cxt ~level f (Call @@ -1040,9 +1038,9 @@ and expression_desc cxt ~(level : int) f x : cxt = P.string f "..."; expression ~level:13 cxt f e) -and print_jsx cxt ?(spread_props : J.expression option) ~(level : int) f - (fnName : string) (tag : J.expression) - (fields : (string * J.expression) list) : cxt = +and print_jsx cxt ?(spread_props : J.expression option) + ?(key : J.expression option) ~(level : int) f (fnName : string) + (tag : J.expression) (fields : (string * J.expression) list) : cxt = let print_tag () = match tag.expression_desc with | J.Str {txt} -> P.string f txt @@ -1066,6 +1064,14 @@ and print_jsx cxt ?(spread_props : J.expression option) ~(level : int) f fields in let print_props () = + (* If a key is present, should be printed before the spread props, + This is to ensure tools like ESBuild use the automatic JSX runtime *) + (match key with + | None -> () + | Some key -> + P.string f " key={"; + let _ = expression ~level:0 cxt f key in + P.string f "} "); let props = List.filter (fun (n, _) -> n <> "children") fields in (match spread_props with | None -> () diff --git a/package.json b/package.json index ba4759e9f3..cec6044956 100644 --- a/package.json +++ b/package.json @@ -85,6 +85,7 @@ "@biomejs/biome": "1.9.4", "@types/node": "^20.14.9", "@types/semver": "^7.5.8", + "esbuild": "0.25.3", "mocha": "10.8.2", "nyc": "15.0.0", "semver": "7.6.2", diff --git a/scripts/test.js b/scripts/test.js index c2edd0c4ae..635f8ab914 100644 --- a/scripts/test.js +++ b/scripts/test.js @@ -3,6 +3,7 @@ import * as fs from "node:fs"; import * as os from "node:os"; import * as path from "node:path"; +import * as esbuild from 'esbuild'; import { buildTestDir, compilerTestDir, @@ -83,6 +84,30 @@ if (mochaTest) { stdio: "inherit", }); + // We need to the jsx because mocha doesn't support jsx + const preserveJsxTestFile = path.join(projectDir, "tests/tests/src/preserve_jsx_test.mjs"); + try { + + await esbuild.build({ + entryPoints: [preserveJsxTestFile], // Specify the single input file + outfile: preserveJsxTestFile, // Specify the single output file + allowOverwrite: true, // We just overwrite the existing file + bundle: false, // Crucial: Turn off bundling + minify: false, // Turn off minification + sourcemap: false, // Turn off source maps if not needed + loader: { '.mjs': 'jsx' }, // Tell esbuild to apply the 'jsx' loader to .mjs files + format: 'esm', // Ensure output is ESM + platform: 'node', // Target Node.js environment + jsx: 'automatic' + }); + + console.log(`Built (transformed) ${preserveJsxTestFile}`); + + } catch (error) { + console.error(`Error building (transforming) ${preserveJsxTestFile}:`, error); + process.exit(1); + } + await mocha(["-t", "10000", "tests/tests/**/*_test.mjs"], { cwd: projectDir, stdio: "inherit", diff --git a/tests/tests/src/preserve_jsx_test.mjs b/tests/tests/src/preserve_jsx_test.mjs index 59ca21c763..7b4043a45c 100644 --- a/tests/tests/src/preserve_jsx_test.mjs +++ b/tests/tests/src/preserve_jsx_test.mjs @@ -1,81 +1,67 @@ -// Generated by ReScript, PLEASE EDIT WITH CARE - +import { Fragment, jsx, jsxs } from "react/jsx-runtime"; import * as Primitive_option from "rescript/lib/es6/Primitive_option.js"; import * as JsxRuntime from "react/jsx-runtime"; - let React = {}; - let ReactDOM = {}; - function Preserve_jsx_test$Icon(props) { - return ; + return /* @__PURE__ */ jsx("strong", {}); } - let Icon = { make: Preserve_jsx_test$Icon }; - -let _single_element_child =

{"Hello, world!"}

; - -let _multiple_element_children =

{"Hello, world!"}

; - -let _single_element_fragment = <>{Primitive_option.some()}; - -let _multiple_element_fragment = <>; - -let _unary_element_with_props = ; - -let _container_element_with_props_and_children =
{"Hello, world!"}
; - +let _single_element_child = /* @__PURE__ */ jsx("div", { children: /* @__PURE__ */ jsx("h1", { children: "Hello, world!" }) }); +let _multiple_element_children = /* @__PURE__ */ jsxs("div", { children: [ + /* @__PURE__ */ jsx("h1", { children: "Hello, world!" }), + /* @__PURE__ */ jsx(Preserve_jsx_test$Icon, {}) +] }); +let _single_element_fragment = /* @__PURE__ */ jsx(Fragment, { children: Primitive_option.some(/* @__PURE__ */ jsx("input", {})) }); +let _multiple_element_fragment = /* @__PURE__ */ jsxs(Fragment, { children: [ + /* @__PURE__ */ jsx("input", { type: "text" }), + /* @__PURE__ */ jsx("input", { type: "number" }) +] }); +let _unary_element_with_props = /* @__PURE__ */ jsx("input", { className: "foo", type: "text" }); +let _container_element_with_props_and_children = /* @__PURE__ */ jsx("div", { className: "foo", title: "foo", children: "Hello, world!" }); let baseProps = { className: "foo", title: "foo" }; - -let newrecord = {...baseProps}; - -let _unary_element_with_spread_props = ; - -let newrecord$1 = {...baseProps}; - -let _container_with_spread_props =
{"Hello, world!"}
; - +let newrecord = { ...baseProps }; +let _unary_element_with_spread_props = /* @__PURE__ */ jsx("input", { ...newrecord, type: "text" }); +let newrecord$1 = { ...baseProps }; +let _container_with_spread_props = /* @__PURE__ */ jsxs("div", { ...newrecord$1, title: "barry", className: "barry", children: [ + "Hello, world!", + /* @__PURE__ */ jsx("input", { type: "text" }) +] }); let baseChildren = [ - {"Hello, world!"}, - {"Hello, world!"} + /* @__PURE__ */ jsx("span", { children: "Hello, world!" }), + /* @__PURE__ */ jsx("span", { children: "Hello, world!" }) ]; - -let _container_with_spread_children =
{baseChildren}
; - -let newrecord$2 = {...baseProps}; - -let _container_with_spread_props_and_children =
{baseChildren}
; - -let newrecord$3 = {...baseProps}; - -let _unary_element_with_spread_props_keyed = ; - -let newrecord$4 = {...baseProps}; - -let _container_with_spread_props_keyed =
{"Hello, world!"}
; - +let _container_with_spread_children = /* @__PURE__ */ jsx("div", { className: "barry", title: "barry", children: baseChildren }); +let newrecord$2 = { ...baseProps }; +let _container_with_spread_props_and_children = /* @__PURE__ */ jsx("div", { ...newrecord$2, title: "barry", className: "barry", children: baseChildren }); +let newrecord$3 = { ...baseProps }; +let _unary_element_with_spread_props_keyed = /* @__PURE__ */ jsx("input", { ...newrecord$3, type: "text" }, "barry-key"); +let newrecord$4 = { ...baseProps }; +let _container_with_spread_props_keyed = /* @__PURE__ */ jsxs("div", { ...newrecord$4, title: "barry", className: "barry", children: [ + "Hello, world!", + /* @__PURE__ */ jsx("input", { type: "text" }) +] }, "barry-key"); export { + Icon, React, ReactDOM, - Icon, - _single_element_child, + _container_element_with_props_and_children, + _container_with_spread_children, + _container_with_spread_props, + _container_with_spread_props_and_children, + _container_with_spread_props_keyed, _multiple_element_children, - _single_element_fragment, _multiple_element_fragment, + _single_element_child, + _single_element_fragment, _unary_element_with_props, - _container_element_with_props_and_children, - baseProps, _unary_element_with_spread_props, - _container_with_spread_props, - baseChildren, - _container_with_spread_children, - _container_with_spread_props_and_children, _unary_element_with_spread_props_keyed, - _container_with_spread_props_keyed, -} -/* _single_element_child Not a pure module */ + baseChildren, + baseProps +}; diff --git a/yarn.lock b/yarn.lock index de112f2ba7..4dbed16337 100644 --- a/yarn.lock +++ b/yarn.lock @@ -274,6 +274,181 @@ __metadata: languageName: node linkType: hard +"@esbuild/aix-ppc64@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/aix-ppc64@npm:0.25.3" + conditions: os=aix & cpu=ppc64 + languageName: node + linkType: hard + +"@esbuild/android-arm64@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/android-arm64@npm:0.25.3" + conditions: os=android & cpu=arm64 + languageName: node + linkType: hard + +"@esbuild/android-arm@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/android-arm@npm:0.25.3" + conditions: os=android & cpu=arm + languageName: node + linkType: hard + +"@esbuild/android-x64@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/android-x64@npm:0.25.3" + conditions: os=android & cpu=x64 + languageName: node + linkType: hard + +"@esbuild/darwin-arm64@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/darwin-arm64@npm:0.25.3" + conditions: os=darwin & cpu=arm64 + languageName: node + linkType: hard + +"@esbuild/darwin-x64@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/darwin-x64@npm:0.25.3" + conditions: os=darwin & cpu=x64 + languageName: node + linkType: hard + +"@esbuild/freebsd-arm64@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/freebsd-arm64@npm:0.25.3" + conditions: os=freebsd & cpu=arm64 + languageName: node + linkType: hard + +"@esbuild/freebsd-x64@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/freebsd-x64@npm:0.25.3" + conditions: os=freebsd & cpu=x64 + languageName: node + linkType: hard + +"@esbuild/linux-arm64@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/linux-arm64@npm:0.25.3" + conditions: os=linux & cpu=arm64 + languageName: node + linkType: hard + +"@esbuild/linux-arm@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/linux-arm@npm:0.25.3" + conditions: os=linux & cpu=arm + languageName: node + linkType: hard + +"@esbuild/linux-ia32@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/linux-ia32@npm:0.25.3" + conditions: os=linux & cpu=ia32 + languageName: node + linkType: hard + +"@esbuild/linux-loong64@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/linux-loong64@npm:0.25.3" + conditions: os=linux & cpu=loong64 + languageName: node + linkType: hard + +"@esbuild/linux-mips64el@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/linux-mips64el@npm:0.25.3" + conditions: os=linux & cpu=mips64el + languageName: node + linkType: hard + +"@esbuild/linux-ppc64@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/linux-ppc64@npm:0.25.3" + conditions: os=linux & cpu=ppc64 + languageName: node + linkType: hard + +"@esbuild/linux-riscv64@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/linux-riscv64@npm:0.25.3" + conditions: os=linux & cpu=riscv64 + languageName: node + linkType: hard + +"@esbuild/linux-s390x@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/linux-s390x@npm:0.25.3" + conditions: os=linux & cpu=s390x + languageName: node + linkType: hard + +"@esbuild/linux-x64@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/linux-x64@npm:0.25.3" + conditions: os=linux & cpu=x64 + languageName: node + linkType: hard + +"@esbuild/netbsd-arm64@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/netbsd-arm64@npm:0.25.3" + conditions: os=netbsd & cpu=arm64 + languageName: node + linkType: hard + +"@esbuild/netbsd-x64@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/netbsd-x64@npm:0.25.3" + conditions: os=netbsd & cpu=x64 + languageName: node + linkType: hard + +"@esbuild/openbsd-arm64@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/openbsd-arm64@npm:0.25.3" + conditions: os=openbsd & cpu=arm64 + languageName: node + linkType: hard + +"@esbuild/openbsd-x64@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/openbsd-x64@npm:0.25.3" + conditions: os=openbsd & cpu=x64 + languageName: node + linkType: hard + +"@esbuild/sunos-x64@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/sunos-x64@npm:0.25.3" + conditions: os=sunos & cpu=x64 + languageName: node + linkType: hard + +"@esbuild/win32-arm64@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/win32-arm64@npm:0.25.3" + conditions: os=win32 & cpu=arm64 + languageName: node + linkType: hard + +"@esbuild/win32-ia32@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/win32-ia32@npm:0.25.3" + conditions: os=win32 & cpu=ia32 + languageName: node + linkType: hard + +"@esbuild/win32-x64@npm:0.25.3": + version: 0.25.3 + resolution: "@esbuild/win32-x64@npm:0.25.3" + conditions: os=win32 & cpu=x64 + languageName: node + linkType: hard + "@isaacs/cliui@npm:^8.0.2": version: 8.0.2 resolution: "@isaacs/cliui@npm:8.0.2" @@ -1207,6 +1382,92 @@ __metadata: languageName: node linkType: hard +"esbuild@npm:0.25.3": + version: 0.25.3 + resolution: "esbuild@npm:0.25.3" + dependencies: + "@esbuild/aix-ppc64": "npm:0.25.3" + "@esbuild/android-arm": "npm:0.25.3" + "@esbuild/android-arm64": "npm:0.25.3" + "@esbuild/android-x64": "npm:0.25.3" + "@esbuild/darwin-arm64": "npm:0.25.3" + "@esbuild/darwin-x64": "npm:0.25.3" + "@esbuild/freebsd-arm64": "npm:0.25.3" + "@esbuild/freebsd-x64": "npm:0.25.3" + "@esbuild/linux-arm": "npm:0.25.3" + "@esbuild/linux-arm64": "npm:0.25.3" + "@esbuild/linux-ia32": "npm:0.25.3" + "@esbuild/linux-loong64": "npm:0.25.3" + "@esbuild/linux-mips64el": "npm:0.25.3" + "@esbuild/linux-ppc64": "npm:0.25.3" + "@esbuild/linux-riscv64": "npm:0.25.3" + "@esbuild/linux-s390x": "npm:0.25.3" + "@esbuild/linux-x64": "npm:0.25.3" + "@esbuild/netbsd-arm64": "npm:0.25.3" + "@esbuild/netbsd-x64": "npm:0.25.3" + "@esbuild/openbsd-arm64": "npm:0.25.3" + "@esbuild/openbsd-x64": "npm:0.25.3" + "@esbuild/sunos-x64": "npm:0.25.3" + "@esbuild/win32-arm64": "npm:0.25.3" + "@esbuild/win32-ia32": "npm:0.25.3" + "@esbuild/win32-x64": "npm:0.25.3" + dependenciesMeta: + "@esbuild/aix-ppc64": + optional: true + "@esbuild/android-arm": + optional: true + "@esbuild/android-arm64": + optional: true + "@esbuild/android-x64": + optional: true + "@esbuild/darwin-arm64": + optional: true + "@esbuild/darwin-x64": + optional: true + "@esbuild/freebsd-arm64": + optional: true + "@esbuild/freebsd-x64": + optional: true + "@esbuild/linux-arm": + optional: true + "@esbuild/linux-arm64": + optional: true + "@esbuild/linux-ia32": + optional: true + "@esbuild/linux-loong64": + optional: true + "@esbuild/linux-mips64el": + optional: true + "@esbuild/linux-ppc64": + optional: true + "@esbuild/linux-riscv64": + optional: true + "@esbuild/linux-s390x": + optional: true + "@esbuild/linux-x64": + optional: true + "@esbuild/netbsd-arm64": + optional: true + "@esbuild/netbsd-x64": + optional: true + "@esbuild/openbsd-arm64": + optional: true + "@esbuild/openbsd-x64": + optional: true + "@esbuild/sunos-x64": + optional: true + "@esbuild/win32-arm64": + optional: true + "@esbuild/win32-ia32": + optional: true + "@esbuild/win32-x64": + optional: true + bin: + esbuild: bin/esbuild + checksum: 10c0/127aff654310ede4e2eb232a7b1d8823f5b5d69222caf17aa7f172574a5b6b75f71ce78c6d8a40030421d7c75b784dc640de0fb1b87b7ea77ab2a1c832fa8df8 + languageName: node + linkType: hard + "escalade@npm:^3.1.1, escalade@npm:^3.2.0": version: 3.2.0 resolution: "escalade@npm:3.2.0" @@ -2482,6 +2743,7 @@ __metadata: "@rescript/win32-x64": "workspace:packages/@rescript/win32-x64" "@types/node": "npm:^20.14.9" "@types/semver": "npm:^7.5.8" + esbuild: "npm:0.25.3" mocha: "npm:10.8.2" nyc: "npm:15.0.0" semver: "npm:7.6.2" From 90b28f0935faeaeb21061e1c88e6d76582325363 Mon Sep 17 00:00:00 2001 From: nojaf Date: Sun, 4 May 2025 22:29:52 +0200 Subject: [PATCH 24/31] Add only spread props case --- compiler/core/js_dump.ml | 133 ++++++++++++++++---------- scripts/test.js | 39 ++++---- tests/tests/src/preserve_jsx_test.mjs | 2 + tests/tests/src/preserve_jsx_test.res | 2 + 4 files changed, 109 insertions(+), 67 deletions(-) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index b48d2e9dc0..7aac2f99c9 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -515,7 +515,7 @@ and expression_desc cxt ~(level : int) f x : cxt = (* TODO: dump for comments *) pp_function ?directive ~is_method ~return_unit ~async ~fn_state:default_fn_exp_state cxt f params body env - (* TODO: + (* TODO: when [e] is [Js_raw_code] with arity print it in a more precise way It seems the optimizer already did work to make sure @@ -524,18 +524,35 @@ and expression_desc cxt ~(level : int) f x : cxt = when Ext_list.length_equal el i ]} *) + (* When -bs-preserve-jsx is enabled, we marked each transformed application node throughout the compilation. + Here we print the transformed application node into a JSX syntax. + The JSX is slightly different from what a user would write, + but it is still valid JSX and is usable by tools like ESBuild. + *) | Call - ( ({expression_desc = J.Var (J.Qualified (_, Some fnName))} as e), + ( ({ + expression_desc = + J.Var + (J.Qualified + ( _, + Some fnName + (* We care about the function name when it is jsxs, + If this is the case, we need to unpack an array later on *) + )); + } as e), el, {call_transformed_jsx = true} ) -> ( + (* We match a JsxRuntime.jsx call *) match el with | [ tag; { expression_desc = + (* This is the props javascript object *) Caml_block (el, _mutable_flag, _, Lambda.Blk_record {fields}); }; ] -> + (* We extract the props from the javascript object *) let fields = Ext_list.array_list_filter_map fields el (fun (f, opt) x -> match x.expression_desc with @@ -543,7 +560,6 @@ and expression_desc cxt ~(level : int) f x : cxt = | _ -> Some (f, x)) in print_jsx cxt ~level f fnName tag fields - (* jsxKeyed call *) | [ tag; { @@ -552,6 +568,7 @@ and expression_desc cxt ~(level : int) f x : cxt = }; key; ] -> + (* When a component has a key the matching runtime function call will have a third argument being the key *) let fields = Ext_list.array_list_filter_map fields el (fun (f, opt) x -> match x.expression_desc with @@ -559,8 +576,14 @@ and expression_desc cxt ~(level : int) f x : cxt = | _ -> Some (f, x)) in print_jsx cxt ~level ~key f fnName tag fields - (* In the case of prop spreading *) | [tag; ({expression_desc = J.Seq _} as props)] -> + (* In the case of prop spreading, the expression will look like: + (props.a = "Hello, world!", props) + which is equivalent to + + + We need to extract the props and the spread object. + *) let fields, spread_props = let rec visit acc e = match e.J.expression_desc with @@ -579,8 +602,8 @@ and expression_desc cxt ~(level : int) f x : cxt = visit [] props in print_jsx cxt ~level ~spread_props f fnName tag fields - (* In the case of prop spreading and keyed *) | [tag; ({expression_desc = J.Seq _} as props); key] -> + (* In the case of props + prop spreading and key argument *) let fields, spread_props = let rec visit acc e = match e.J.expression_desc with @@ -599,7 +622,11 @@ and expression_desc cxt ~(level : int) f x : cxt = visit [] props in print_jsx cxt ~level ~spread_props ~key f fnName tag fields + | [tag; ({expression_desc = J.Var _} as spread_props)] -> + (* All the props are spread *) + print_jsx cxt ~level ~spread_props f fnName tag [] | _ -> + (* This should not happen, we fallback to the general case *) expression_desc cxt ~level f (Call ( e, @@ -1041,14 +1068,16 @@ and expression_desc cxt ~(level : int) f x : cxt = and print_jsx cxt ?(spread_props : J.expression option) ?(key : J.expression option) ~(level : int) f (fnName : string) (tag : J.expression) (fields : (string * J.expression) list) : cxt = - let print_tag () = + let print_tag cxt = match tag.expression_desc with - | J.Str {txt} -> P.string f txt + (* "div" or any other primitive tag *) + | J.Str {txt} -> + P.string f txt; + cxt (* fragment *) - | J.Var (J.Qualified ({id = {name = "JsxRuntime"}}, Some "Fragment")) -> () - | _ -> - let _ = expression ~level cxt f tag in - () + | J.Var (J.Qualified ({id = {name = "JsxRuntime"}}, Some "Fragment")) -> cxt + (* A user defined component or external component *) + | _ -> expression ~level cxt f tag in let children_opt = List.find_map @@ -1063,38 +1092,46 @@ and print_jsx cxt ?(spread_props : J.expression option) else None) fields in - let print_props () = + let print_props cxt = (* If a key is present, should be printed before the spread props, This is to ensure tools like ESBuild use the automatic JSX runtime *) - (match key with - | None -> () - | Some key -> - P.string f " key={"; - let _ = expression ~level:0 cxt f key in - P.string f "} "); + let cxt = + match key with + | None -> cxt + | Some key -> + P.string f " key={"; + let cxt = expression ~level:0 cxt f key in + P.string f "} "; + cxt + in let props = List.filter (fun (n, _) -> n <> "children") fields in - (match spread_props with - | None -> () - | Some spread -> - P.string f " {..."; - let _ = expression ~level:0 cxt f spread in - P.string f "} "); - if List.length props > 0 then - (List.iter (fun (n, x) -> + let cxt = + match spread_props with + | None -> cxt + | Some spread -> + P.string f " {..."; + let cxt = expression ~level:0 cxt f spread in + P.string f "} "; + cxt + in + if List.length props = 0 then cxt + else + (List.fold_left (fun acc (n, x) -> P.space f; P.string f n; P.string f "="; P.string f "{"; - let _ = expression ~level:0 cxt f x in - P.string f "}")) - props + let next = expression ~level:0 acc f x in + P.string f "}"; + next)) + cxt props in - (match children_opt with + match children_opt with | None -> P.string f "<"; - print_tag (); - print_props (); - P.string f "/>" + let cxt = cxt |> print_tag |> print_props in + P.string f "/>"; + cxt | Some children -> let child_is_jsx child = match child.J.expression_desc with @@ -1103,26 +1140,26 @@ and print_jsx cxt ?(spread_props : J.expression option) in P.string f "<"; - print_tag (); - print_props (); + let cxt = cxt |> print_tag |> print_props in + P.string f ">"; + if List.length children > 0 then P.newline f; - let _ = - children - |> List.fold_left - (fun acc e -> - if not (child_is_jsx e) then P.string f "{"; - let next = expression ~level acc f e in - if not (child_is_jsx e) then P.string f "}"; - next) - cxt + let cxt = + List.fold_left + (fun acc e -> + if not (child_is_jsx e) then P.string f "{"; + let next = expression ~level acc f e in + if not (child_is_jsx e) then P.string f "}"; + P.newline f; + next) + cxt children in P.string f ""); - - cxt + let cxt = print_tag cxt in + P.string f ">"; + cxt and property_name_and_value_list cxt f (l : J.property_map) = iter_lst cxt f l diff --git a/scripts/test.js b/scripts/test.js index 635f8ab914..eb12f52b83 100644 --- a/scripts/test.js +++ b/scripts/test.js @@ -3,7 +3,7 @@ import * as fs from "node:fs"; import * as os from "node:os"; import * as path from "node:path"; -import * as esbuild from 'esbuild'; +import * as esbuild from "esbuild"; import { buildTestDir, compilerTestDir, @@ -85,9 +85,11 @@ if (mochaTest) { }); // We need to the jsx because mocha doesn't support jsx - const preserveJsxTestFile = path.join(projectDir, "tests/tests/src/preserve_jsx_test.mjs"); + const preserveJsxTestFile = path.join( + projectDir, + "tests/tests/src/preserve_jsx_test.mjs", + ); try { - await esbuild.build({ entryPoints: [preserveJsxTestFile], // Specify the single input file outfile: preserveJsxTestFile, // Specify the single output file @@ -95,16 +97,18 @@ if (mochaTest) { bundle: false, // Crucial: Turn off bundling minify: false, // Turn off minification sourcemap: false, // Turn off source maps if not needed - loader: { '.mjs': 'jsx' }, // Tell esbuild to apply the 'jsx' loader to .mjs files - format: 'esm', // Ensure output is ESM - platform: 'node', // Target Node.js environment - jsx: 'automatic' + loader: { ".mjs": "jsx" }, // Tell esbuild to apply the 'jsx' loader to .mjs files + format: "esm", // Ensure output is ESM + platform: "node", // Target Node.js environment + jsx: "automatic", }); - + console.log(`Built (transformed) ${preserveJsxTestFile}`); - } catch (error) { - console.error(`Error building (transforming) ${preserveJsxTestFile}:`, error); + console.error( + `Error building (transforming) ${preserveJsxTestFile}:`, + error, + ); process.exit(1); } @@ -174,8 +178,8 @@ if (runtimeDocstrings) { await execClean([], { cwd: docstringTestDir, - stdio: "inherit" - }) + stdio: "inherit", + }); await execBuild([], { cwd: docstringTestDir, @@ -202,12 +206,9 @@ if (runtimeDocstrings) { }); console.log("Run mocha test"); - await mocha( - [path.join(docstringTestDir, "generated_mocha_test.res.js")], - { - cwd: projectDir, - stdio: "inherit", - }, - ); + await mocha([path.join(docstringTestDir, "generated_mocha_test.res.js")], { + cwd: projectDir, + stdio: "inherit", + }); } } diff --git a/tests/tests/src/preserve_jsx_test.mjs b/tests/tests/src/preserve_jsx_test.mjs index 7b4043a45c..b90f732eb0 100644 --- a/tests/tests/src/preserve_jsx_test.mjs +++ b/tests/tests/src/preserve_jsx_test.mjs @@ -46,6 +46,7 @@ let _container_with_spread_props_keyed = /* @__PURE__ */ jsxs("div", { ...newrec "Hello, world!", /* @__PURE__ */ jsx("input", { type: "text" }) ] }, "barry-key"); +let _unary_element_with_only_spread_props = /* @__PURE__ */ jsx("input", { ...baseProps }); export { Icon, React, @@ -59,6 +60,7 @@ export { _multiple_element_fragment, _single_element_child, _single_element_fragment, + _unary_element_with_only_spread_props, _unary_element_with_props, _unary_element_with_spread_props, _unary_element_with_spread_props_keyed, diff --git a/tests/tests/src/preserve_jsx_test.res b/tests/tests/src/preserve_jsx_test.res index d864548bc1..044c2bd66e 100644 --- a/tests/tests/src/preserve_jsx_test.res +++ b/tests/tests/src/preserve_jsx_test.res @@ -130,3 +130,5 @@ let _container_with_spread_props_keyed = {React.string("Hello, world!")}
+ +let _unary_element_with_only_spread_props = From faa5618b1817929bb2afdc7d551f6f26c21a0bb8 Mon Sep 17 00:00:00 2001 From: nojaf Date: Mon, 5 May 2025 09:41:11 +0200 Subject: [PATCH 25/31] Give record a name --- analysis/src/CompletionFrontEnd.ml | 20 +++++++++----------- 1 file changed, 9 insertions(+), 11 deletions(-) diff --git a/analysis/src/CompletionFrontEnd.ml b/analysis/src/CompletionFrontEnd.ml index b1717ae893..0970e5418b 100644 --- a/analysis/src/CompletionFrontEnd.ml +++ b/analysis/src/CompletionFrontEnd.ml @@ -279,25 +279,23 @@ let rec exprToContextPathInner ~(inJsxContext : bool) (e : Parsetree.expression) pexp_attributes; } | Pexp_apply - { - funct = {pexp_desc = Pexp_ident {txt = Lident "->"}}; - args = - [ - (_, lhs); (_, {pexp_desc = Pexp_ident id; pexp_loc; pexp_attributes}); - ]; - partial; - transformed_jsx; - } -> + ({ + funct = {pexp_desc = Pexp_ident {txt = Lident "->"}}; + args = + [ + (_, lhs); + (_, {pexp_desc = Pexp_ident id; pexp_loc; pexp_attributes}); + ]; + } as app) -> (* Transform away pipe with identifier *) exprToContextPath ~inJsxContext { pexp_desc = Pexp_apply { + app with funct = {pexp_desc = Pexp_ident id; pexp_loc; pexp_attributes}; args = [(Nolabel, lhs)]; - partial; - transformed_jsx; }; pexp_loc; pexp_attributes; From 400b550863130e0bc52119dc29e3a2ff92f1c7bb Mon Sep 17 00:00:00 2001 From: nojaf Date: Mon, 5 May 2025 09:44:25 +0200 Subject: [PATCH 26/31] Use config flag in Js_dump instead --- compiler/bsc/rescript_compiler_main.ml | 4 +--- compiler/core/js_dump.ml | 3 ++- compiler/frontend/ppx_entry.ml | 6 ++---- compiler/syntax/cli/res_cli.ml | 14 +++++--------- compiler/syntax/src/jsx_common.ml | 1 - compiler/syntax/src/jsx_ppx.ml | 10 ++++------ compiler/syntax/src/jsx_ppx.mli | 2 -- compiler/syntax/src/jsx_v4.ml | 2 +- 8 files changed, 15 insertions(+), 27 deletions(-) diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index 485ce59351..f9113c40b6 100644 --- a/compiler/bsc/rescript_compiler_main.ml +++ b/compiler/bsc/rescript_compiler_main.ml @@ -255,9 +255,7 @@ let buckle_script_flags : (string * Bsc_args.spec * string) array = ( "-bs-jsx-mode", string_call ignore, "*internal* Set jsx mode, this is no longer used and is a no-op." ); - ( "-bs-jsx-preserve", - unit_call (fun _ -> Js_config.jsx_preserve := true), - "*internal* Preserve jsx" ); + ("-bs-jsx-preserve", set Js_config.jsx_preserve, "*internal* Preserve jsx"); ( "-bs-package-output", string_call Js_packages_state.update_npm_package_path, "*internal* Set npm-output-path: [opt_module]:path, for example: \ diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 7aac2f99c9..0b70f9204c 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -541,7 +541,8 @@ and expression_desc cxt ~(level : int) f x : cxt = )); } as e), el, - {call_transformed_jsx = true} ) -> ( + {call_transformed_jsx = true} ) + when !Js_config.jsx_preserve -> ( (* We match a JsxRuntime.jsx call *) match el with | [ diff --git a/compiler/frontend/ppx_entry.ml b/compiler/frontend/ppx_entry.ml index 4f6624efca..e86949064f 100644 --- a/compiler/frontend/ppx_entry.ml +++ b/compiler/frontend/ppx_entry.ml @@ -34,8 +34,7 @@ let rewrite_signature (ast : Parsetree.signature) : Parsetree.signature = let open Js_config in let jsx_version = int_of_jsx_version jsx_version_ in let jsx_module = string_of_jsx_module !jsx_module in - let jsx_preserve = !jsx_preserve in - Jsx_ppx.rewrite_signature ~jsx_version ~jsx_module ~jsx_preserve ast + Jsx_ppx.rewrite_signature ~jsx_version ~jsx_module ast in if !Js_config.no_builtin_ppx then ast else @@ -54,8 +53,7 @@ let rewrite_implementation (ast : Parsetree.structure) : Parsetree.structure = let open Js_config in let jsx_version = int_of_jsx_version jsx_version_ in let jsx_module = string_of_jsx_module !jsx_module in - let jsx_preserve = !jsx_preserve in - Jsx_ppx.rewrite_implementation ~jsx_version ~jsx_module ~jsx_preserve ast + Jsx_ppx.rewrite_implementation ~jsx_version ~jsx_module ast in if !Js_config.no_builtin_ppx then ast else diff --git a/compiler/syntax/cli/res_cli.ml b/compiler/syntax/cli/res_cli.ml index c52bce4770..572ddd95f3 100644 --- a/compiler/syntax/cli/res_cli.ml +++ b/compiler/syntax/cli/res_cli.ml @@ -163,7 +163,6 @@ module ResClflags : sig val interface : bool ref val jsx_version : int ref val jsx_module : string ref - val jsx_preserve : bool ref val typechecker : bool ref val test_ast_conversion : bool ref @@ -176,7 +175,6 @@ end = struct let interface = ref false let jsx_version = ref (-1) let jsx_module = ref "react" - let jsx_preserve = ref false let file = ref "" let typechecker = ref false let test_ast_conversion = ref false @@ -227,7 +225,7 @@ module CliArgProcessor = struct [@@unboxed] let process_file ~is_interface ~width ~recover ~target ~jsx_version - ~jsx_module ~jsx_preserve ~typechecker ~test_ast_conversion filename = + ~jsx_module ~typechecker ~test_ast_conversion filename = let len = String.length filename in let process_interface = is_interface @@ -279,8 +277,7 @@ module CliArgProcessor = struct Ast_mapper_from0.default_mapper tree0 in let parsetree = - Jsx_ppx.rewrite_signature ~jsx_version ~jsx_module ~jsx_preserve - parsetree + Jsx_ppx.rewrite_signature ~jsx_version ~jsx_module parsetree in print_engine.print_interface ~width ~filename ~comments:parse_result.comments parsetree @@ -305,8 +302,7 @@ module CliArgProcessor = struct Ast_mapper_from0.default_mapper tree0 in let parsetree = - Jsx_ppx.rewrite_implementation ~jsx_version ~jsx_module ~jsx_preserve - parsetree + Jsx_ppx.rewrite_implementation ~jsx_version ~jsx_module parsetree in print_engine.print_implementation ~width ~filename ~comments:parse_result.comments parsetree @@ -319,7 +315,7 @@ let () = CliArgProcessor.process_file ~is_interface:!ResClflags.interface ~width:!ResClflags.width ~recover:!ResClflags.recover ~target:!ResClflags.print ~jsx_version:!ResClflags.jsx_version - ~jsx_module:!ResClflags.jsx_module ~jsx_preserve:!ResClflags.jsx_preserve - ~typechecker:!ResClflags.typechecker !ResClflags.file + ~jsx_module:!ResClflags.jsx_module ~typechecker:!ResClflags.typechecker + !ResClflags.file ~test_ast_conversion:!ResClflags.test_ast_conversion) [@@raises exit] diff --git a/compiler/syntax/src/jsx_common.ml b/compiler/syntax/src/jsx_common.ml index 427ad17818..6937bd14d0 100644 --- a/compiler/syntax/src/jsx_common.ml +++ b/compiler/syntax/src/jsx_common.ml @@ -6,7 +6,6 @@ type jsx_config = { mutable module_: string; mutable nested_modules: string list; mutable has_component: bool; - mutable preserve: bool; } (* Helper method to look up the [@react.component] attribute *) diff --git a/compiler/syntax/src/jsx_ppx.ml b/compiler/syntax/src/jsx_ppx.ml index d42a0be729..8bd2ffd7a0 100644 --- a/compiler/syntax/src/jsx_ppx.ml +++ b/compiler/syntax/src/jsx_ppx.ml @@ -135,29 +135,27 @@ let get_mapper ~config = {default_mapper with expr; module_binding; signature; structure} -let rewrite_implementation ~jsx_version ~jsx_module ~jsx_preserve - (code : Parsetree.structure) : Parsetree.structure = +let rewrite_implementation ~jsx_version ~jsx_module (code : Parsetree.structure) + : Parsetree.structure = let config = { Jsx_common.version = jsx_version; module_ = jsx_module; nested_modules = []; has_component = false; - preserve = jsx_preserve; } in let mapper = get_mapper ~config in mapper.structure mapper code -let rewrite_signature ~jsx_version ~jsx_module ~jsx_preserve - (code : Parsetree.signature) : Parsetree.signature = +let rewrite_signature ~jsx_version ~jsx_module (code : Parsetree.signature) : + Parsetree.signature = let config = { Jsx_common.version = jsx_version; module_ = jsx_module; nested_modules = []; has_component = false; - preserve = jsx_preserve; } in let mapper = get_mapper ~config in diff --git a/compiler/syntax/src/jsx_ppx.mli b/compiler/syntax/src/jsx_ppx.mli index 7ed522defe..de5bd83f8f 100644 --- a/compiler/syntax/src/jsx_ppx.mli +++ b/compiler/syntax/src/jsx_ppx.mli @@ -11,13 +11,11 @@ val rewrite_implementation : jsx_version:int -> jsx_module:string -> - jsx_preserve:bool -> Parsetree.structure -> Parsetree.structure val rewrite_signature : jsx_version:int -> jsx_module:string -> - jsx_preserve:bool -> Parsetree.signature -> Parsetree.signature diff --git a/compiler/syntax/src/jsx_v4.ml b/compiler/syntax/src/jsx_v4.ml index da69cef6a1..89bb301f2d 100644 --- a/compiler/syntax/src/jsx_v4.ml +++ b/compiler/syntax/src/jsx_v4.ml @@ -1277,7 +1277,7 @@ let mk_react_jsx (config : Jsx_common.jsx_config) mapper loc attrs [key_prop; (nolabel, unit_expr ~loc:Location.none)] ) in let args = [(nolabel, elementTag); (nolabel, props_record)] @ key_and_unit in - Exp.apply ~loc ~attrs ~transformed_jsx:config.preserve jsx_expr args + Exp.apply ~loc ~attrs ~transformed_jsx:true jsx_expr args (* In most situations, the component name is the make function from a module. However, if the name contains a lowercase letter, it means it probably an external component. From 3e1867eeee6095879c0936ca4706c281354a5186 Mon Sep 17 00:00:00 2001 From: nojaf Date: Mon, 5 May 2025 09:53:02 +0200 Subject: [PATCH 27/31] Remove helper code --- compiler/core/jsx_help.ml | 48 --------------------------------------- 1 file changed, 48 deletions(-) delete mode 100644 compiler/core/jsx_help.ml diff --git a/compiler/core/jsx_help.ml b/compiler/core/jsx_help.ml deleted file mode 100644 index 936ba4fd60..0000000000 --- a/compiler/core/jsx_help.ml +++ /dev/null @@ -1,48 +0,0 @@ -let lambda_tag_info_to_string (e : Lambda.tag_info) = - match e with - | Lambda.Blk_constructor _ -> "Blk_constructor" - | Lambda.Blk_record_inlined _ -> "Blk_record_inlined" - | Lambda.Blk_tuple -> "Blk_tuple" - | Lambda.Blk_poly_var _ -> "Blk_poly_var" - | Lambda.Blk_record _ -> "Blk_record" - | Lambda.Blk_module _ -> "Blk_module" - | Lambda.Blk_module_export _ -> "Blk_module_export" - | Lambda.Blk_extension -> "Blk_extension" - | Lambda.Blk_some -> "Blk_some" - | Lambda.Blk_some_not_nested -> "Blk_some_not_nested" - | Lambda.Blk_record_ext _ -> "Blk_record_ext" - | Lambda.Blk_lazy_general -> "Blk_lazy_general" - -let j_exp_to_string (e : J.expression) = - match e.J.expression_desc with - | J.Object _ -> "Object" - | J.Str _ -> "String" - | J.Var (J.Qualified (_, Some o)) -> "Var_" ^ o - | J.Var _ -> "Var" - | J.Call _ -> "Call" - | J.Fun _ -> "Fun" - | J.Array _ -> "Array" - | J.Bin _ -> "Bin" - | J.Cond _ -> "Cond" - | J.New _ -> "New" - | J.Seq _ -> "Seq" - | J.Number _ -> "Number" - | J.Bool _ -> "Bool" - | J.Null -> "Null" - | J.Undefined _ -> "Undefined" - | J.Is_null_or_undefined _ -> "Is_null_or_undefined" - | J.Js_not _ -> "Js_not" - | J.Typeof _ -> "Typeof" - | J.String_index _ -> "String_index" - | J.Array_index _ -> "Array_index" - | J.Static_index _ -> "Static_index" - | J.Length _ -> "Length" - | J.Caml_block (_, _, _, tag) -> - Format.sprintf "Caml_block (%s)" (lambda_tag_info_to_string tag) - | J.Caml_block_tag _ -> "Caml_block_tag" - | J.Tagged_template _ -> "Tagged_template" - | J.Optional_block _ -> "Optional_block" - | J.Spread _ -> "Spread" - | J.Await _ -> "Await" - | J.Raw_js_code _ -> "Raw_js_code" - | _ -> "Other" From 32bffd8c39a0f0f0c15a08827125424f606a09e8 Mon Sep 17 00:00:00 2001 From: nojaf Date: Mon, 5 May 2025 09:56:19 +0200 Subject: [PATCH 28/31] Extra call info --- compiler/core/lam_compile_primitive.ml | 17 ++++++----------- 1 file changed, 6 insertions(+), 11 deletions(-) diff --git a/compiler/core/lam_compile_primitive.ml b/compiler/core/lam_compile_primitive.ml index ae17cd8077..1a52d835fd 100644 --- a/compiler/core/lam_compile_primitive.ml +++ b/compiler/core/lam_compile_primitive.ml @@ -54,17 +54,15 @@ let get_module_system () = | [module_system] -> module_system | _ -> Commonjs +let call_info = + {Js_call_info.arity = Full; call_info = Call_na; call_transformed_jsx = false} + let import_of_path path = - E.call - ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = false} - (E.js_global "import") - [E.str path] + E.call ~info:call_info (E.js_global "import") [E.str path] let wrap_then import value = let arg = Ident.create "m" in - E.call - ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = false} - (E.dot import "then") + E.call ~info:call_info (E.dot import "then") [ E.ocaml_fun ~return_unit:false ~async:false ~one_unit_arg:false [arg] [{statement_desc = J.Return (E.dot (E.var arg) value); comment = None}]; @@ -88,10 +86,7 @@ let translate output_prefix loc (cxt : Lam_compile_context.t) | _ -> assert false) | Pjs_apply -> ( match args with - | fn :: rest -> - E.call - ~info:{arity = Full; call_info = Call_na; call_transformed_jsx = false} - fn rest + | fn :: rest -> E.call ~info:call_info fn rest | _ -> assert false) | Pnull_to_opt -> ( match args with From f10452935ae8bc0325116323ee9b55f61c1827be Mon Sep 17 00:00:00 2001 From: nojaf Date: Mon, 5 May 2025 10:33:42 +0200 Subject: [PATCH 29/31] Detect direct Array as well --- compiler/core/js_dump.ml | 1 + tests/tests/src/preserve_jsx_test.mjs | 18 ++++++++++++++++++ tests/tests/src/preserve_jsx_test.res | 23 +++++++++++++++++++++++ 3 files changed, 42 insertions(+) diff --git a/compiler/core/js_dump.ml b/compiler/core/js_dump.ml index 0b70f9204c..05c300d0a3 100644 --- a/compiler/core/js_dump.ml +++ b/compiler/core/js_dump.ml @@ -1086,6 +1086,7 @@ and print_jsx cxt ?(spread_props : J.expression option) if n = "children" then if fnName = "jsxs" then match e.J.expression_desc with + | J.Array (xs, _) | J.Optional_block ({expression_desc = J.Array (xs, _)}, _) -> Some xs | _ -> Some [e] diff --git a/tests/tests/src/preserve_jsx_test.mjs b/tests/tests/src/preserve_jsx_test.mjs index b90f732eb0..092830e77d 100644 --- a/tests/tests/src/preserve_jsx_test.mjs +++ b/tests/tests/src/preserve_jsx_test.mjs @@ -47,7 +47,24 @@ let _container_with_spread_props_keyed = /* @__PURE__ */ jsxs("div", { ...newrec /* @__PURE__ */ jsx("input", { type: "text" }) ] }, "barry-key"); let _unary_element_with_only_spread_props = /* @__PURE__ */ jsx("input", { ...baseProps }); +function QueryClientProvider(props) { + return props.children; +} +; +let A = {}; +function Preserve_jsx_test$B(props) { + return /* @__PURE__ */ jsx("p", { children: "Hello, world!" }); +} +let B = { + make: Preserve_jsx_test$B +}; +let _external_component_with_children = /* @__PURE__ */ jsxs(QueryClientProvider, { children: [ + /* @__PURE__ */ jsx("strong", {}), + /* @__PURE__ */ jsx(Preserve_jsx_test$B, {}) +] }); export { + A, + B, Icon, React, ReactDOM, @@ -56,6 +73,7 @@ export { _container_with_spread_props, _container_with_spread_props_and_children, _container_with_spread_props_keyed, + _external_component_with_children, _multiple_element_children, _multiple_element_fragment, _single_element_child, diff --git a/tests/tests/src/preserve_jsx_test.res b/tests/tests/src/preserve_jsx_test.res index 044c2bd66e..81042f4b25 100644 --- a/tests/tests/src/preserve_jsx_test.res +++ b/tests/tests/src/preserve_jsx_test.res @@ -132,3 +132,26 @@ let _container_with_spread_props_keyed =
let _unary_element_with_only_spread_props = + +// Simulate an external component +%%raw(` + function QueryClientProvider(props) { return props.children } + `) + +module A = { + @react.component + external make: (~children: React.element) => React.element = "QueryClientProvider" +} + +module B = { + @react.component + let make = () => { +

{React.string("Hello, world!")}

+ } +} + +let _external_component_with_children = + + + + From 848b3abf439caf33f5ab39184d58eadbeb815515 Mon Sep 17 00:00:00 2001 From: nojaf Date: Mon, 5 May 2025 11:00:08 +0200 Subject: [PATCH 30/31] Don't run with mocha --- package.json | 1 - scripts/test.js | 47 ++--- tests/tests/src/preserve_jsx_test.mjs | 164 ++++++++++------ yarn.lock | 262 -------------------------- 4 files changed, 122 insertions(+), 352 deletions(-) diff --git a/package.json b/package.json index cec6044956..ba4759e9f3 100644 --- a/package.json +++ b/package.json @@ -85,7 +85,6 @@ "@biomejs/biome": "1.9.4", "@types/node": "^20.14.9", "@types/semver": "^7.5.8", - "esbuild": "0.25.3", "mocha": "10.8.2", "nyc": "15.0.0", "semver": "7.6.2", diff --git a/scripts/test.js b/scripts/test.js index eb12f52b83..b7fddb16ac 100644 --- a/scripts/test.js +++ b/scripts/test.js @@ -3,7 +3,6 @@ import * as fs from "node:fs"; import * as os from "node:os"; import * as path from "node:path"; -import * as esbuild from "esbuild"; import { buildTestDir, compilerTestDir, @@ -84,38 +83,22 @@ if (mochaTest) { stdio: "inherit", }); - // We need to the jsx because mocha doesn't support jsx - const preserveJsxTestFile = path.join( - projectDir, - "tests/tests/src/preserve_jsx_test.mjs", + await mocha( + [ + "-t", + "10000", + "tests/tests/**/*_test.mjs", + // Ignore the preserve_jsx_test.mjs file. + // I can't run because Mocha doesn't support jsx. + // We also want to keep the output as is. + "--ignore", + "tests/tests/src/preserve_jsx_test.mjs", + ], + { + cwd: projectDir, + stdio: "inherit", + }, ); - try { - await esbuild.build({ - entryPoints: [preserveJsxTestFile], // Specify the single input file - outfile: preserveJsxTestFile, // Specify the single output file - allowOverwrite: true, // We just overwrite the existing file - bundle: false, // Crucial: Turn off bundling - minify: false, // Turn off minification - sourcemap: false, // Turn off source maps if not needed - loader: { ".mjs": "jsx" }, // Tell esbuild to apply the 'jsx' loader to .mjs files - format: "esm", // Ensure output is ESM - platform: "node", // Target Node.js environment - jsx: "automatic", - }); - - console.log(`Built (transformed) ${preserveJsxTestFile}`); - } catch (error) { - console.error( - `Error building (transforming) ${preserveJsxTestFile}:`, - error, - ); - process.exit(1); - } - - await mocha(["-t", "10000", "tests/tests/**/*_test.mjs"], { - cwd: projectDir, - stdio: "inherit", - }); await node("tests/tests/src/core/Core_TestSuite.mjs", [], { cwd: projectDir, diff --git a/tests/tests/src/preserve_jsx_test.mjs b/tests/tests/src/preserve_jsx_test.mjs index 092830e77d..0c25c00707 100644 --- a/tests/tests/src/preserve_jsx_test.mjs +++ b/tests/tests/src/preserve_jsx_test.mjs @@ -1,87 +1,137 @@ -import { Fragment, jsx, jsxs } from "react/jsx-runtime"; +// Generated by ReScript, PLEASE EDIT WITH CARE + import * as Primitive_option from "rescript/lib/es6/Primitive_option.js"; import * as JsxRuntime from "react/jsx-runtime"; + let React = {}; + let ReactDOM = {}; + function Preserve_jsx_test$Icon(props) { - return /* @__PURE__ */ jsx("strong", {}); + return ; } + let Icon = { make: Preserve_jsx_test$Icon }; -let _single_element_child = /* @__PURE__ */ jsx("div", { children: /* @__PURE__ */ jsx("h1", { children: "Hello, world!" }) }); -let _multiple_element_children = /* @__PURE__ */ jsxs("div", { children: [ - /* @__PURE__ */ jsx("h1", { children: "Hello, world!" }), - /* @__PURE__ */ jsx(Preserve_jsx_test$Icon, {}) -] }); -let _single_element_fragment = /* @__PURE__ */ jsx(Fragment, { children: Primitive_option.some(/* @__PURE__ */ jsx("input", {})) }); -let _multiple_element_fragment = /* @__PURE__ */ jsxs(Fragment, { children: [ - /* @__PURE__ */ jsx("input", { type: "text" }), - /* @__PURE__ */ jsx("input", { type: "number" }) -] }); -let _unary_element_with_props = /* @__PURE__ */ jsx("input", { className: "foo", type: "text" }); -let _container_element_with_props_and_children = /* @__PURE__ */ jsx("div", { className: "foo", title: "foo", children: "Hello, world!" }); + +let _single_element_child =
+

+{"Hello, world!"} +

+
; + +let _multiple_element_children =
+

+{"Hello, world!"} +

+ +
; + +let _single_element_fragment = <> +{Primitive_option.some()} +; + +let _multiple_element_fragment = <> + + +; + +let _unary_element_with_props = ; + +let _container_element_with_props_and_children =
+{"Hello, world!"} +
; + let baseProps = { className: "foo", title: "foo" }; -let newrecord = { ...baseProps }; -let _unary_element_with_spread_props = /* @__PURE__ */ jsx("input", { ...newrecord, type: "text" }); -let newrecord$1 = { ...baseProps }; -let _container_with_spread_props = /* @__PURE__ */ jsxs("div", { ...newrecord$1, title: "barry", className: "barry", children: [ - "Hello, world!", - /* @__PURE__ */ jsx("input", { type: "text" }) -] }); + +let newrecord = {...baseProps}; + +let _unary_element_with_spread_props = ; + +let newrecord$1 = {...baseProps}; + +let _container_with_spread_props =
+{"Hello, world!"} + +
; + let baseChildren = [ - /* @__PURE__ */ jsx("span", { children: "Hello, world!" }), - /* @__PURE__ */ jsx("span", { children: "Hello, world!" }) + + {"Hello, world!"} + , + + {"Hello, world!"} + ]; -let _container_with_spread_children = /* @__PURE__ */ jsx("div", { className: "barry", title: "barry", children: baseChildren }); -let newrecord$2 = { ...baseProps }; -let _container_with_spread_props_and_children = /* @__PURE__ */ jsx("div", { ...newrecord$2, title: "barry", className: "barry", children: baseChildren }); -let newrecord$3 = { ...baseProps }; -let _unary_element_with_spread_props_keyed = /* @__PURE__ */ jsx("input", { ...newrecord$3, type: "text" }, "barry-key"); -let newrecord$4 = { ...baseProps }; -let _container_with_spread_props_keyed = /* @__PURE__ */ jsxs("div", { ...newrecord$4, title: "barry", className: "barry", children: [ - "Hello, world!", - /* @__PURE__ */ jsx("input", { type: "text" }) -] }, "barry-key"); -let _unary_element_with_only_spread_props = /* @__PURE__ */ jsx("input", { ...baseProps }); -function QueryClientProvider(props) { - return props.children; -} + +let _container_with_spread_children =
+{baseChildren} +
; + +let newrecord$2 = {...baseProps}; + +let _container_with_spread_props_and_children =
+{baseChildren} +
; + +let newrecord$3 = {...baseProps}; + +let _unary_element_with_spread_props_keyed = ; + +let newrecord$4 = {...baseProps}; + +let _container_with_spread_props_keyed =
+{"Hello, world!"} + +
; + +let _unary_element_with_only_spread_props = ; + +function QueryClientProvider(props) { return props.children } ; + let A = {}; + function Preserve_jsx_test$B(props) { - return /* @__PURE__ */ jsx("p", { children: "Hello, world!" }); + return

+ {"Hello, world!"} +

; } + let B = { make: Preserve_jsx_test$B }; -let _external_component_with_children = /* @__PURE__ */ jsxs(QueryClientProvider, { children: [ - /* @__PURE__ */ jsx("strong", {}), - /* @__PURE__ */ jsx(Preserve_jsx_test$B, {}) -] }); + +let _external_component_with_children = + + +; + export { - A, - B, - Icon, React, ReactDOM, - _container_element_with_props_and_children, - _container_with_spread_children, - _container_with_spread_props, - _container_with_spread_props_and_children, - _container_with_spread_props_keyed, - _external_component_with_children, - _multiple_element_children, - _multiple_element_fragment, + Icon, _single_element_child, + _multiple_element_children, _single_element_fragment, - _unary_element_with_only_spread_props, + _multiple_element_fragment, _unary_element_with_props, + _container_element_with_props_and_children, + baseProps, _unary_element_with_spread_props, - _unary_element_with_spread_props_keyed, + _container_with_spread_props, baseChildren, - baseProps -}; + _container_with_spread_children, + _container_with_spread_props_and_children, + _unary_element_with_spread_props_keyed, + _container_with_spread_props_keyed, + _unary_element_with_only_spread_props, + A, + B, + _external_component_with_children, +} +/* _single_element_child Not a pure module */ diff --git a/yarn.lock b/yarn.lock index 4dbed16337..de112f2ba7 100644 --- a/yarn.lock +++ b/yarn.lock @@ -274,181 +274,6 @@ __metadata: languageName: node linkType: hard -"@esbuild/aix-ppc64@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/aix-ppc64@npm:0.25.3" - conditions: os=aix & cpu=ppc64 - languageName: node - linkType: hard - -"@esbuild/android-arm64@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/android-arm64@npm:0.25.3" - conditions: os=android & cpu=arm64 - languageName: node - linkType: hard - -"@esbuild/android-arm@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/android-arm@npm:0.25.3" - conditions: os=android & cpu=arm - languageName: node - linkType: hard - -"@esbuild/android-x64@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/android-x64@npm:0.25.3" - conditions: os=android & cpu=x64 - languageName: node - linkType: hard - -"@esbuild/darwin-arm64@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/darwin-arm64@npm:0.25.3" - conditions: os=darwin & cpu=arm64 - languageName: node - linkType: hard - -"@esbuild/darwin-x64@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/darwin-x64@npm:0.25.3" - conditions: os=darwin & cpu=x64 - languageName: node - linkType: hard - -"@esbuild/freebsd-arm64@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/freebsd-arm64@npm:0.25.3" - conditions: os=freebsd & cpu=arm64 - languageName: node - linkType: hard - -"@esbuild/freebsd-x64@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/freebsd-x64@npm:0.25.3" - conditions: os=freebsd & cpu=x64 - languageName: node - linkType: hard - -"@esbuild/linux-arm64@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/linux-arm64@npm:0.25.3" - conditions: os=linux & cpu=arm64 - languageName: node - linkType: hard - -"@esbuild/linux-arm@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/linux-arm@npm:0.25.3" - conditions: os=linux & cpu=arm - languageName: node - linkType: hard - -"@esbuild/linux-ia32@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/linux-ia32@npm:0.25.3" - conditions: os=linux & cpu=ia32 - languageName: node - linkType: hard - -"@esbuild/linux-loong64@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/linux-loong64@npm:0.25.3" - conditions: os=linux & cpu=loong64 - languageName: node - linkType: hard - -"@esbuild/linux-mips64el@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/linux-mips64el@npm:0.25.3" - conditions: os=linux & cpu=mips64el - languageName: node - linkType: hard - -"@esbuild/linux-ppc64@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/linux-ppc64@npm:0.25.3" - conditions: os=linux & cpu=ppc64 - languageName: node - linkType: hard - -"@esbuild/linux-riscv64@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/linux-riscv64@npm:0.25.3" - conditions: os=linux & cpu=riscv64 - languageName: node - linkType: hard - -"@esbuild/linux-s390x@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/linux-s390x@npm:0.25.3" - conditions: os=linux & cpu=s390x - languageName: node - linkType: hard - -"@esbuild/linux-x64@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/linux-x64@npm:0.25.3" - conditions: os=linux & cpu=x64 - languageName: node - linkType: hard - -"@esbuild/netbsd-arm64@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/netbsd-arm64@npm:0.25.3" - conditions: os=netbsd & cpu=arm64 - languageName: node - linkType: hard - -"@esbuild/netbsd-x64@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/netbsd-x64@npm:0.25.3" - conditions: os=netbsd & cpu=x64 - languageName: node - linkType: hard - -"@esbuild/openbsd-arm64@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/openbsd-arm64@npm:0.25.3" - conditions: os=openbsd & cpu=arm64 - languageName: node - linkType: hard - -"@esbuild/openbsd-x64@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/openbsd-x64@npm:0.25.3" - conditions: os=openbsd & cpu=x64 - languageName: node - linkType: hard - -"@esbuild/sunos-x64@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/sunos-x64@npm:0.25.3" - conditions: os=sunos & cpu=x64 - languageName: node - linkType: hard - -"@esbuild/win32-arm64@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/win32-arm64@npm:0.25.3" - conditions: os=win32 & cpu=arm64 - languageName: node - linkType: hard - -"@esbuild/win32-ia32@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/win32-ia32@npm:0.25.3" - conditions: os=win32 & cpu=ia32 - languageName: node - linkType: hard - -"@esbuild/win32-x64@npm:0.25.3": - version: 0.25.3 - resolution: "@esbuild/win32-x64@npm:0.25.3" - conditions: os=win32 & cpu=x64 - languageName: node - linkType: hard - "@isaacs/cliui@npm:^8.0.2": version: 8.0.2 resolution: "@isaacs/cliui@npm:8.0.2" @@ -1382,92 +1207,6 @@ __metadata: languageName: node linkType: hard -"esbuild@npm:0.25.3": - version: 0.25.3 - resolution: "esbuild@npm:0.25.3" - dependencies: - "@esbuild/aix-ppc64": "npm:0.25.3" - "@esbuild/android-arm": "npm:0.25.3" - "@esbuild/android-arm64": "npm:0.25.3" - "@esbuild/android-x64": "npm:0.25.3" - "@esbuild/darwin-arm64": "npm:0.25.3" - "@esbuild/darwin-x64": "npm:0.25.3" - "@esbuild/freebsd-arm64": "npm:0.25.3" - "@esbuild/freebsd-x64": "npm:0.25.3" - "@esbuild/linux-arm": "npm:0.25.3" - "@esbuild/linux-arm64": "npm:0.25.3" - "@esbuild/linux-ia32": "npm:0.25.3" - "@esbuild/linux-loong64": "npm:0.25.3" - "@esbuild/linux-mips64el": "npm:0.25.3" - "@esbuild/linux-ppc64": "npm:0.25.3" - "@esbuild/linux-riscv64": "npm:0.25.3" - "@esbuild/linux-s390x": "npm:0.25.3" - "@esbuild/linux-x64": "npm:0.25.3" - "@esbuild/netbsd-arm64": "npm:0.25.3" - "@esbuild/netbsd-x64": "npm:0.25.3" - "@esbuild/openbsd-arm64": "npm:0.25.3" - "@esbuild/openbsd-x64": "npm:0.25.3" - "@esbuild/sunos-x64": "npm:0.25.3" - "@esbuild/win32-arm64": "npm:0.25.3" - "@esbuild/win32-ia32": "npm:0.25.3" - "@esbuild/win32-x64": "npm:0.25.3" - dependenciesMeta: - "@esbuild/aix-ppc64": - optional: true - "@esbuild/android-arm": - optional: true - "@esbuild/android-arm64": - optional: true - "@esbuild/android-x64": - optional: true - "@esbuild/darwin-arm64": - optional: true - "@esbuild/darwin-x64": - optional: true - "@esbuild/freebsd-arm64": - optional: true - "@esbuild/freebsd-x64": - optional: true - "@esbuild/linux-arm": - optional: true - "@esbuild/linux-arm64": - optional: true - "@esbuild/linux-ia32": - optional: true - "@esbuild/linux-loong64": - optional: true - "@esbuild/linux-mips64el": - optional: true - "@esbuild/linux-ppc64": - optional: true - "@esbuild/linux-riscv64": - optional: true - "@esbuild/linux-s390x": - optional: true - "@esbuild/linux-x64": - optional: true - "@esbuild/netbsd-arm64": - optional: true - "@esbuild/netbsd-x64": - optional: true - "@esbuild/openbsd-arm64": - optional: true - "@esbuild/openbsd-x64": - optional: true - "@esbuild/sunos-x64": - optional: true - "@esbuild/win32-arm64": - optional: true - "@esbuild/win32-ia32": - optional: true - "@esbuild/win32-x64": - optional: true - bin: - esbuild: bin/esbuild - checksum: 10c0/127aff654310ede4e2eb232a7b1d8823f5b5d69222caf17aa7f172574a5b6b75f71ce78c6d8a40030421d7c75b784dc640de0fb1b87b7ea77ab2a1c832fa8df8 - languageName: node - linkType: hard - "escalade@npm:^3.1.1, escalade@npm:^3.2.0": version: 3.2.0 resolution: "escalade@npm:3.2.0" @@ -2743,7 +2482,6 @@ __metadata: "@rescript/win32-x64": "workspace:packages/@rescript/win32-x64" "@types/node": "npm:^20.14.9" "@types/semver": "npm:^7.5.8" - esbuild: "npm:0.25.3" mocha: "npm:10.8.2" nyc: "npm:15.0.0" semver: "npm:7.6.2" From aceb0e29a830c7a3841310f91ba2484fac51c7f1 Mon Sep 17 00:00:00 2001 From: nojaf Date: Mon, 5 May 2025 11:19:57 +0200 Subject: [PATCH 31/31] Feedback code review --- compiler/core/js_call_info.ml | 3 ++ compiler/core/js_call_info.mli | 2 + compiler/core/lam_compile.ml | 19 +------- compiler/core/lam_compile_external_call.ml | 53 +++------------------- 4 files changed, 13 insertions(+), 64 deletions(-) diff --git a/compiler/core/js_call_info.ml b/compiler/core/js_call_info.ml index 6412d91b1f..c58aad901f 100644 --- a/compiler/core/js_call_info.ml +++ b/compiler/core/js_call_info.ml @@ -42,3 +42,6 @@ let builtin_runtime_call = let ml_full_call = {arity = Full; call_info = Call_ml; call_transformed_jsx = false} + +let na_full_call transformed_jsx = + {arity = Full; call_info = Call_na; call_transformed_jsx = transformed_jsx} diff --git a/compiler/core/js_call_info.mli b/compiler/core/js_call_info.mli index 1977426737..ff0d3ad875 100644 --- a/compiler/core/js_call_info.mli +++ b/compiler/core/js_call_info.mli @@ -42,3 +42,5 @@ val dummy : t val builtin_runtime_call : t val ml_full_call : t + +val na_full_call : bool -> t diff --git a/compiler/core/lam_compile.ml b/compiler/core/lam_compile.ml index 58ba342170..159b9d9012 100644 --- a/compiler/core/lam_compile.ml +++ b/compiler/core/lam_compile.ml @@ -50,14 +50,7 @@ let rec apply_with_arity_aux (fn : J.expression) (arity : int list) if len >= x then let first_part, continue = Ext_list.split_at args x in apply_with_arity_aux - (E.call - ~info: - { - arity = Full; - call_info = Call_ml; - (* no clue if this is correct *) call_transformed_jsx = false; - } - fn first_part) + (E.call ~info:Js_call_info.ml_full_call fn first_part) rest continue (len - x) else if (* GPR #1423 *) @@ -70,15 +63,7 @@ let rec apply_with_arity_aux (fn : J.expression) (arity : int list) ~async:false ~one_unit_arg:false [ S.return_stmt - (E.call - ~info: - { - arity = Full; - call_info = Call_ml; - (* no clue if this is correct *) call_transformed_jsx = - false; - } - fn + (E.call ~info:Js_call_info.ml_full_call fn (Ext_list.append args @@ Ext_list.map params E.var)); ] else E.call ~info:Js_call_info.dummy fn args diff --git a/compiler/core/lam_compile_external_call.ml b/compiler/core/lam_compile_external_call.ml index 2a5ff0f3f4..34cdcbd9d0 100644 --- a/compiler/core/lam_compile_external_call.ml +++ b/compiler/core/lam_compile_external_call.ml @@ -288,14 +288,7 @@ let translate_ffi ?(transformed_jsx = false) (cxt : Lam_compile_context.t) let args, eff, dynamic = assemble_args_has_splice arg_types args in let args = if dynamic then E.variadic_args args else args in add_eff eff - (E.call - ~info: - { - arity = Full; - call_info = Call_na; - call_transformed_jsx = transformed_jsx; - } - fn args)) + (E.call ~info:(Js_call_info.na_full_call transformed_jsx) fn args)) | Js_call { external_module_name = module_name; @@ -311,14 +304,7 @@ let translate_ffi ?(transformed_jsx = false) (cxt : Lam_compile_context.t) let args, eff, dynamic = assemble_args_has_splice arg_types args in let args = if dynamic then E.variadic_args args else args in add_eff eff - (E.call - ~info: - { - arity = Full; - call_info = Call_na; - call_transformed_jsx = transformed_jsx; - } - fn args) + (E.call ~info:(Js_call_info.na_full_call transformed_jsx) fn args) else let args, eff = assemble_args_no_splice arg_types args in add_eff eff @@ -336,26 +322,12 @@ let translate_ffi ?(transformed_jsx = false) (cxt : Lam_compile_context.t) let args, eff, dynamic = assemble_args_has_splice arg_types args in let args = if dynamic then E.variadic_args args else args in add_eff eff - (E.call - ~info: - { - arity = Full; - call_info = Call_na; - call_transformed_jsx = transformed_jsx; - } - fn args) + (E.call ~info:(Js_call_info.na_full_call transformed_jsx) fn args) else let args, eff = assemble_args_no_splice arg_types args in (* TODO: fix in rest calling convention *) add_eff eff - (E.call - ~info: - { - arity = Full; - call_info = Call_na; - call_transformed_jsx = transformed_jsx; - } - fn args) + (E.call ~info:(Js_call_info.na_full_call transformed_jsx) fn args) | Js_new {external_module_name = module_name; name = fn; splice; scopes} -> (* handle [@@new]*) (* This has some side effect, it will @@ -414,12 +386,7 @@ let translate_ffi ?(transformed_jsx = false) (cxt : Lam_compile_context.t) add_eff eff (let self = translate_scoped_access js_send_scopes self in E.call - ~info: - { - arity = Full; - call_info = Call_na; - call_transformed_jsx = transformed_jsx; - } + ~info:(Js_call_info.na_full_call transformed_jsx) (E.dot self name) args) | _ -> assert false) | Js_module_as_var module_name -> external_var module_name ~dynamic_import @@ -434,15 +401,7 @@ let translate_ffi ?(transformed_jsx = false) (cxt : Lam_compile_context.t) ~dynamic_import in if args = [] then e - else - E.call - ~info: - { - arity = Full; - call_info = Call_na; - call_transformed_jsx = transformed_jsx; - } - e args + else E.call ~info:(Js_call_info.na_full_call transformed_jsx) e args | Js_module_as_class module_name -> let fn = external_var module_name ~dynamic_import in let args, eff = assemble_args_no_splice arg_types args in