Transform initial simple element

nojaf · nojaf · commit a0c170f0bed6 · 2025-05-03T12:38:09.000+02:00
diff --git 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 "<meh />";
-    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 "></";
+        P.string f tagName;
+        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
@@ -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
@@ -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
@@ -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,15 +339,23 @@ 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
       (* TODO: fix in rest calling convention *)
       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,15 +404,23 @@ 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
         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 = 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
@@ -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
@@ -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
@@ -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
@@ -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
@@ -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
diff --git a/compiler/ml/translcore.ml b/compiler/ml/translcore.ml
diff --git a/compiler/ml/translmod.ml b/compiler/ml/translmod.ml
