[refactoring] clean up arity which does not depend on type info anymore

Author: Hongbo Zhang

jscomp/js_dump.ml

@@ -643,7 +643,7 @@ and
     pp_string f (* ~utf:(kind = `Utf8) *) ~quote s; cxt 
   | Raw_js_code (s,info) -> 
     begin match info with 
-    | Exp _ -> 
+    | Exp -> 
       P.string f "("; 
       P.string f s ; 
       P.string f ")";
@@ -1147,7 +1147,7 @@ and statement_desc top cxt f (s : J.statement_desc) : Ext_pp_scope.t =
       match e.expression_desc with
       | Call ({expression_desc = Fun _; },_,_) -> true
       | Caml_uninitialized_obj _ 
-      | Raw_js_code (_, Exp _) 
+      | Raw_js_code (_, Exp) 
       | Fun _ | Object _ -> true
       | Raw_js_code (_,Stmt)
       | Caml_block_set_tag _ 

jscomp/js_op.ml

@@ -247,7 +247,7 @@ type length_object =
   | Caml_block
 
 type code_info = 
-  | Exp of int option
+  | Exp (* of int option *)
   | Stmt
 (** TODO: define constant - for better constant folding  *)
 (* type constant =  *)

jscomp/lam_compile_external_call.ml

@@ -31,7 +31,7 @@
 
 module E = Js_exp_make
 
-open Parsetree_util
+
 
 type external_module_name = 
   | Single of string 
@@ -141,7 +141,7 @@ let handle_attributes ({prim_attributes ; prim_name} as _prim  : prim ) : Locati
               ]}
            *)
            -> 
-           begin  match is_single_string pay_load with
+           begin  match Ast_payload.is_single_string pay_load with
              | Some name -> 
                js_val := `Value name 
              | None -> 
@@ -152,7 +152,7 @@ let handle_attributes ({prim_attributes ; prim_name} as _prim  : prim ) : Locati
            (* {[ [@@bs.val_of_module]]}
            *)
            -> 
-           begin match is_single_string pay_load with 
+           begin match Ast_payload.is_single_string pay_load with 
            | Some name ->
              js_val_of_module := `Value(Bind (name, prim_name))
            | None -> 
@@ -164,19 +164,19 @@ let handle_attributes ({prim_attributes ; prim_name} as _prim  : prim ) : Locati
 
          |"bs.send" 
            ->
-           begin match is_single_string pay_load with 
+           begin match Ast_payload.is_single_string pay_load with 
              | Some name -> js_send := `Value name
              | None -> js_send := `Value _prim.prim_name
            end
          | "bs.set"
            ->
-           begin match is_single_string pay_load with
+           begin match Ast_payload.is_single_string pay_load with
              | Some name -> js_set := `Value name
              | None -> js_set := `Value _prim.prim_name
            end
          | "bs.get"
            ->
-           begin match is_single_string pay_load with
+           begin match Ast_payload.is_single_string pay_load with
              | Some name -> js_get := `Value name
              | None -> js_get := `Value _prim.prim_name
            end
@@ -186,20 +186,20 @@ let handle_attributes ({prim_attributes ; prim_name} as _prim  : prim ) : Locati
              [@@bs.call "xx"] [@@bs.call]
            *)
            ->
-           begin match is_single_string pay_load with 
+           begin match Ast_payload.is_single_string pay_load with 
              | Some name -> call_name :=  Some (x.loc, name)
              | None -> call_name := Some(x.loc, _prim.prim_name)
            end
          | "bs.module" -> 
-           begin match is_string_or_strings pay_load with 
+           begin match Ast_payload.is_string_or_strings pay_load with 
              | `Single name -> external_module_name:= Some (Single name)
              | `Some [a;b] -> external_module_name := Some (Bind (a,b))
              | `Some _ -> ()
              | `None -> () (* should emit a warning instead *)
            end
 
          | "bs.new" -> 
-           begin match is_single_string pay_load with 
+           begin match Ast_payload.is_single_string pay_load with 
              | Some x -> js_new := Some x 
              | None -> js_new := Some _prim.prim_name
            end

jscomp/lam_dispatch_primitive.ml

@@ -940,7 +940,7 @@ let query (prim : Lam_compile_env.primitive_description)
       -> 
       begin match args with 
       | [ { expression_desc = Str (_,s )}] -> 
-        E.raw_js_code (Exp (Parsetree_util.has_arity prim.prim_attributes)) s
+        E.raw_js_code Exp  s
       | _ -> 
         Ext_log.err __LOC__ 
           "JS.unsafe_js_expr is applied to an non literal string in %s"

jscomp/lam_stats_util.ml

@@ -92,16 +92,16 @@ let rec get_arity
 
     end
   | Llet(_,_,_, l ) -> get_arity meta l 
-  | Lprim (Pccall {prim_name = "js_pure_expr"; prim_attributes}, 
-           [Lconst (Const_base (Const_string (_str,_)))])
-    ->
-    (* Ext_log.dwarn __LOC__ "called %s %d" str (List.length prim_attributes ); *)
-    begin match Parsetree_util.has_arity prim_attributes with
-      | Some arity -> 
-        (* Ext_log.dwarn __LOC__ "arity %d" arity; *)
-        Determin(false, [arity, None], false)
-      | None -> NA
-    end
+  (* | Lprim (Pccall {prim_name = "js_pure_expr"; prim_attributes},  *)
+  (*          [Lconst (Const_base (Const_string (_str,_)))]) *)
+  (*   -> *)
+  (*   (\* Ext_log.dwarn __LOC__ "called %s %d" str (List.length prim_attributes ); *\) *)
+  (*   begin match Parsetree_util.has_arity prim_attributes with *)
+  (*     | Some arity ->  *)
+  (*       (\* Ext_log.dwarn __LOC__ "arity %d" arity; *\) *)
+  (*       Determin(false, [arity, None], false) *)
+  (*     | None -> NA *)
+  (*   end *)
   | Lprim (Pfield (n,_), [Lprim(Pgetglobal id,[])]) ->
     Lam_compile_env.find_and_add_if_not_exist (id, n) meta.env
       ~not_found:(fun _ -> assert false)

jscomp/syntax/ast_payload.ml

@@ -0,0 +1,69 @@
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ * 
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ * 
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+
+type t = Parsetree.payload
+
+let is_single_string (x : t ) = 
+  match x with  (** TODO also need detect empty phrase case *)
+  | PStr [ {
+      pstr_desc =  
+        Pstr_eval (
+          {pexp_desc = 
+             Pexp_constant 
+               (Const_string (name,_));
+           _},_);
+      _}] -> Some name
+  | _  -> None
+
+
+let is_string_or_strings (x : t) : 
+  [ `None | `Single of string | `Some of string list ] = 
+  let module M = struct exception Not_str end  in 
+  match x with 
+  | PStr [ {pstr_desc =  
+              Pstr_eval (
+                {pexp_desc = 
+                   Pexp_apply
+                     ({pexp_desc = Pexp_constant (Const_string (name,_)); _},
+                      args
+                     );
+                 _},_);
+            _}] ->
+    (try 
+       `Some (name :: (args |> List.map (fun (_label,e) ->
+           match (e : Parsetree.expression) with
+           | {pexp_desc = Pexp_constant (Const_string (name,_)); _} -> 
+             name
+           | _ -> raise M.Not_str)))
+
+     with M.Not_str -> `None )
+  | PStr [ {
+      pstr_desc =  
+        Pstr_eval (
+          {pexp_desc = 
+             Pexp_constant 
+               (Const_string (name,_));
+           _},_);
+      _}] -> `Single name 
+  | _ -> `None

jscomp/syntax/ast_payload.mli

@@ -0,0 +1,35 @@
+(* Copyright (C) 2015-2016 Bloomberg Finance L.P.
+ * 
+ * This program is free software: you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, either version 3 of the License, or
+ * (at your option) any later version.
+ *
+ * In addition to the permissions granted to you by the LGPL, you may combine
+ * or link a "work that uses the Library" with a publicly distributed version
+ * of this file to produce a combined library or application, then distribute
+ * that combined work under the terms of your choosing, with no requirement
+ * to comply with the obligations normally placed on you by section 4 of the
+ * LGPL version 3 (or the corresponding section of a later version of the LGPL
+ * should you choose to use a later version).
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ * 
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
+
+
+
+(** A utility module used when destructuring parsetree attributes, used for 
+    compiling FFI attributes and built-in ppx  *)
+
+type t = Parsetree.payload
+
+val is_single_string : t -> string option
+
+val is_string_or_strings : 
+  t -> [ `None | `Single of string | `Some of string list ]

jscomp/syntax/parsetree_util.ml

@@ -41,7 +41,8 @@ let is_single_string (x : Parsetree.payload ) =
       _}] -> Some name
   | _  -> None
 
-let is_string_or_strings (x : Parsetree.payload ) :  [ `None | `Single of string | `Some of string list ] = 
+let is_string_or_strings (x : Parsetree.payload ) : 
+  [ `None | `Single of string | `Some of string list ] = 
   let module M = struct exception Not_str end  in 
   match x with 
   | PStr [ {pstr_desc =  
@@ -74,40 +75,3 @@ let is_string_or_strings (x : Parsetree.payload ) :  [ `None | `Single of string
 let lift_int ?loc ?attrs x = 
   Ast_helper.Exp.constant ?loc ?attrs (Const_int x)
 
-let has_arity (attrs : Parsetree.attributes) = 
-  Ext_list.find_opt (fun (attr : Parsetree.attribute)  -> 
-      match attr with 
-      | {txt = "arity"; _ }, 
-        PStr [ { pstr_desc = Pstr_eval 
-                     ( {pexp_desc = Pexp_constant (Const_int i)},_attr);
-                 _}]
-        -> 
-        if i >= 0 then 
-          Some i
-        else None
-      | _ -> None 
-    ) attrs  
-
-
-
-let arity_from_core_type (x : Parsetree.core_type) = 
-  let rec aux acc (x : Parsetree.core_type) = 
-    match x.ptyp_desc with 
-    | Ptyp_arrow (_,_,r) -> 
-      (* 'a -> ('b -> ('c -> 'd )) *)
-      aux (acc + 1) r 
-    | _ -> acc  in 
-  aux 0 x
-
-
-
-let attr_attribute_from_type (x : Parsetree.core_type) : Parsetree.attribute = 
-  let n = arity_from_core_type x in 
-  let loc = x.ptyp_loc in
-  {txt = "arity"; loc},
-  PStr ([ {pstr_desc = 
-             Pstr_eval (lift_int n,[]);
-           pstr_loc = loc
-          }])
-
-

jscomp/syntax/parsetree_util.mli

@@ -33,10 +33,7 @@
     compiling FFI code
  *)
 
-val is_single_string : Parsetree.payload -> string option 
+(* val is_single_string : Parsetree.payload -> string option  *)
 
-val is_string_or_strings : Parsetree.payload -> [ `None | `Single of string | `Some of string list ]
+(* val is_string_or_strings : Parsetree.payload -> [ `None | `Single of string | `Some of string list ] *)
 
-val has_arity : Parsetree.attributes -> int option
-
-val attr_attribute_from_type : Parsetree.core_type -> Parsetree.attribute

jscomp/syntax/syntax.mllib

@@ -1,2 +1,3 @@
 parsetree_util
+ast_payload
 ppx_entry