Merge pull request #412 from bloomberg/non_intrusive_uncurry_support

Non intrusive uncurry support

Author: bobzhang

docs/Curry-and-Uncurry-functions.md

@@ -17,7 +17,7 @@ To apply a function, you can do this
 
 ```ocaml
 f 3 "x"
-f_uncurry #@ (3,"x")
+f_uncurry (3,"x") [@uncurry]
 ```
 For uncurried function applicaton, BuckleScript is guaranteed to
 compile it in the same way as JS code
@@ -42,7 +42,7 @@ Both are correct code, but the second one is more efficient.
 
 ```ocaml
 let f = fun a b -> a + string_of_int b
-let f_uncurry = fun %uncurry a b -> a + string_of_int b 
+let f_uncurry = fun [@uncurry] (a, b) -> a + string_of_int b 
 ```
 
 - When is uncurried function recommended

docs/OCaml-call-JS.md

@@ -33,19 +33,18 @@ improve the generated code.
     }
    |}]
    ```
-   In the expression level, i.e, `[%bs.raw ...]` user can add a type annotation, the compiler would use such type annotation to deduce its arities. for example, the next three versions:
+   In the expression level, i.e, `[%bs.raw ...]` user can add a type
+   annotation, for example:
 
    ```ocaml
-   let f = [%bs.raw ("Math.max"  : float -> float -> float) ] 3.0 
-   let f : float -> float -> float = [%bs.raw "Math.max" ] 3.0
-   let f = ([%bs.raw "Math.max"] : float -> float -> float ) 3.0
+   let f : float * float -> float [@uncurry] = [%bs.raw "Math.max" ]
+   in f (3.0, 2.0) [@uncurry]
    ```
    will be translated into 
 
    ```js
-   function f(prim){
-     return Math.max(3.0,prim);
-   }
+   var f = Math.max ;
+   f(3.0,2.0)
    ```
    Caveat:
    1. So far we don't do any sanity check in the quoted text (syntax check is a long-term goal)
@@ -220,7 +219,7 @@ On top of this we can write normal OCaml functions, for example:
    ```OCaml
    let assert_equal = eq
    let from_suites name suite  = 
-       describe name (fun%uncurry () -> 
+       describe name (fun [@uncurry] () -> 
          List.iter (fun (name, code) -> it name code) suite)
    ```
 
@@ -271,8 +270,8 @@ val f : < hi : ('a * 'b -> 'c [@uncurry] ;  .. > Js.t  -> 'a -> 'b -> 'c
   This attribute helps create JavaScript object literal
 
 ```ocaml
-  let a = f ({ hi = fun %uncurry (x,y) -> x + y}[@bs.obj]) 1 2 
-  let b = f ({ hi = fun %uncurry (x,y) -> x +. y}[@bs.obj]) 1. 2.
+  let a = f ({ hi = fun [@uncurry] (x,y) -> x + y}[@bs.obj]) 1 2 
+  let b = f ({ hi = fun [@uncurry] (x,y) -> x +. y}[@bs.obj]) 1. 2.
   ```
 
    Generated code is like below 

jscomp/lam_compile.ml

@@ -177,7 +177,6 @@ and get_exp_with_args (cxt : Lam_compile_defs.cxt)  lam args_lambda
                  end
             ) args_lambda ([], []) in
 
-
         match closed_lambda with 
         | Some (Lfunction (_, params, body)) 
           when Ext_list.same_length params args_lambda -> 
@@ -204,13 +203,13 @@ and get_exp_with_args (cxt : Lam_compile_defs.cxt)  lam args_lambda
              E.unit
            | {name = "CamlinternalMod"; _}, "init_mod" ,
              [ 
-                _ ;
-                shape  ;
-                (* Module []
-                   TODO: add a function [empty_shape]
-                   This pattern match is fragile, since it depends 
-                   on how we compile [Lconst]
-                *)
+               _ ;
+               shape  ;
+               (* Module []
+                  TODO: add a function [empty_shape]
+                  This pattern match is fragile, since it depends 
+                  on how we compile [Lconst]
+               *)
              ] when Js_of_lam_module.is_empty_shape shape
              ->
              E.dummy_obj () (* purely type definition*)
@@ -511,8 +510,11 @@ and
       compile_lambda  cxt  
         (Lapply (an, (args' @ args), (Lam_util.mk_apply_info App_na)))
     (* External function calll *)
-    | Lapply(Lprim(Pfield (n,_), [ Lprim(Pgetglobal id,[])]), args_lambda,_info) ->
-
+    | Lapply(Lprim(Pfield (n,_), [ Lprim(Pgetglobal id,[])]), args_lambda,
+             {apply_status = App_na | App_ml_full}) ->
+      (* Note we skip [App_js_full] since [get_exp_with_args] dont carry 
+         this information, we should fix [get_exp_with_args]
+      *)
       get_exp_with_args cxt lam  args_lambda id n  env
 
 
@@ -875,10 +877,10 @@ and
           end
 
         | fn :: rest -> 
-          compile_lambda cxt @@ 
-          Lambda.Lapply (fn, rest , 
-                         {apply_loc = Location.none;
-                          apply_status = App_js_full})
+          compile_lambda cxt 
+            (Lapply (fn, rest , 
+                     {apply_loc = Location.none;
+                      apply_status = App_js_full}))
         | _ -> assert false 
       else 
         begin match args_lambda with 

jscomp/ppx_entry.ml

@@ -279,27 +279,18 @@ let gen_fn_mk loc arity args  : Parsetree.expression_desc =
 
 
 
-let handle_raw ?ty loc e attrs  = 
-  let attrs = 
-    match ty with 
-    | Some ty -> 
-      Parsetree_util.attr_attribute_from_type ty :: attrs  
-    | None -> attrs in 
+let handle_raw loc e   = 
   Ast_helper.Exp.letmodule 
     {txt = tmp_module_name; loc }
     (Ast_helper.Mod.structure [ 
         Ast_helper.Str.primitive 
-          (Ast_helper.Val.mk ~attrs {loc ; txt = tmp_fn} 
+          (Ast_helper.Val.mk  {loc ; txt = tmp_fn} 
              ~prim:[prim]
-             (Ast_helper.Typ.arrow "" predef_string_type predef_any_type))]
-    )    
-  (Ast_helper.Exp.constraint_ ~loc  
+             (Ast_helper.Typ.arrow "" predef_string_type predef_any_type))])    
     (Ast_helper.Exp.apply 
        (Ast_helper.Exp.ident {txt= Ldot(Lident tmp_module_name, tmp_fn) ; loc})
        [("",e)])
-    (match ty with 
-    | Some ty -> ty
-    | None -> predef_any_type))
+
 
 
 
@@ -650,25 +641,10 @@ let rec unsafe_mapper : Ast_mapper.mapper =
             PStr 
               ( [{ pstr_desc = Pstr_eval ({ 
                    pexp_desc = Pexp_constant (Const_string (_, _)) ;
-                   pexp_attributes = attrs } as e ,
+                    } as e ,
                                                 _); pstr_loc = _ }]))
           -> 
-
-              handle_raw loc e attrs
-        | Pexp_extension( {txt = "bs.raw"; loc}, PStr 
-                ( [{ pstr_desc = Parsetree.Pstr_eval ({ 
-                      pexp_desc = 
-                        Pexp_constraint (
-                          {pexp_desc = Pexp_constant (Const_string (_, _)) ; _}
-                          as e,
-                             ty)
-                      ; pexp_attributes = attrs} , _);  }]))
-        | Pexp_constraint({pexp_desc = Pexp_extension( {txt = "bs.raw"; loc}, PStr 
-                ( [{ pstr_desc = Pstr_eval ({ 
-                      pexp_desc = 
-                        Pexp_constant (Const_string (_, _)) 
-                      ; pexp_attributes = attrs} as e , _);  }]))}, ty)            
-              -> handle_raw ~ty loc e attrs
+              handle_raw loc e 
         | Pexp_extension({txt = "bs.raw"; loc}, (PTyp _ | PPat _ | PStr _))
               -> 
               Location.raise_errorf ~loc "bs.raw can only be applied to a string"
@@ -679,24 +655,26 @@ let rec unsafe_mapper : Ast_mapper.mapper =
         | Pexp_extension ({txt = "bs.debugger"; loc} , payload)
           -> handle_debugger loc payload
         (** End rewriting *)
-
-        | Pexp_extension
-                 ({txt = "uncurry";loc},
-                  PStr
-                    [{
-                      pstr_desc =
-                        Pstr_eval
-                          ({pexp_desc =
-                              Pexp_fun ("", None, pat ,
-                                        body)},
-                           _)}])
-          -> 
-          begin match body.pexp_desc with 
-          | Pexp_fun _ -> 
-            Location.raise_errorf ~loc 
-              "`fun %%uncurry (param0, param1) -> ` instead of `fun %%uncurry param0 param1 ->` "
-          | _ -> handle_uncurry_generation loc pat body e mapper
+        | Pexp_fun ("", None, pat , body)
+          ->
+          let loc = e.pexp_loc in 
+          begin match Ext_list.exclude_with_fact (function 
+              | {Location.txt = "uncurry"; _}, _ -> true 
+              | _ -> false) e.pexp_attributes with 
+          | None, _ -> Ast_mapper.default_mapper.expr mapper e 
+          | Some _, attrs 
+            -> 
+            begin match body.pexp_desc with 
+              | Pexp_fun _ -> 
+                Location.raise_errorf ~loc 
+                  {| `fun [@uncurry] (param0, param1) -> `
+                     instead of `fun [@uncurry] param0 param1 ->` |}
+              | _ -> 
+                handle_uncurry_generation loc pat body 
+                  {e with pexp_attributes = attrs } mapper
+            end
           end
+
         | Pexp_apply ({pexp_desc = Pexp_ident {txt = Lident "#@"; loc}},
                       [("", fn);
                        ("", pat)])
@@ -733,6 +711,18 @@ let rec unsafe_mapper : Ast_mapper.mapper =
                         ) )
                       ])
           -> handle_obj_property loc obj name e mapper
+        | Pexp_apply (fn,
+                      [("", pat)]) -> 
+          let loc = e.pexp_loc in 
+          begin match Ext_list.exclude_with_fact (function 
+              | {Location.txt = "uncurry"; _}, _ -> true 
+              | _ -> false) e.pexp_attributes with 
+          | None, _ -> Ast_mapper.default_mapper.expr mapper e 
+          | Some _, attrs -> 
+            handle_uncurry_application loc fn pat 
+              {e with pexp_attributes = attrs} mapper
+          end
+
         | Pexp_record (label_exprs, None)   -> 
           begin match  (* exclude {[ u with ..]} syntax currently *)
               Ext_list.exclude_with_fact 

jscomp/runtime/Makefile

@@ -21,7 +21,7 @@ $(addsuffix .cmj, $(OTHERS)): caml_builtin_exceptions.cmj  block.cmj js.cmj
 RUNTIME := $(addsuffix .cmj, $(SOURCE_LIST)) 
 
 
-COMPFLAGS += $(MODULE_FLAGS) -I ../stdlib -nostdlib -nopervasives -open Pervasives -w -40 -js-npm-output-path $(npm_package_name):lib/js -js-no-builtin-ppx-mli
+COMPFLAGS += $(MODULE_FLAGS) -I ../stdlib -nostdlib -nopervasives -open Pervasives -w -40 -js-npm-output-path $(npm_package_name):lib/js 
 
 
 

jscomp/runtime/caml_float.ml

@@ -117,7 +117,7 @@ let caml_modf_float (x : float) : float * float =
   else if Js.Float.is_nan x then Js.Float.nan ,  Js.Float.nan 
   else (1. /. x , x)
 
-let caml_ldexp_float = [%bs.raw ({| function (x,exp) {
+let caml_ldexp_float : float * int -> float [@uncurry] = [%bs.raw {| function (x,exp) {
     exp |= 0;
     if (exp > 1023) {
         exp -= 1023;
@@ -134,11 +134,11 @@ let caml_ldexp_float = [%bs.raw ({| function (x,exp) {
     x *= Math.pow(2, exp);
     return x;
 }
-|} : float -> int -> float)]
+|}]
 
 
 
-let caml_frexp_float =  [%bs.raw ({|function (x) {
+let caml_frexp_float : float -> float * int [@uncurry]=  [%bs.raw {|function (x) {
     if ((x == 0) || !isFinite(x)) return [ x, 0];
     var neg = x < 0;
     if (neg) x = - x;
@@ -148,7 +148,7 @@ let caml_frexp_float =  [%bs.raw ({|function (x) {
     if (neg) x = - x;
     return [x, exp];
 }
-|} : float -> float * int )]
+|}]
 
 let caml_float_compare (x : float) (y : float ) = 
   if x = y then 0 
@@ -178,18 +178,17 @@ let caml_log1p_float  : float -> float = function x ->
   if z = 0. then x else x *. log y /. z 
 
 
-let caml_hypot_float = [%bs.raw ({| function (x, y) {
+let caml_hypot_float : float * float -> float [@uncurry] = [%bs.raw {| function (x, y) {
     var x0 = Math.abs(x), y0 = Math.abs(y);
     var a = Math.max(x0, y0), b = Math.min(x0,y0) / (a?a:1);
     return a * Math.sqrt(1 + b*b);
 }
-|} : float -> float -> float)
-]
+|}]
 
 
-let caml_log10_float =  [%bs.raw ({| function  (x) { 
+let caml_log10_float : float -> float [@uncurry] =  [%bs.raw {| function  (x) { 
    return Math.LOG10E * Math.log(x); }
-|} : float -> float) ]
+|} ]
 
 
 let caml_cosh_float x = exp x +. exp (-. x) /. 2. 

jscomp/runtime/caml_float.mli

@@ -33,11 +33,13 @@ val caml_int32_bits_of_float : float -> int32
 
 val caml_classify_float : float -> fpclass
 val caml_modf_float : float -> float * float 
-val caml_ldexp_float : float -> int -> float 
-val caml_frexp_float : float -> float * int
+
+val caml_ldexp_float : float * int -> float [@uncurry]
+val caml_frexp_float : float -> float * int [@uncurry]
 val caml_float_compare : float -> float -> int 
 val caml_copysign_float : float -> float -> float
 val caml_expm1_float : float -> float 
 
-val caml_hypot_float : float -> float -> float  
-val caml_log10_float : float -> float
+val caml_hypot_float : float * float -> float  [@uncurry]
+
+val caml_log10_float : float -> float [@uncurry]

jscomp/runtime/caml_format.ml

@@ -361,9 +361,8 @@ let aux f (i : nativeint)  =
       f.filter <- " ";
       let n = f.prec -Js.String.length !s in 
       if n > 0 then
-        s :=  repeat n "0"  ^ !s
-    end
-  ;
+        s :=  repeat (n, "0")[@uncurry]  ^ !s
+    end ;
   finish_formatting f !s
 
 let caml_format_int fmt i = 
@@ -485,7 +484,7 @@ let caml_int64_format fmt x =
       f.filter <- " ";
       let n = f.prec -Js.String.length !s in
       if n > 0 then
-        s := repeat n "0" ^ !s
+        s := repeat (n, "0") [@uncurry] ^ !s
     end;
 
   finish_formatting f !s

jscomp/runtime/caml_int64.ml

@@ -388,7 +388,7 @@ let to_hex x =
     if pad <= 0 then             
       aux x.hi ^ lo
     else
-      aux x.hi ^ Caml_utils.repeat pad "0" ^ lo 
+      aux x.hi ^ Caml_utils.repeat(pad, "0") [@uncurry] ^ lo 
 
 let discard_sign x = {x with hi = Nativeint.logand 0x7fff_ffffn x.hi }  
 

jscomp/runtime/caml_io.ml

@@ -44,7 +44,7 @@ let stdout = {
   output = (fun _ s ->
     let v =Js.String.length s - 1 in
     if [%bs.raw{| (typeof process !== "undefined") && process.stdout && process.stdout.write|}] then
-      ([%bs.raw{| process.stdout.write |} ] : string -> unit) s
+      ([%bs.raw{| process.stdout.write |} ] : string -> unit [@uncurry]) s [@uncurry]
     else
     if s.[v] = '\n' then
       Js.log (Js.String.slice s 0 v)
@@ -86,10 +86,8 @@ let caml_ml_output (oc : out_channel) (str : string) offset len  =
     else Js.String.slice str offset len in
   if [%bs.raw{| (typeof process !== "undefined") && process.stdout && process.stdout.write |}] &&
      oc == stdout then
-    begin     
+    ([%bs.raw{| process.stdout.write |}] : string -> unit [@uncurry] ) str [@uncurry]
 
-      ([%bs.raw{| process.stdout.write |}] : string -> unit ) str
-    end        
   else
     begin