infer the type for external _ bs.obj

jscomp/syntax/ast_comb.ml

@@ -65,6 +65,16 @@ let tuple_type_pair ?loc kind arity =
 
 
 
+let js_obj_type_id () = 
+  if Js_config.is_browser () then
+    Ast_literal.Lid.pervasives_js_obj
+  else Ast_literal.Lid.js_obj 
 
+let to_js_type loc  x  = 
+  Typ.constr ~loc {txt = js_obj_type_id (); loc} [x]
 
+let to_js_undefined_type loc x =
+  Typ.constr ~loc
+    {txt = Ast_literal.Lid.js_undefined ; loc}
+    [x]  
 

jscomp/syntax/ast_comb.mli

@@ -53,3 +53,10 @@ val tuple_type_pair :
   [< `Make | `Run ] ->
   int -> Parsetree.core_type * Parsetree.core_type list * Parsetree.core_type
 
+val to_js_type :
+  Location.t -> Parsetree.core_type -> Parsetree.core_type
+
+
+(** TODO: make it work for browser too *)
+val to_js_undefined_type :
+  Location.t -> Parsetree.core_type -> Parsetree.core_type  

jscomp/syntax/ast_core_type.ml

@@ -23,7 +23,7 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
 type t = Parsetree.core_type 
-
+open Ast_helper
 (** TODO check the polymorphic *)
 let list_of_arrow (ty : t) = 
   let rec aux (ty : Parsetree.core_type) acc = 
@@ -124,3 +124,19 @@ let string_type (ty : t) =
 
     | `Nothing -> `Nothing
 
+
+
+let from_labels ~loc tyvars (labels : string list)
+  : t = 
+  let result_type =
+    Ast_comb.to_js_type loc  
+     (Typ.object_ ~loc (List.map2 (fun x y -> x ,[], y) labels tyvars) Closed)
+  in 
+  List.fold_right2 
+    (fun label tyvar acc -> Typ.arrow ~loc label tyvar acc) labels tyvars  result_type
+
+
+type arg_label =
+  [ `Label of string | `Optional of string | `Empty]
+
+

jscomp/syntax/ast_core_type.mli

@@ -43,3 +43,10 @@ val string_type : t ->
     `NonNullString of (int * string) list |
     `NullString of (int * string) list  |
     `Nothing ]
+
+(** return a function type *)
+val from_labels :
+  loc:Location.t -> t list -> string list -> t
+
+type arg_label =
+  [ `Label of string | `Optional of string | `Empty]

jscomp/syntax/ast_external_attributes.ml

@@ -56,8 +56,9 @@ type arg_type =
   | `Unit
   | `Nothing
   ]
-type arg_label =
-  [ `Label of string | `Optional of string | `Empty]
+
+type arg_label = Ast_core_type.arg_label
+
 type arg_kind = 
   {
     arg_type : arg_type;
@@ -195,7 +196,8 @@ let handle_attributes
     | Some _ as val_name ->  val_name
     | None -> Some prim_name_or_pval_prim
     in 
-    let result_type, arg_types = Ast_core_type.list_of_arrow type_annotation in
+    let result_type_ty, arg_types_ty =
+      Ast_core_type.list_of_arrow type_annotation in
     let st = 
       List.fold_left 
         (fun st
@@ -213,7 +215,7 @@ let handle_attributes
 
             begin match txt with 
               | "bs.val" ->  
-                begin match arg_types with 
+                begin match arg_types_ty with 
                 | [] -> 
                   {st with val_name = name_from_payload_or_prim payload}
                 | _ -> 
@@ -261,8 +263,8 @@ let handle_attributes
       List.map (fun (label, ty) -> 
           { arg_label = Ast_core_type.label_name label ;
             arg_type =  aux ty 
-          }) arg_types in
-    let result_type = aux result_type in 
+          }) arg_types_ty in
+    let result_type = aux result_type_ty in 
     let ffi = 
       match st with 
       | {mk_obj = true} -> 
@@ -429,7 +431,22 @@ let handle_attributes
         -> Location.raise_errorf ~loc "conflict attributes found"
       | _ ->  Location.raise_errorf ~loc "Illegal attribute found"  in
     check_ffi ~loc ffi;
-    type_annotation,
+    (match ffi, result_type_ty with
+     | Obj_create arg_labels ,  {ptyp_desc = Ptyp_any; _}
+       ->
+       let result =
+         Ast_comb.to_js_type loc @@
+         Ast_helper.Typ.object_  ~loc   (
+         List.fold_right2  (fun arg label acc ->
+           match arg, label with
+           | (_, ty), `Label s
+             -> (s , [], ty) :: acc                 
+           | (_, ty), `Optional s
+             ->  (s, [], Ast_comb.to_js_undefined_type loc ty) :: acc
+           | (_, _), `Empty -> acc                
+           ) arg_types_ty arg_labels []) Closed  in
+       Ast_core_type.replace_result type_annotation result 
+     | _, _ -> type_annotation) ,
     (match ffi , prim_name with
     | Obj_create _ , _ -> prim_name
     | _ , "" -> pval_prim

jscomp/syntax/ast_external_attributes.mli

@@ -53,8 +53,8 @@ type arg_type =
   | `Unit
   | `Nothing
   ]
-type arg_label =
-  [ `Label of string | `Optional of string | `Empty]
+type arg_label = Ast_core_type.arg_label 
+
 type arg_kind = 
   {
     arg_type : arg_type;

jscomp/syntax/ast_literal.ml

@@ -24,6 +24,7 @@
 
 open Ast_helper
 
+let pervasives = "Pervasives"
 module Lid = struct 
   type t = Longident.t 
   let val_unit : t = Lident "()"
@@ -35,25 +36,33 @@ module Lid = struct
 
 
   let js_fn = Longident.Ldot (Lident "Js", "fn")
-  let pervasives_fn = Longident.Ldot (Lident "Pervasives", "js_fn")
+  let pervasives_fn = Longident.Ldot (Lident pervasives, "js_fn")
 
   let js_meth = Longident.Ldot (Lident "Js", "meth")
-  let pervasives_meth = Longident.Ldot (Lident "Pervasives", "js_meth")
+  let pervasives_meth = Longident.Ldot (Lident pervasives, "js_meth")
 
 
   let js_meth_callback = Longident.Ldot (Lident "Js", "meth_callback")
-  let pervasives_meth_callback = Longident.Ldot (Lident "Pervasives", "js_meth_callback")
+  let pervasives_meth_callback = Longident.Ldot (Lident pervasives, "js_meth_callback")
 
   let js_obj = Longident.Ldot (Lident "Js", "t") 
-  let pervasives_js_obj = Longident.Ldot (Lident "Pervasives", "js_t") 
+  let pervasives_js_obj = Longident.Ldot (Lident pervasives, "js_t") 
 
-  let ignore_id = Longident.Ldot (Lident "Pervasives", "ignore")
+  let ignore_id = Longident.Ldot (Lident pervasives, "ignore")
 
   let js_null  = Longident.Ldot (Lident "Js", "null")
   let js_undefined = Longident.Ldot (Lident "Js", "undefined")
   let js_null_undefined = Longident.Ldot (Lident "Js", "null_undefined")
 
-  let pervasives_re_id = Longident.Ldot (Lident "Pervasives", "js_re")
+  let pervasives_js_null =
+    Longident.Ldot (Lident pervasives, "js_null")
+  let pervasives_js_undefined =
+    Longident.Ldot (Lident pervasives, "js_undefined")
+
+  let pervasives_js_null_undefined =
+    Longident.Ldot (Lident pervasives, "null_undefined")
+
+  let pervasives_re_id = Longident.Ldot (Lident pervasives, "js_re")
   let js_re_id = Longident.Ldot (Lident "Js_re", "t")
 
   let js_unsafe = Longident.Lident "Js_unsafe"

jscomp/syntax/ast_literal.mli

@@ -45,6 +45,8 @@ module Lid : sig
   val js_undefined : t
   val js_null_undefined : t 
 
+  val pervasives_js_undefined : t
+
   val pervasives_re_id : t 
   val js_re_id : t 
 

jscomp/syntax/ast_util.ml

@@ -36,10 +36,6 @@ type uncurry_type_gen =
    Parsetree.core_type ->
    Parsetree.core_type  ->
    Parsetree.core_type) cxt
-let js_obj_type_id () = 
-  if Js_config.is_browser () then
-    Ast_literal.Lid.pervasives_js_obj
-  else Ast_literal.Lid.js_obj 
 
 let uncurry_type_id () = 
   if Js_config.is_browser () then 
@@ -103,8 +99,6 @@ let lift_js_method_callback loc
 *)
 
 
-let to_js_type loc  x  = 
-  Typ.constr ~loc {txt = js_obj_type_id (); loc} [x]
 
 let arrow = Typ.arrow
 
@@ -114,7 +108,7 @@ let js_property loc obj name =
   let downgrade ~loc () = 
     let var = Typ.var ~loc "a" in 
     Ast_comb.arrow_no_label ~loc
-      (to_js_type loc var) var
+      (Ast_comb.to_js_type loc var) var
   in
   Ast_external.local_extern_cont loc  
     ~pval_prim:[Literals.js_unsafe_downgrade] 
@@ -305,16 +299,6 @@ let to_uncurry_fn   =
 let to_method_callback  = 
   generic_to_uncurry_exp `Method_callback 
 
-let from_labels ~loc (labels : Asttypes.label list) : Parsetree.core_type = 
-  let arity = List.length labels in 
-  let tyvars = (Ext_list.init arity (fun i ->      
-      Typ.var ~loc ("a" ^ string_of_int i))) in 
-  let result_type =
-    to_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
 
 let handle_debugger loc payload = 
   if Ast_payload.as_empty_structure payload then
@@ -411,6 +395,7 @@ let handle_raw_structure loc payload =
       Location.raise_errorf ~loc "bs.raw can only be applied to a string"
   end
 
+
 let record_as_js_object 
     loc 
     (self : Ast_mapper.mapper)
@@ -419,12 +404,16 @@ let record_as_js_object
   let labels, args = 
     Ext_list.split_map (fun ({Location.txt ; loc}, e) -> 
         match txt with
-        | Longident.Lident x -> (x, (x, self.expr self e))
+        | Longident.Lident x ->
+          (x, (x, self.expr self e))
         | Ldot _ | Lapply _ ->  
           Location.raise_errorf ~loc "invalid js label "
   ) label_exprs in 
+  let arity = List.length labels in 
+  let tyvars = (Ext_list.init arity (fun i ->      
+      Typ.var ~loc ("a" ^ string_of_int i))) in 
 
-  let pval_type = from_labels ~loc labels in 
+  let pval_type = Ast_core_type.from_labels ~loc tyvars labels in 
   let pval_attributes = Ast_attributes.bs_obj pval_type in 
   let local_fun_name = "mk" in
   let pval_type, pval_prim = 

jscomp/syntax/ast_util.mli

@@ -97,8 +97,6 @@ val to_method_type : uncurry_type_gen
 *)
 val to_method_callback_type : uncurry_type_gen
 
-val to_js_type : 
-  loc -> Parsetree.core_type -> Parsetree.core_type
 
 
 

jscomp/syntax/ppx_entry.ml

@@ -267,7 +267,7 @@ let handle_typ
         with ptyp_desc = Ptyp_object(methods, closed_flag);
              ptyp_attributes } in 
     if !obj_type_as_js_obj_type then 
-      Ast_util.to_js_type loc inner_type          
+      Ast_comb.to_js_type loc inner_type          
     else inner_type
   | _ -> super.typ self ty
 

jscomp/test/.depend

@@ -11,6 +11,7 @@ ext_pervasives.cmi : ../stdlib/int32.cmi ../stdlib/format.cmi
 ext_sys.cmi :
 float_record.cmi :
 gpr_405_test.cmi :
+infer_type_test.cmi : ../runtime/js.cmj
 inline_edge_cases.cmi :
 inline_map_test.cmi :
 js_dyn.cmi :
@@ -279,8 +280,8 @@ http_types.cmj : ../runtime/js.cmj
 http_types.cmx : ../runtime/js.cmx
 ignore_test.cmj : mt.cmi ../runtime/js.cmj
 ignore_test.cmx : mt.cmx ../runtime/js.cmx
-infer_type_test.cmj :
-infer_type_test.cmx :
+infer_type_test.cmj : ../runtime/js.cmj infer_type_test.cmi
+infer_type_test.cmx : ../runtime/js.cmx infer_type_test.cmi
 inline_edge_cases.cmj : inline_edge_cases.cmi
 inline_edge_cases.cmx : inline_edge_cases.cmi
 inline_map2_test.cmj : mt.cmi ../stdlib/list.cmi
@@ -1017,8 +1018,8 @@ http_types.cmo : ../runtime/js.cmo
 http_types.cmj : ../runtime/js.cmj
 ignore_test.cmo : mt.cmi ../runtime/js.cmo
 ignore_test.cmj : mt.cmj ../runtime/js.cmj
-infer_type_test.cmo :
-infer_type_test.cmj :
+infer_type_test.cmo : ../runtime/js.cmo infer_type_test.cmi
+infer_type_test.cmj : ../runtime/js.cmj infer_type_test.cmi
 inline_edge_cases.cmo : inline_edge_cases.cmi
 inline_edge_cases.cmj : inline_edge_cases.cmi
 inline_map2_test.cmo : mt.cmi ../stdlib/list.cmi

jscomp/test/infer_type_test.js

@@ -6,8 +6,7 @@ var hh = {
   lo: 20
 };
 
-var v = hh.width;
+hh.width;
 
 exports.hh = hh;
-exports.v  = v;
 /* hh Not a pure module */

jscomp/test/infer_type_test.ml

@@ -4,7 +4,10 @@ external mk_config :
   hi:int -> lo:int -> ?width:int -> unit -> _  =
   "" [@@bs.obj]
 
-
+type hh =  < hi : int; lo : int; width : int option Js.undefined > Js.t
 let hh = mk_config ~hi:30 ~lo:20 ()
 
-let v = hh##width
+(* let v = hh##widt *)
+let v = hh##width    
+
+

jscomp/test/infer_type_test.mli

@@ -0,0 +1,6 @@
+external mk_config :
+  hi:int -> lo:int -> ?width:int -> unit -> _  =
+  "" [@@bs.obj]
+
+type hh =  < hi : int; lo : int; width : int option Js.undefined > Js.t
+val hh : hh