Merge pull request #4764 from rescript-lang/fix_4762

fix #4762

Author: bobzhang

jscomp/main/builtin_cmi_datasets.ml

@@ -132,7 +132,7 @@ end
 module MapperRt = Js_mapperRt
 module Internal = struct 
   open Fn    
-  external unsafeInvariantApply : 'a -> 'a = "#full_apply"
+  external opaqueFullApply : 'a -> 'a = "#full_apply"
 
   (* Use opaque instead of [._n] to prevent some optimizations happening *)
   external run : 'a arity0 -> 'a = "#run" 

jscomp/runtime/js.ml

@@ -18,7 +18,7 @@ SNAP=../lib/$snapshot_path
 o snapshot: phony  $SNAP/whole_compiler.ml   $SNAP/bsb_helper.ml $SNAP/bsb.ml $SNAP/unstable/all_ounit_tests.ml
 # $SNAP/bspp.ml
 o $SNAP/whole_compiler.ml: bspack | ./bin/bspack.exe $LTO
-    flags = ${releaseMode} -D BS_ONLY=true -bs-MD -module-alias Config=Config_whole_compiler -bs-exclude-I config  -I $OCAML_SRC_UTILS -I $OCAML_SRC_PARSING -I $OCAML_SRC_TYPING -I $OCAML_SRC_BYTECOMP -I $OCAML_SRC_DRIVER   ${includes}
+    flags = ${releaseMode} -D BS_ONLY=true -bs-MD -module-alias Config=Config_whole_compiler -bs-exclude-I config  -I $OCAML_SRC_UTILS -I $OCAML_SRC_PARSING -I $OCAML_SRC_TYPING -I $OCAML_SRC_BYTECOMP -I $OCAML_SRC_DRIVER   $includes
     main = Js_main
     post_process = && node $LTO $SNAP/whole_compiler.ml
 

jscomp/snapshot.ninja

@@ -48,7 +48,7 @@ module Lid = struct
   (* TODO should be renamed in to {!Js.fn} *)
   (* TODO should be moved into {!Js.t} Later *)
   let js_internal : t = Ldot (Lident "Js", "Internal")
-  let js_internal_full_apply : t = Ldot (js_internal, "unsafeInvariantApply")
+  let js_internal_full_apply : t = Ldot (js_internal, "opaqueFullApply")
   let opaque : t = Ldot (js_internal, "opaque")
   let js_fn : t =
       Ldot (Lident "Js",  "Fn")

jscomp/syntax/ast_literal.ml

@@ -34,6 +34,17 @@ type exp = Parsetree.expression
 let jsInternal = 
   Ast_literal.Lid.js_internal
 
+(* we use the trick 
+  [( opaque e : _) ] to avoid it being inspected, 
+  the type constraint is avoid some syntactic transformation, e.g ` e |. (f g [@bs])`
+  `opaque` is to avoid it being inspected in the type level
+*)
+let opaque_full_apply ~loc (e : exp) : Parsetree.expression_desc =   
+  Pexp_constraint
+    (Exp.apply ~loc (Exp.ident {txt = Ast_literal.Lid.js_internal_full_apply; loc})
+      [Nolabel,e],
+      Typ.any ~loc ()
+    )  
 let generic_apply loc 
     (self : Bs_ast_mapper.mapper) 
     (obj : Parsetree.expression) 
@@ -56,18 +67,15 @@ let generic_apply loc
       (Exp.ident {txt = Ldot (jsInternal, "run");loc}, [Nolabel,fn])
   else 
     let arity_s = string_of_int arity in 
-
-    Parsetree.Pexp_apply (
-      Exp.ident {txt = Ast_literal.Lid.js_internal_full_apply; loc},
-      [Nolabel,
-       Exp.apply ~loc
-         (Exp.apply ~loc
-            (Exp.ident ~loc {txt = Ast_literal.Lid.opaque; loc}) 
-            [(Nolabel, Exp.field ~loc 
-              (Exp.constraint_ ~loc fn 
-                (Typ.constr ~loc {txt = Ldot (Ast_literal.Lid.js_fn, "arity"^arity_s);loc} 
-                  [Typ.any ~loc ()])) {txt = Ast_literal.Lid.hidden_field arity_s; loc})]) 
-         args])                        
+    opaque_full_apply ~loc (
+      Exp.apply ~loc
+        (Exp.apply ~loc
+           (Exp.ident ~loc {txt = Ast_literal.Lid.opaque; loc}) 
+           [(Nolabel, Exp.field ~loc 
+               (Exp.constraint_ ~loc fn 
+                  (Typ.constr ~loc {txt = Ldot (Ast_literal.Lid.js_fn, "arity"^arity_s);loc} 
+                     [Typ.any ~loc ()])) {txt = Ast_literal.Lid.hidden_field arity_s; loc})]) 
+        args)
 
 let method_apply  loc 
     (self : Bs_ast_mapper.mapper) 
@@ -91,17 +99,15 @@ let method_apply  loc
         (Exp.ident {txt = Ldot ((Ldot (Ast_literal.Lid.js_oo,"Internal")), "run");loc}, [Nolabel,fn])
     else 
       let arity_s = string_of_int arity in 
-      Parsetree.Pexp_apply (
-        Exp.ident {txt = Ast_literal.Lid.js_internal_full_apply; loc},
-        [Nolabel,
-         Exp.apply ~loc (
-           Exp.apply ~loc (Exp.ident ~loc {txt = Ast_literal.Lid.opaque; loc}) 
-             [(Nolabel,
+      opaque_full_apply ~loc (
+        Exp.apply ~loc (
+          Exp.apply ~loc (Exp.ident ~loc {txt = Ast_literal.Lid.opaque; loc}) 
+            [(Nolabel,
               Exp.field ~loc
                 (Exp.constraint_ ~loc 
-                  fn (Typ.constr ~loc {txt = Ldot (Ast_literal.Lid.js_meth,"arity"^arity_s);loc} [Typ.any ~loc ()]))
+                   fn (Typ.constr ~loc {txt = Ldot (Ast_literal.Lid.js_meth,"arity"^arity_s);loc} [Typ.any ~loc ()]))
                 {loc; txt = Ast_literal.Lid.hidden_field arity_s})]) 
-           args])
+          args)
 
 
 let uncurry_fn_apply loc self fn args = 

jscomp/syntax/ast_uncurry_apply.ml

@@ -17,9 +17,6 @@ let h = fun [@bs] ~x:unit -> 3
 
 let a = u1 u
 
-(* let u1 (f : u) =
-  Js.Internal.unsafeInvariantApply ((Js.Internal.run2 (f : u)) ~y:"x" ~x:2) 
-  *)
 
 
 type u0 = ?x:int -> y : string -> int [@bs]

jscomp/test/label_uncurry.ml

@@ -1,13 +1,5 @@
 
 
-(* external unsafeInvariantApply : 'a -> 'a = "#full_apply"
-
-
-let f1 x = unsafeInvariantApply (x ())
-
-
-let f2 x y = unsafeInvariantApply (x y ()) *)
-
 
 let rec f = fun [@bs] a -> f a [@bs]