Merge pull request #432 from bloomberg/ppx_global_config

[feature] prepare global default configuration

Author: bobzhang

jscomp/syntax/ast_payload.ml

@@ -53,6 +53,25 @@ let as_empty_structure (x : t ) =
   | PStr ([]) -> true
   | PTyp _ | PPat _ | PStr (_ :: _ ) -> false 
 
+
+let as_record_and_process 
+    loc
+    ( x : t ) (action : Longident.t Asttypes.loc * Parsetree.expression -> unit ): unit= 
+  match  x with 
+  | PStr [ {pstr_desc = Pstr_eval
+                ({pexp_desc = Pexp_record (label_exprs, with_obj) ; pexp_loc = loc}, _); 
+            _
+           }]
+    -> 
+    begin match with_obj with
+    | None ->
+      List.iter action label_exprs
+    | Some _ -> 
+      Location.raise_errorf ~loc "with is not supported"
+    end
+  | _ -> 
+    Location.raise_errorf ~loc "this is not a valid record config"
+
 let is_string_or_strings (x : t) : 
   [ `None | `Single of string | `Some of string list ] = 
   let module M = struct exception Not_str end  in 
@@ -83,3 +102,12 @@ let is_string_or_strings (x : t) :
            _},_);
       _}] -> `Single name 
   | _ -> `None
+
+let assert_bool_lit  (e : Parsetree.expression) = 
+  match e.pexp_desc with
+  | Pexp_construct ({txt = Lident "true" }, None)
+    -> true
+  | Pexp_construct ({txt = Lident "false" }, None)
+    -> false 
+  | _ ->
+    Location.raise_errorf ~loc:e.pexp_loc "expect `true` or `false` in this field"

jscomp/syntax/ast_payload.mli

@@ -34,3 +34,8 @@ val as_string_exp : t -> Parsetree.expression option
 val as_empty_structure :  t -> bool 
 val is_string_or_strings : 
   t -> [ `None | `Single of string | `Some of string list ]
+val as_record_and_process : 
+  Location.t ->
+  t -> (Longident.t Asttypes.loc * Parsetree.expression -> unit) -> unit
+
+val assert_bool_lit : Parsetree.expression -> bool

jscomp/syntax/ppx_entry.ml

@@ -76,6 +76,12 @@ let arrow = Ast_helper.Typ.arrow
 
 let record_as_js_object = ref None (* otherwise has an attribute *)
 let obj_type_as_js_obj_type = ref false
+let uncurry_type = ref false 
+let obj_type_auto_uncurry =  ref false
+let non_export = ref false 
+let lift_js_type ~loc  x  = Typ.constr ~loc {txt = js_obj_type_id (); loc} [x]
+let lift_curry_type ~loc x  = Typ.constr ~loc {txt = curry_type_id (); loc} [x]
+
 let handle_record_as_js_object 
     loc 
     attr
@@ -96,10 +102,9 @@ let handle_record_as_js_object
         Typ.var ~loc ("a" ^ string_of_int i))) in 
 
     let result_type =
-      Typ.constr ~loc  {txt =  js_obj_type_id () ; loc}
-        [
-          Typ.object_ ~loc (List.map2 (fun x y -> x ,[], y) labels tyvars) Closed
-        ]
+      lift_js_type ~loc  
+        @@ Typ.object_ ~loc (List.map2 (fun x y -> x ,[], y) labels tyvars) Closed
+
     in 
     List.fold_right2 
       (fun label tyvar acc -> arrow ~loc label tyvar acc) labels tyvars  result_type
@@ -126,8 +131,7 @@ let gen_fn_run loc arity args  : Parsetree.expression_desc =
       Parsetree.Ptyp_tuple tyvars
   in 
   let uncurry_fn = 
-    Typ.constr ~loc {txt = curry_type_id (); loc}
-      [ Typ.mk ~loc tuple_type_desc] in
+    lift_curry_type ~loc @@ Typ.mk ~loc tuple_type_desc in
   (** could be optimized *)
   let pval_type = 
     Ext_list.reduce_from_right (fun a b -> arrow ~loc "" a b) (uncurry_fn :: tyvars) in 
@@ -153,8 +157,7 @@ let gen_fn_mk loc arity args  : Parsetree.expression_desc =
       Parsetree.Ptyp_tuple tyvars
   in 
   let uncurry_fn = 
-    Typ.constr ~loc {txt = curry_type_id (); loc}
-      [Typ.mk ~loc tuple_type_desc]
+    lift_curry_type ~loc @@ Typ.mk ~loc tuple_type_desc
   in 
   let arrow = arrow ~loc "" in
   (** could be optimized *)
@@ -163,10 +166,8 @@ let gen_fn_mk loc arity args  : Parsetree.expression_desc =
       arrow  (arrow  (Ast_literal.type_unit ~loc ()) (List.hd tyvars) ) uncurry_fn
     else 
       arrow (Ext_list.reduce_from_right arrow tyvars) uncurry_fn in 
-  let local_module_name = "Tmp" in 
-  let local_fun_name = "mk" in 
   Ast_comb.create_local_external loc ~pval_prim ~pval_type 
-    ~local_module_name ~local_fun_name args 
+    args 
 
 
 let find_uncurry_attrs_and_remove (attrs : Parsetree.attributes ) = 
@@ -192,10 +193,10 @@ let uncurry_fn_type loc ty attrs
     | v -> 
       Typ.tuple ~loc ~attrs [v ; body]
   in
-  Typ.constr ~loc {txt = curry_type_id () ; loc} [ fn_type]
+  lift_curry_type ~loc fn_type
+
 
 
-let uncurry_type = ref false 
 
 (*
   Attributes are very hard to attribute
@@ -239,27 +240,31 @@ let handle_typ
                     | _ -> false)
                   ptyp_attributes with 
     |  None, None, _  ->
+      let check_auto_uncurry core_type = 
+        if  !obj_type_auto_uncurry then
+          Ext_ref.protect uncurry_type true (fun _ -> self.typ self core_type  )          
+        else self.typ self core_type in 
+  
       let methods = 
         List.map (fun (label, ptyp_attrs, core_type ) -> 
             match find_uncurry_attrs_and_remove ptyp_attrs with 
-            | None, _ -> label, ptyp_attrs , self.typ self core_type
+            | None, _ -> 
+              label, ptyp_attrs , check_auto_uncurry  core_type
             | Some v, ptyp_attrs -> 
-              label , ptyp_attrs, self.typ self 
+              label , ptyp_attrs, 
+              check_auto_uncurry
                 { core_type with ptyp_attributes = v :: core_type.ptyp_attributes}
           ) methods 
       in           
       if !obj_type_as_js_obj_type then 
-        {ptyp_desc = 
-           Ptyp_constr ({ txt = js_obj_type_id () ; loc},
-                        [{ ty with ptyp_desc = Ptyp_object(methods, closed_flag);
-                                   ptyp_attributes }]);
-         ptyp_attributes = [];
-         ptyp_loc = loc }
+        lift_js_type ~loc { ty with ptyp_desc = Ptyp_object(methods, closed_flag);
+                               ptyp_attributes }
+
       else 
         {ty with ptyp_desc = Ptyp_object (methods, closed_flag)}
     | fact1 , fact2,  ptyp_attributes -> 
       let obj_type_as_js_obj_type_cxt =  fact1 <> None || !obj_type_as_js_obj_type in
-      let uncurry_type_cxt  = fact2 <> None || !uncurry_type in 
+      let uncurry_type_cxt  = fact2 <> None || !uncurry_type || !obj_type_auto_uncurry in 
       let methods = 
         Ext_ref.protect2
           obj_type_as_js_obj_type
@@ -287,7 +292,7 @@ let handle_typ
     end
   | _ -> super.typ self ty
 
-let handle_ctyp 
+let handle_class_obj_typ 
     (super : Ast_mapper.mapper) 
     (self : Ast_mapper.mapper)
     (ty : Parsetree.class_type) = 
@@ -301,7 +306,13 @@ let handle_ctyp
       Ext_ref.protect uncurry_type true begin fun () -> 
         self.class_type self  {ty with pcty_attributes = pcty_attributes'} 
       end
-    | None, _ -> super.class_type self ty
+    | None, _ -> 
+      if !obj_type_auto_uncurry then 
+        Ext_ref.protect uncurry_type true begin fun () -> 
+          super.class_type self ty
+        end
+      else 
+        super.class_type self ty
     end
 
 
@@ -374,13 +385,8 @@ let handle_obj_property loc obj name e
     ~pval_prim:"js_unsafe_downgrade"
     ~pval_type:(
       Ast_comb.arrow_no_label ~loc
-        (Typ.constr ~loc 
-           {txt = js_obj_type_id () ; loc} 
-           [var])
-        var)
-        
-    ~local_module_name:"Tmp"
-    ~local_fun_name:"cast" ["", obj] in 
+        (lift_js_type ~loc var) var)
+    ["", obj] in 
   { e with pexp_desc =
      Pexp_send
                ({pexp_desc = down ;
@@ -429,20 +435,12 @@ let handle_obj_method loc (obj : Parsetree.expression)
   let down = Ast_comb.create_local_external loc  
     ~pval_prim:"js_unsafe_downgrade"
     ~pval_type:(Ast_comb.arrow_no_label ~loc
-                  (Typ.constr ~loc {txt = js_obj_type_id () ; loc} [var])
+                  (lift_js_type ~loc var)
                   var )
     ~local_module_name:"Tmp"
     ~local_fun_name:"cast" ["", obj] in 
   {e with pexp_desc = gen_fn_run loc len 
-    (("",
-      {pexp_desc =
-         Pexp_send
-           ({pexp_desc = down ;
-             pexp_loc = loc ;
-             pexp_attributes = []},
-            name);
-       pexp_loc = loc ; 
-       pexp_attributes = [] }) :: 
+    (("", Exp.send ~loc (Exp.mk ~loc down) name) :: 
      List.map (fun x -> "", x) args
     )}
         (** TODO: 
@@ -610,7 +608,7 @@ let rec unsafe_mapper : Ast_mapper.mapper =
         | _ ->  Ast_mapper.default_mapper.expr  mapper e
       );
     typ = (fun self typ -> handle_typ Ast_mapper.default_mapper self typ);
-    class_type = (fun self ctyp -> handle_ctyp Ast_mapper.default_mapper self ctyp);
+    class_type = (fun self ctyp -> handle_class_obj_typ Ast_mapper.default_mapper self ctyp);
     structure_item = (fun mapper (str : Parsetree.structure_item) -> 
         begin match str.pstr_desc with 
         | Pstr_extension ( ({txt = "bs.raw"; loc}, payload), _attrs) 
@@ -635,11 +633,70 @@ let rec unsafe_mapper : Ast_mapper.mapper =
         end
       )
   }
+
+
+let common_actions_table : 
+  (string *  (Parsetree.expression -> unit)) list = 
+  [ "obj_type_auto_uncurry", 
+    (fun e -> 
+       obj_type_auto_uncurry := Ast_payload.assert_bool_lit e
+    )
+  ]
+
+
+let structural_config_table  = 
+  String_map.of_list 
+    (( "non_export" , 
+      (fun e -> non_export := Ast_payload.assert_bool_lit e ))
+      :: common_actions_table)
+
+let signature_config_table = 
+  String_map.of_list common_actions_table
+
+
+let make_call_back table ((x : Longident.t Asttypes.loc) , y) = 
+  match x with 
+  | {txt = Lident name; loc  } -> 
+    begin match String_map.find name table with 
+    | fn -> fn y
+    | exception _ -> Location.raise_errorf ~loc "%s is not supported" name
+    end
+  | {loc} -> 
+    Location.raise_errorf ~loc "invalid label for config"
+
 let rewrite_signature : (Parsetree.signature -> Parsetree.signature) ref = 
   ref (fun  x -> 
-      unsafe_mapper.signature  unsafe_mapper x
+      match (x : Parsetree.signature) with 
+      | {psig_desc = Psig_attribute ({txt = "bs.config"; loc}, payload); _} :: rest 
+        -> 
+        begin 
+          Ast_payload.as_record_and_process loc payload 
+            (make_call_back signature_config_table) ; 
+          unsafe_mapper.signature unsafe_mapper rest
+        end
+      | _ -> 
+        unsafe_mapper.signature  unsafe_mapper x
        )
 
 let rewrite_implementation : (Parsetree.structure -> Parsetree.structure) ref = 
-  ref (fun x -> unsafe_mapper.structure  unsafe_mapper x )
+  ref (fun (x : Parsetree.structure) -> 
+      match x with 
+      | {pstr_desc = Pstr_attribute ({txt = "bs.config"; loc}, payload); _} :: rest 
+        -> 
+        begin 
+          Ast_payload.as_record_and_process loc payload 
+            (make_call_back structural_config_table) ; 
+          let rest = unsafe_mapper.structure unsafe_mapper rest in
+          if !non_export then
+            [Str.include_ ~loc  
+               (Incl.mk ~loc 
+                  (Mod.constraint_ ~loc
+                     (Mod.structure ~loc rest  )
+                     (Mty.signature ~loc [])
+                  ))]
+          else rest 
+
+        end
+      | _ -> 
+        unsafe_mapper.structure  unsafe_mapper x )
 

jscomp/test/.depend

@@ -3,6 +3,7 @@ abstract_type.cmi :
 ari_regress_test.cmi :
 array_test.cmi :
 basic_module_test.cmi :
+config2_test.cmi : ../runtime/js.cmj
 const_block_test.cmi :
 demo_int_map.cmi :
 ext_pervasives.cmi : ../stdlib/int32.cmi ../stdlib/format.cmi
@@ -107,6 +108,10 @@ complex_test.cmj : mt.cmi ../stdlib/complex.cmi
 complex_test.cmx : mt.cmx ../stdlib/complex.cmx
 complex_while_loop.cmj :
 complex_while_loop.cmx :
+config1_test.cmj :
+config1_test.cmx :
+config2_test.cmj : ../runtime/js.cmj config2_test.cmi
+config2_test.cmx : ../runtime/js.cmx config2_test.cmi
 const_block_test.cmj : mt.cmi ../stdlib/array.cmi const_block_test.cmi
 const_block_test.cmx : mt.cmx ../stdlib/array.cmx const_block_test.cmi
 const_defs.cmj :
@@ -761,6 +766,10 @@ complex_test.cmo : mt.cmi ../stdlib/complex.cmi
 complex_test.cmj : mt.cmj ../stdlib/complex.cmj
 complex_while_loop.cmo :
 complex_while_loop.cmj :
+config1_test.cmo :
+config1_test.cmj :
+config2_test.cmo : ../runtime/js.cmo config2_test.cmi
+config2_test.cmj : ../runtime/js.cmj config2_test.cmi
 const_block_test.cmo : mt.cmi ../stdlib/array.cmi const_block_test.cmi
 const_block_test.cmj : mt.cmj ../stdlib/array.cmj const_block_test.cmi
 const_defs.cmo :

jscomp/test/config1_test.ml

@@ -0,0 +1,9 @@
+
+;;[@@@bs.config{
+  obj_type_auto_uncurry = true;
+  non_export = true;
+}]
+;;
+
+
+let a = 3

jscomp/test/config2_test.ml

@@ -0,0 +1,36 @@
+[@@@bs.config{
+  obj_type_auto_uncurry = true;
+  (* non_export = true; *)
+}]
+
+
+
+class type v = object [@uncurry]
+  method hey : int * int -> int 
+end 
+
+class type v2 = object
+  method hey : int * int -> int 
+end 
+
+type vv = 
+  < 
+    hey : int * int -> int 
+  > [@bs.obj] [@uncurry]
+
+type vv2 = 
+  < 
+    hey : int * int -> int 
+  > [@bs.obj] 
+
+
+let hh (x : v) : v2 = x 
+
+let hh2 ( x : vv) : vv2 = x 
+
+
+let test_v (x : v Js.t) = 
+  x##hey(1,2)
+
+let test_vv (h : vv) =
+  h##hey(1,2)