Differentiate exception extensions (#6954)

* Differentiate exception extensions

* Update extension tests

Author: DZakh

jscomp/ml/ctype.ml

@@ -4172,6 +4172,7 @@ let nondep_extension_constructor env mid ext =
         ext_private = ext.ext_private;
         ext_attributes = ext.ext_attributes;
         ext_loc = ext.ext_loc;
+        ext_is_exception = ext.ext_is_exception;
       }
   with Not_found ->
     clear_hash ();

jscomp/ml/env.ml

@@ -1777,7 +1777,6 @@ and store_extension ~check id ext env =
   if check && not loc.Location.loc_ghost &&
     Warnings.is_active (Warnings.Unused_extension ("", false, false, false))
   then begin
-    let is_exception = Path.same ext.ext_type_path Predef.path_exn in
     let ty = Path.last ext.ext_type_path in
     let n = Ident.name id in
     let k = (ty, loc, n) in
@@ -1789,7 +1788,7 @@ and store_extension ~check id ext env =
           if not (is_in_signature env) && not used.cu_positive then
             Location.prerr_warning loc
               (Warnings.Unused_extension
-                 (n, is_exception, used.cu_pattern, used.cu_privatize)
+                 (n, ext.ext_is_exception, used.cu_pattern, used.cu_privatize)
               )
         )
     end;

jscomp/ml/predef.ml

@@ -276,7 +276,7 @@ let common_initial_env add_type add_extension empty_env =
      type_variance = [Variance.covariant]}
   in
 
-  let add_extension id l =
+  let add_exception id l =
     add_extension id
       { ext_type_path = path_exn;
         ext_type_params = [];
@@ -286,19 +286,20 @@ let common_initial_env add_type add_extension empty_env =
         ext_loc = Location.none;
         ext_attributes = [{Asttypes.txt="ocaml.warn_on_literal_pattern";
                            loc=Location.none},
-                          Parsetree.PStr[]] }
+                          Parsetree.PStr[]];
+        ext_is_exception = true }
   in
-  add_extension ident_match_failure
+  add_exception ident_match_failure
                          [newgenty (Ttuple[type_string; type_int; type_int])] (
-  add_extension ident_invalid_argument [type_string] (
-  add_extension ident_js_error [type_unknown] (
-  add_extension ident_failure [type_string] (
-  add_extension ident_not_found [] (
-  add_extension ident_end_of_file [] (
-  add_extension ident_division_by_zero [] (
-  add_extension ident_assert_failure
+  add_exception ident_invalid_argument [type_string] (
+  add_exception ident_js_error [type_unknown] (
+  add_exception ident_failure [type_string] (
+  add_exception ident_not_found [] (
+  add_exception ident_end_of_file [] (
+  add_exception ident_division_by_zero [] (
+  add_exception ident_assert_failure
                          [newgenty (Ttuple[type_string; type_int; type_int])] (
-  add_extension ident_undefined_recursive_module
+  add_exception ident_undefined_recursive_module
                          [newgenty (Ttuple[type_string; type_int; type_int])] (
   add_type ident_int64 decl_abstr (
   add_type ident_bigint decl_abstr (

jscomp/ml/subst.ml

@@ -313,7 +313,8 @@ let extension_constructor s ext =
       ext_ret_type = may_map (typexp s) ext.ext_ret_type;
       ext_private = ext.ext_private;
       ext_attributes = attrs s ext.ext_attributes;
-      ext_loc = if s.for_saving then Location.none else ext.ext_loc; }
+      ext_loc = if s.for_saving then Location.none else ext.ext_loc;
+      ext_is_exception = ext.ext_is_exception; }
   in
     cleanup_types ();
     ext

jscomp/ml/typedecl.ml

@@ -1556,21 +1556,23 @@ let transl_extension_constructor env type_path type_params
         in
         args, ret_type, Text_rebind(path, lid)
   in
+  let is_exception = Path.same type_path Predef.path_exn in
   let ext =
-    { ext_type_path = type_path;
+    { Types.ext_type_path = type_path;
       ext_type_params = typext_params;
       ext_args = args;
       ext_ret_type = ret_type;
       ext_private = priv;
-      Types.ext_loc = sext.pext_loc;
-      Types.ext_attributes = sext.pext_attributes; }
+      ext_loc = sext.pext_loc;
+      ext_attributes = sext.pext_attributes;
+      ext_is_exception = is_exception; }
   in
-    { ext_id = id;
+    { Typedtree.ext_id = id;
       ext_name = sext.pext_name;
       ext_type = ext;
       ext_kind = kind;
-      Typedtree.ext_loc = sext.pext_loc;
-      Typedtree.ext_attributes = sext.pext_attributes; }
+      ext_loc = sext.pext_loc;
+      ext_attributes = sext.pext_attributes; }
 
 let transl_extension_constructor env type_path type_params
     typext_params priv sext =

jscomp/ml/types.ml

@@ -198,7 +198,8 @@ type extension_constructor =
       ext_ret_type: type_expr option;
       ext_private: private_flag;
       ext_loc: Location.t;
-      ext_attributes: Parsetree.attributes; }
+      ext_attributes: Parsetree.attributes;
+      ext_is_exception: bool; }
 
 and type_transparence =
     Type_public      (* unrestricted expansion *)

jscomp/ml/types.mli

@@ -350,6 +350,7 @@ type extension_constructor =
       ext_private: private_flag;
       ext_loc: Location.t;
       ext_attributes: Parsetree.attributes;
+      ext_is_exception: bool;
     }
 
 and type_transparence =

jscomp/test/record_extension_test.js

@@ -1,4 +1,4 @@
-/* for o in jscomp/test/*test.js ; do npx mocha  $o ; done */*/
+/* for o in jscomp/test/*test.js ; do npx mocha  $o ; done */ */
 
 let suites: ref<Mt.pair_suites> = ref(list{})
 let test_id = ref(0)
@@ -7,15 +7,19 @@ let eq = (loc, x, y) => Mt.eq_suites(~test_id, ~suites, loc, x, y)
 /* Record_extension */
 type t0 = ..
 type t0 += Inline_record({x: int, y: string})
+type t0 += SinglePayload(string) | TuplePayload(int, string)
 
 let f = x =>
   switch x {
   | Inline_record({x, y}) => Some(x + int_of_string(y))
+  | SinglePayload(v) => Some(int_of_string(v))
+  | TuplePayload(v0, v1) => Some(v0 + int_of_string(v1))
   | _ => None
   }
-let v0 = Inline_record({x: 3, y: "4"})
 
-eq(__LOC__, f(v0), Some(7))
+eq(__LOC__, f(Inline_record({x: 3, y: "4"})), Some(7))
+eq(__LOC__, f(SinglePayload("1")), Some(1))
+eq(__LOC__, f(TuplePayload(1, "2")), Some(3))
 
 /* Record_unboxed */
 type t1 = | @unboxed A({x: int})
@@ -52,4 +56,8 @@ let u = f =>
   | _ => -1
   }
 
+eq(__LOC__, u(() => raise(A({name: 1, x: 1}))), 2)
+eq(__LOC__, u(() => raise(B(1, 2))), 3)
+eq(__LOC__, u(() => raise(C({name: 4}))), 4)
+
 let () = Mt.from_pair_suites(__LOC__, suites.contents)