Throw as instance of JS new Error() (#6611)

* throw as instance of JS `new Error()`

Adapted from melange-re/melange#1036

Thanks @anmonteiro

* uncomment test

* update output

* update build

* [skip ci]: update CHANGELOG.md

Author: aspeddro

CHANGELOG.md

@@ -16,6 +16,7 @@
 
 - Allow `@directive` on functions for emitting function level directive code (`let serverAction = @directive("'use server'") (~name) => {...}`). https://github.com/rescript-lang/rescript-compiler/pull/6756
 - Add `rewatch` to the npm package as an alternative build tool. https://github.com/rescript-lang/rescript-compiler/pull/6762
+- Throws an instance of JavaScript's `new Error()` and adds the extension payload for `cause` option. https://github.com/rescript-lang/rescript-compiler/pull/6611
 
 #### :boom: Breaking Change
 

jscomp/core/js_dump.ml

@@ -97,8 +97,11 @@ type cxt = Ext_pp_scope.t
 let semi f = P.string f L.semi
 let comma f = P.string f L.comma
 
+let new_error name cause =
+  E.new_ (E.js_global Js_dump_lit.error) [ name; cause ]
+
 let exn_block_as_obj ~(stack : bool) (el : J.expression list) (ext : J.tag_info)
-    : J.expression_desc =
+    : J.expression =
   let field_name =
     match ext with
     | Blk_extension -> (
@@ -108,12 +111,29 @@ let exn_block_as_obj ~(stack : bool) (el : J.expression list) (ext : J.tag_info)
         fun i -> match i with 0 -> Literals.exception_id | i -> ss.(i - 1))
     | _ -> assert false
   in
-  Object
-    (if stack then
-     Ext_list.mapi_append el
-       (fun i e -> (Js_op.Lit (field_name i), e))
-       [ (Js_op.Lit "Error", E.new_ (E.js_global "Error") []) ]
-    else Ext_list.mapi el (fun i e -> (Js_op.Lit (field_name i), e)))
+    let cause =
+    {
+      J.expression_desc =
+        Object (List.mapi (fun i e -> (Js_op.Lit (field_name i), e)) el);
+      comment = None;
+    }
+  in
+   if stack then
+      new_error (List.hd el)
+        {
+          J.expression_desc = Object [ (Lit Js_dump_lit.cause, cause) ];
+          comment = None;
+        }
+    else cause
+
+let exn_ref_as_obj e : J.expression =
+  let cause = { J.expression_desc = e; comment = None; } in
+  new_error
+    (E.record_access cause Js_dump_lit.exception_id 0l)
+    {
+      J.expression_desc = Object [ (Lit Js_dump_lit.cause, cause) ];
+      comment = None;
+    }
 
 let rec iter_lst cxt (f : P.t) ls element inter =
   match ls with
@@ -730,7 +750,7 @@ and expression_desc cxt ~(level : int) f x : cxt =
                ])
       | _ -> assert false)
   | Caml_block (el, _, _, ((Blk_extension | Blk_record_ext _) as ext)) ->
-      expression_desc cxt ~level f (exn_block_as_obj ~stack:false el ext)
+      expression cxt ~level f (exn_block_as_obj ~stack:false el ext)
   | Caml_block (el, _, tag, Blk_record_inlined p) ->
       let untagged = Ast_untagged_variants.process_untagged p.attrs in
       let objs =
@@ -1184,8 +1204,8 @@ and statement_desc top cxt f (s : J.statement_desc) : cxt =
       let e =
         match e.expression_desc with
         | Caml_block (el, _, _, ((Blk_extension | Blk_record_ext _) as ext)) ->
-            { e with expression_desc = exn_block_as_obj ~stack:true el ext }
-        | _ -> e
+            { e with expression_desc = (exn_block_as_obj ~stack:true el ext).expression_desc }
+        | exp -> { e with expression_desc = (exn_ref_as_obj exp).expression_desc }
       in
       P.string f L.throw;
       P.space f;

jscomp/core/js_dump_lit.ml

@@ -164,3 +164,9 @@ let block_variant = "variant"
 let block_simple_variant = "simpleVariant"
 
 let case = "case"
+
+let cause = "cause"
+
+let error = "Error"
+
+let exception_id = "RE_EXN_ID"

jscomp/core/js_exp_make.ml

@@ -416,7 +416,7 @@ let poly_var_value_access (e : t) =
         comment = None;
       }
 
-let extension_access (e : t) name (pos : int32) : t =
+let extension_access (e : t) ?name (pos : int32) : t =
   match e.expression_desc with
   | Array (l, _) (* Float i -- should not appear here *)
   | Caml_block (l, _, _, _)

jscomp/core/js_exp_make.mli

@@ -170,7 +170,7 @@ val variant_access : t -> int32 -> t
 
 val cons_access : t -> int32 -> t
 
-val extension_access : t -> string option -> Int32.t -> t
+val extension_access : t -> ?name:string -> Int32.t -> t
 
 val record_assign : t -> int32 -> string -> t -> t
 

jscomp/core/js_of_lam_block.ml

@@ -38,8 +38,8 @@ let field (field_info : Lam_compat.field_dbg_info) e (i : int32) =
         e i
   | Fld_poly_var_content -> E.poly_var_value_access e
   | Fld_poly_var_tag -> E.poly_var_tag_access e
-  | Fld_record_extension { name } -> E.extension_access e (Some name) i
-  | Fld_extension -> E.extension_access e None i
+  | Fld_record_extension { name } -> E.extension_access e ~name i
+  | Fld_extension -> E.extension_access e i
   | Fld_variant -> E.variant_access e i
   | Fld_cons -> E.cons_access e i
   | Fld_record_inline { name } -> E.inline_record_access e name i

jscomp/core/lam_convert.ml

@@ -22,14 +22,17 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
-let caml_id_field_info : Lambda.field_dbg_info =
-  Fld_record { name = Literals.exception_id; mutable_flag = Immutable }
-
-let lam_caml_id : Lam_primitive.t = Pfield (0, caml_id_field_info)
 let prim = Lam.prim
 
-let lam_extension_id loc (head : Lam.t) =
-  prim ~primitive:lam_caml_id ~args:[ head ] loc
+let lam_extension_id =
+  let lam_caml_id : Lam_primitive.t =
+    let caml_id_field_info : Lambda.field_dbg_info =
+      Fld_record { name = Js_dump_lit.exception_id; mutable_flag = Immutable }
+    in
+    Pfield (0, caml_id_field_info)
+  in
+  fun loc (head : Lam.t) ->
+    prim ~primitive:lam_caml_id ~args:[ head ] loc
 
 let lazy_block_info : Lam_tag_info.t =
   Blk_record

jscomp/runtime/caml_format.ml

@@ -659,7 +659,7 @@ let float_of_string : string -> exn ->  float  =
         return Infinity;
     if (/^-inf(inity)?$/i.test(s))
         return -Infinity;
-    throw exn;
+    throw new Error(exn.RE_EXN_ID, { cause: exn });;
 }
 |}]
 

jscomp/runtime/caml_js_exceptions.res

@@ -23,14 +23,14 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
 
 exception Error = JsError
-
+type js_error = { cause : exn }
 /**   
    This function has to be in this module Since 
    [Error] is defined here 
 */
 let internalToOCamlException = (e: unknown) =>
-  if Caml_exceptions.is_extension(e) {
-    (Obj.magic(e): exn)
+  if Caml_exceptions.is_extension(((Obj.magic(e): js_error).cause)) {
+    (Obj.magic(e): js_error).cause
   } else {
     JsError(e)
   }

jscomp/runtime/caml_lexer.res

@@ -160,7 +160,7 @@ let caml_lex_engine_aux: (
         if (state < 0) {
             lexbuf.lex_curr_pos = lexbuf.lex_last_pos;
             if (lexbuf.lex_last_action == -1)
-                throw exn
+                throw new Error(exn.RE_EXN_ID, { cause: exn })
             else
                 return lexbuf.lex_last_action;
         }
@@ -308,7 +308,7 @@ let caml_new_lex_engine_aux: (
         if (state < 0) {
             lexbuf.lex_curr_pos = lexbuf.lex_last_pos;
             if (lexbuf.lex_last_action == -1)
-                throw exn;
+                throw new Error(exn.RE_EXN_ID, { cause: exn });
             else
                 return lexbuf.lex_last_action;
         }