Merge pull request #618 from bloomberg/external_object

bobzhang · web-flow · commit b3d2462945c2 · 2016-08-09T15:21:47.000-04:00
add first class js object support so people can create js object
diff --git a/jscomp/syntax/ast_attributes.ml b/jscomp/syntax/ast_attributes.ml
@@ -101,7 +101,7 @@ let process_attributes_rev (attrs : t) =
         st, attr::acc 
     ) ( `Nothing, []) attrs
 
-let process_class_type_decl_rev attrs = 
+let process_bs attrs = 
   List.fold_left (fun (st, acc) (({txt; loc}, _) as attr : attr) -> 
       match txt, st  with 
       | "bs", _
diff --git a/jscomp/syntax/ast_attributes.mli b/jscomp/syntax/ast_attributes.mli
@@ -35,7 +35,7 @@ val process_method_attributes_rev :
 val process_attributes_rev : 
   t -> [ `Meth_callback | `Nothing | `Uncurry | `Method ] * t 
 
-val process_class_type_decl_rev : 
+val process_bs : 
   t -> [ `Nothing | `Has] * t 
 
 val process_external : t -> bool 
diff --git a/jscomp/syntax/ast_core_type.ml b/jscomp/syntax/ast_core_type.ml
@@ -150,3 +150,6 @@ let from_labels ~loc tyvars (labels : string list)
     (fun label tyvar acc -> Typ.arrow ~loc label tyvar acc) labels tyvars  result_type
 
 
+let make_obj ~loc xs =
+  Ast_comb.to_js_type loc @@
+  Ast_helper.Typ.object_  ~loc xs   Closed
diff --git a/jscomp/syntax/ast_core_type.mli b/jscomp/syntax/ast_core_type.mli
@@ -57,3 +57,7 @@ val string_type : t -> arg_type
 val from_labels :
   loc:Location.t -> t list -> string list -> t
 
+val make_obj :
+  loc:Location.t ->
+  (string * Parsetree.attributes * t) list ->
+  t
diff --git a/jscomp/syntax/ast_exp.ml b/jscomp/syntax/ast_exp.ml
@@ -0,0 +1,25 @@
+(* 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.expression 
diff --git a/jscomp/syntax/ast_exp.mli b/jscomp/syntax/ast_exp.mli
@@ -0,0 +1,25 @@
+(* 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.expression 
diff --git a/jscomp/syntax/ast_external.mli b/jscomp/syntax/ast_external.mli
@@ -29,7 +29,7 @@ val create_local_external : Location.t ->
   pval_type:Parsetree.core_type ->
   ?local_module_name:string ->
   ?local_fun_name:string ->
-  (Asttypes.label * Parsetree.expression) list -> Parsetree.expression_desc
+  (string * Parsetree.expression) list -> Parsetree.expression_desc
 
 val local_extern_cont : 
   Location.t ->
diff --git a/jscomp/syntax/ast_external_attributes.ml b/jscomp/syntax/ast_external_attributes.ml
@@ -433,8 +433,7 @@ let handle_attributes
      | Obj_create arg_labels ,  {ptyp_desc = Ptyp_any; _}
        ->
        let result =
-         Ast_comb.to_js_type loc @@
-         Ast_helper.Typ.object_  ~loc   (
+         Ast_core_type.make_obj ~loc (
          List.fold_right2  (fun arg label acc ->
            match arg, label with
            | (_, ty), Ast_core_type.Label s
@@ -451,7 +450,7 @@ let handle_attributes
                | _ -> assert false                 
              end                 
            | (_, _), Ast_core_type.Empty -> acc                
-           ) arg_types_ty arg_labels []) Closed  in
+           ) arg_types_ty arg_labels [])  in
        Ast_core_type.replace_result type_annotation result 
      | _, _ -> type_annotation) ,
     (match ffi , prim_name with
diff --git a/jscomp/syntax/ast_pat.ml b/jscomp/syntax/ast_pat.ml
@@ -0,0 +1,50 @@
+(* 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.pattern
+
+
+let is_unit_cont ~yes ~no (p : t)  =
+  match p  with
+  | {ppat_desc = Ppat_construct({txt = Lident "()"}, None)}
+    -> yes 
+  | _ -> no
+
+
+(** [arity_of_fun pat e] tells the arity of 
+    expression [fun pat -> e]
+*)
+let arity_of_fun
+    (pat : Parsetree.pattern)
+    (e : Parsetree.expression) =
+  let rec aux (e : Parsetree.expression)  =
+    match e.pexp_desc with
+    | Pexp_fun ("", None, pat, e) ->
+      1 + aux e       
+    | Pexp_fun _
+      -> Location.raise_errorf
+           ~loc:e.pexp_loc "Lable is not allowed in JS object"
+    | _ -> 0 in
+  is_unit_cont ~yes:0 ~no:1 pat + aux e 
diff --git a/jscomp/syntax/ast_pat.mli b/jscomp/syntax/ast_pat.mli
@@ -0,0 +1,31 @@
+(* 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.pattern
+
+val is_unit_cont : yes:'a -> no:'a -> t -> 'a
+
+(** [arity_of_fun pat e] tells the arity of 
+    expression [fun pat -> e]*)
+val arity_of_fun : t -> Parsetree.expression -> int
diff --git a/jscomp/syntax/ast_util.ml b/jscomp/syntax/ast_util.ml
@@ -258,11 +258,12 @@ let generic_to_uncurry_exp kind loc (self : Ast_mapper.mapper)  pat body
   let len = List.length rev_extra_args in 
   let arity = 
     match kind with 
-    | `Fn  ->     
+    | `Fn  ->
       begin match rev_extra_args with 
-        | [ {ppat_desc =
-               ( Ppat_construct ({txt = Lident "()"}, None) )}]
-          -> 0 
+        | [ p]
+          ->
+          Ast_pat.is_unit_cont ~yes:0 ~no:len p           
+
         | _ -> len 
       end
     | `Method_callback -> len  in 
@@ -369,6 +370,131 @@ let handle_raw_structure loc payload =
       Location.raise_errorf ~loc "bs.raw can only be applied to a string"
   end
 
+    
+let ocaml_obj_as_js_object
+    loc (mapper : Ast_mapper.mapper)
+    (self_pat : Parsetree.pattern)
+    (clfs : Parsetree.class_field list) =
+  let self_type_lit = "self_type"   in 
+  (** Attention: we should avoid type variable conflict for each method   *)
+  (* Since the method name is unique, there would be no conflict *)
+  (* Note mapper is only for API compatible *)  
+  let self_type loc = Typ.var ~loc self_type_lit in 
+  let generate_callback_method_pair loc
+      (mapper : Ast_mapper.mapper) method_name arity
+    : (Ast_core_type.t * Ast_core_type.t)  =
+    let result = Typ.var ~loc method_name in   
+    let self_type = self_type loc in  
+    if arity = 0 then
+      to_method_type loc mapper "" (Ast_literal.type_unit ~loc ()) result ,
+      to_method_callback_type loc mapper  "" self_type result      
+    else
+      let tyvars =
+        Ext_list.init arity (fun i -> Typ.var ~loc (method_name ^ string_of_int i))
+      in
+      begin match tyvars with
+        | x :: rest ->
+          let method_rest =
+            List.fold_right (fun v acc -> Typ.arrow ~loc "" v acc)
+              rest result in         
+          (to_method_type loc mapper "" x method_rest,
+           to_method_callback_type loc mapper  "" self_type
+             (Typ.arrow ~loc "" x method_rest))
+        | _ -> assert false
+      end in          
+  let (labels,  label_types, method_types, exprs) =
+    List.fold_right
+      (fun (x  : Parsetree.class_field)
+        (labels,
+         label_types,
+         method_types,
+         exprs) ->
+        match x.pcf_desc with
+        | Pcf_method (
+            label,
+            Public,
+            Cfk_concrete
+              (Fresh, e))
+           ->
+           begin match e.pexp_desc with
+             | Pexp_poly
+                 (({pexp_desc = Pexp_fun ("", None, pat, e)} as f),
+                  None) ->  
+               let arity = Ast_pat.arity_of_fun pat e in
+               let method_type, label_type =
+                 generate_callback_method_pair x.pcf_loc mapper label.txt arity in 
+               (label::labels,
+                label_type::label_types,
+                method_type :: method_types,
+                {f with
+                 pexp_desc =
+                   let f = Ast_pat.is_unit_cont pat ~yes:e ~no:f in                       
+                   to_method_callback loc mapper self_pat f
+                } :: exprs)
+             | Pexp_poly( _, Some _)
+               ->
+               Location.raise_errorf ~loc:x.pcf_loc
+                 "polymorphic type annotation not supported yet"
+               
+             | Pexp_poly (_, None) ->
+               Location.raise_errorf
+                 ~loc:x.pcf_loc
+                 "Unsupported syntax, expect syntax like `method x () = x ` "
+             | _ ->
+               Location.raise_errorf ~loc:x.pcf_loc
+                 "Unsupported syntax in js object"               
+           end
+         | Pcf_method (_, _, Cfk_concrete(Override, _) ) -> 
+           Location.raise_errorf ~loc:x.pcf_loc
+             "override flag not supported"
+       
+         | Pcf_method (_, _, Cfk_virtual _ )
+           ->
+           Location.raise_errorf ~loc:x.pcf_loc
+             "virtural method not supported"
+           
+         | Pcf_method (_, Private,_ )
+           -> (** TODO: support Private *)             
+           Location.raise_errorf ~loc:x.pcf_loc
+             "Private method not supported yet"
+         | Pcf_inherit _ 
+         | Pcf_val _ 
+         | Pcf_initializer _
+         | Pcf_attribute _
+         | Pcf_extension _
+         | Pcf_constraint _ ->
+           Location.raise_errorf
+             ~loc:x.pcf_loc "Only method support currently"
+      ) clfs  ([], [], [],  []) in
+  let result_type =
+    Typ.alias ~loc (Ast_core_type.make_obj  ~loc
+      (List.map2 (fun label method_type ->
+           label.Asttypes.txt , [], method_type           
+         ) labels method_types)) self_type_lit  in      
+  let pval_type =
+    List.fold_right2
+      (fun label label_type acc ->
+         Typ.arrow
+           ~loc:label.Asttypes.loc
+           label.Asttypes.txt
+           label_type acc           
+      ) labels label_types result_type in
+  let pval_attributes = Ast_attributes.bs_obj pval_type in
+  let local_fun_name = "mk" in
+  let pval_type, pval_prim =
+    Ast_external_attributes.handle_attributes_as_string
+      loc
+      local_fun_name      
+      pval_type pval_attributes "" in
+  Ast_external.local_extern_cont
+    loc
+    ~pval_attributes
+    ~pval_prim
+    ~local_fun_name
+    (fun e ->
+       Exp.apply ~loc e
+         (List.map2 (fun l expr -> l.Asttypes.txt, expr) labels exprs) )
+    ~pval_type
 
 let record_as_js_object 
     loc 
diff --git a/jscomp/syntax/ast_util.mli b/jscomp/syntax/ast_util.mli
@@ -118,3 +118,8 @@ val handle_raw :
 
 val handle_raw_structure : 
   loc -> Ast_payload.t -> Parsetree.structure_item
+
+val ocaml_obj_as_js_object :
+  (Parsetree.pattern ->
+   Parsetree.class_field list ->
+   Parsetree.expression_desc) cxt   
diff --git a/jscomp/syntax/ppx_entry.ml b/jscomp/syntax/ppx_entry.ml
@@ -446,13 +446,25 @@ let rec unsafe_mapper : Ast_mapper.mapper =
             }
           else 
             Ast_mapper.default_mapper.expr  self e
+        | Pexp_object {pcstr_self;  pcstr_fields} ->
+          begin match Ast_attributes.process_bs e.pexp_attributes with
+            | `Has, pexp_attributes
+              ->
+              {e with
+               pexp_desc = 
+                 Ast_util.ocaml_obj_as_js_object
+                   loc self pcstr_self pcstr_fields;
+               pexp_attributes               
+              }                          
+            | `Nothing , _ ->
+              Ast_mapper.default_mapper.expr  self e              
+          end            
         | _ ->  Ast_mapper.default_mapper.expr self e
       );
     typ = (fun self typ -> handle_typ Ast_mapper.default_mapper self typ);
     class_type = 
       (fun self ({pcty_attributes} as ctd) -> 
-         match Ast_attributes.process_class_type_decl_rev 
-                 pcty_attributes with 
+         match Ast_attributes.process_bs pcty_attributes with 
          | `Nothing,  _ -> 
            Ast_mapper.default_mapper.class_type
              self ctd 
diff --git a/jscomp/syntax/syntax.mllib b/jscomp/syntax/syntax.mllib
@@ -13,3 +13,5 @@ ast_derive
 ast_signature
 ast_core_type
 ast_external_attributes
+ast_pat
+ast_exp
diff --git a/jscomp/test/.depend b/jscomp/test/.depend
diff --git a/jscomp/test/Makefile b/jscomp/test/Makefile
diff --git a/jscomp/test/ppx_this_obj.js b/jscomp/test/ppx_this_obj.js
diff --git a/jscomp/test/ppx_this_obj_test.js b/jscomp/test/ppx_this_obj_test.js
diff --git a/jscomp/test/ppx_this_obj_test.ml b/jscomp/test/ppx_this_obj_test.ml
diff --git a/jscomp/test/unsafe_obj_external.js b/jscomp/test/unsafe_obj_external.js
diff --git a/jscomp/test/unsafe_obj_external.ml b/jscomp/test/unsafe_obj_external.ml
