Merge pull request #2783 from BuckleScript/arity_infer

lift function limitation in bs.deriving abstract, fix #2776

Author: bobzhang

jscomp/all.depend

@@ -221,6 +221,7 @@ syntax/external_process.cmx : common/lam_methname.cmx \
     syntax/ast_core_type.cmx syntax/ast_comb.cmx syntax/ast_attributes.cmx \
     syntax/external_process.cmi
 syntax/ast_derive_abstract.cmx : syntax/external_process.cmx \
+    syntax/external_ffi_types.cmx syntax/external_arg_spec.cmx \
     ext/ext_list.cmx syntax/ast_literal.cmx syntax/ast_derive_util.cmx \
     syntax/ast_core_type.cmx syntax/ast_attributes.cmx \
     syntax/ast_derive_abstract.cmi

jscomp/bin/all_ounit_tests.ml

@@ -4155,13 +4155,13 @@ external ff :
     OUnit.assert_bool __LOC__
     (Ext_string.contain_substring should_err.stderr "contravariant")
   end;
-  __LOC__ >:: begin fun _ ->
+  (* __LOC__ >:: begin fun _ ->
     let should_err = bsc_check_eval {|
     type 'a t = {k : int -> 'a } [@@bs.deriving abstract]
     |} in
     OUnit.assert_bool __LOC__
     (Ext_string.contain_substring should_err.stderr "not allowed")
-  end
+  end *)
     (* __LOC__ >:: begin fun _ ->  *)
     (*   let should_infer = perform_bsc [| "-i"; "-bs-eval"|] {| *)
     (*      let  f = fun [@bs] x -> let (a,b) = x in a + b  *)

jscomp/bsb/bsb_templates.ml

@@ -549,15 +549,12 @@ let root = OCamlRes.Res.([
         \      \"You've clicked this \" ++ string_of_int(self.state.count) ++ \" times(s)\";\n\
         \    <div>\n\
         \      <button onClick=(_event => self.send(Click))>\n\
-        \        (ReasonReact.stringToElement(message))\n\
+        \        (ReasonReact.string(message))\n\
         \      </button>\n\
         \      <button onClick=(_event => self.send(Toggle))>\n\
-        \        (ReasonReact.stringToElement(\"Toggle greeting\"))\n\
+        \        (ReasonReact.string(\"Toggle greeting\"))\n\
         \      </button>\n\
-        \      (\n\
-        \        self.state.show ?\n\
-        \          ReasonReact.stringToElement(greeting) : ReasonReact.nullElement\n\
-        \      )\n\
+        \      (self.state.show ? ReasonReact.string(greeting) : ReasonReact.null)\n\
         \    </div>;\n\
         \  },\n\
          };\n\
@@ -583,7 +580,7 @@ let root = OCamlRes.Res.([
         \  ...component,\n\
         \  render: self =>\n\
         \    <div onClick=(self.handle(handleClick))>\n\
-        \      (ReasonReact.stringToElement(message))\n\
+        \      (ReasonReact.string(message))\n\
         \    </div>,\n\
          };\n\
          ")]) ;
@@ -598,6 +595,7 @@ let root = OCamlRes.Res.([
        # in another tab\n\
        npm run webpack\n\
        ```\n\
+       \n\
        After you see the webpack compilation succeed (the `npm run webpack` step), open up `src/index.html` (**no server needed!**). Then modify whichever `.re` file in `src` and refresh the page to see the changes.\n\
        \n\
        **For more elaborate ReasonReact examples**, please see https://github.com/reasonml-community/reason-react-example\n\
@@ -633,7 +631,7 @@ let root = OCamlRes.Res.([
       \  \"dependencies\": {\n\
       \    \"react\": \"^16.2.0\",\n\
       \    \"react-dom\": \"^16.2.0\",\n\
-      \    \"reason-react\": \">=0.3.4\"\n\
+      \    \"reason-react\": \">=0.4.0\"\n\
       \  },\n\
       \  \"devDependencies\": {\n\
       \    \"bs-platform\": \"^${bsb:bs-version}\",\n\
@@ -665,10 +663,7 @@ let root = OCamlRes.Res.([
       \  \"bs-dependencies\": [\n\
       \    \"reason-react\"\n\
       \  ],\n\
-      \  \"refmt\": 3,\n\
-      \  \"warnings\": {\n\
-      \    \"error\": \"+5\"\n\
-      \  }\n\
+      \  \"refmt\": 3\n\
        }\n\
        ") ;
     File  (".gitignore",

jscomp/ounit_tests/ounit_cmd_tests.ml

@@ -243,13 +243,13 @@ external ff :
     OUnit.assert_bool __LOC__
     (Ext_string.contain_substring should_err.stderr "contravariant")
   end;
-  __LOC__ >:: begin fun _ ->
+  (* __LOC__ >:: begin fun _ ->
     let should_err = bsc_check_eval {|
     type 'a t = {k : int -> 'a } [@@bs.deriving abstract]
     |} in
     OUnit.assert_bool __LOC__
     (Ext_string.contain_substring should_err.stderr "not allowed")
-  end
+  end *)
     (* __LOC__ >:: begin fun _ ->  *)
     (*   let should_infer = perform_bsc [| "-i"; "-bs-eval"|] {| *)
     (*      let  f = fun [@bs] x -> let (a,b) = x in a + b  *)

jscomp/syntax/ast_attributes.ml

@@ -190,7 +190,38 @@ let iter_process_derive_type attrs =
   !st
 
 
-let process_bs_string_int_unwrap_uncurry attrs =
+(* duplicated [bs.uncurry] [bs.string] not allowed,
+  it is worse in bs.uncurry since it will introduce
+  inconsistency in arity
+ *)  
+let iter_process_bs_string_int_unwrap_uncurry attrs =
+  let st = ref `Nothing in 
+  let assign v (({loc;_}, _ ) as attr : attr) = 
+    if !st = `Nothing then 
+    begin 
+      Bs_ast_invariant.mark_used_bs_attribute attr;
+      st := v ;
+    end  
+    else Bs_syntaxerr.err loc Conflict_attributes  in 
+  List.iter
+    (fun (({txt ; loc}, (payload : _ ) ) as attr : attr)  ->
+      match  txt with
+      | "bs.string"
+        -> assign `String attr
+      | "bs.int"
+        -> assign `Int attr
+      | "bs.ignore"
+        -> assign `Ignore attr
+      | "bs.unwrap"
+        -> assign `Unwrap attr
+      | "bs.uncurry"
+        ->
+        assign (`Uncurry (Ast_payload.is_single_int payload)) attr
+      | _ -> ()
+    ) attrs;
+    !st 
+
+(* let process_bs_string_int_unwrap_uncurry attrs =
   List.fold_left
     (fun (st,attrs)
       (({txt ; loc}, (payload : _ ) ) as attr : attr)  ->
@@ -216,7 +247,7 @@ let process_bs_string_int_unwrap_uncurry attrs =
         ->
         Bs_syntaxerr.err loc Conflict_attributes
       | _ , _ -> st, (attr :: attrs )
-    ) (`Nothing, []) attrs
+    ) (`Nothing, []) attrs *)
 
 
 let iter_process_bs_string_as  (attrs : t) : string option =
@@ -327,6 +358,20 @@ let bs_obj : attr
 let bs_get : attr
   =  {txt = "bs.get"; loc = locg}, Ast_payload.empty
 
+let bs_get_arity : attr
+  =  {txt = "internal.arity"; loc = locg}, 
+    PStr 
+    [{pstr_desc =
+         Pstr_eval (
+           {pexp_desc =
+              Pexp_constant
+                (Const_int 1);
+            pexp_loc = locg;
+            pexp_attributes = []
+           },[])
+      ; pstr_loc = locg}]
+  
+
 let bs_set : attr
   =  {txt = "bs.set"; loc = locg}, Ast_payload.empty
 

jscomp/syntax/ast_attributes.mli

@@ -46,8 +46,11 @@ type derive_attr = {
   explict_nonrec : bool;
   bs_deriving : Ast_payload.action list option
 }
-val process_bs_string_int_unwrap_uncurry :
-  t -> [`Nothing | `String | `Int | `Ignore | `Unwrap | `Uncurry of int option ]  * t
+
+
+val iter_process_bs_string_int_unwrap_uncurry :
+  t -> 
+  [`Nothing | `String | `Int | `Ignore | `Unwrap | `Uncurry of int option ]
 
 
 val iter_process_bs_string_as :
@@ -82,5 +85,6 @@ val bs_obj : attr
 
 
 val bs_get : attr
+val bs_get_arity : attr 
 val bs_set : attr
 val bs_return_undefined : attr

jscomp/syntax/ast_derive_abstract.ml

@@ -34,31 +34,15 @@ let handle_config (config : Parsetree.expression option) =
     U.invalid_config config
   | None -> ()
 
-(* see #2337
-   TODO: relax it to allow (int -> int [@bs])
-*)
-let rec checkNotFunciton (ty : Parsetree.core_type) =
-  match ty.ptyp_desc with
-  | Ptyp_poly (_,ty) -> checkNotFunciton ty
-  | Ptyp_alias (ty,_) -> checkNotFunciton ty
-  | Ptyp_arrow _ ->
-    Location.raise_errorf
-      ~loc:ty.ptyp_loc
-      "syntactic function type is not allowed when working with abstract bs.deriving, create a named type as work around"
-  | Ptyp_any
-  | Ptyp_var _
-  | Ptyp_tuple _
-  | Ptyp_constr _
-  | Ptyp_object _
-  | Ptyp_class _
-  | Ptyp_variant _
-  | Ptyp_package _
-  | Ptyp_extension _ -> ()
 
 
 let get_optional_attrs =
   [Ast_attributes.bs_get; Ast_attributes.bs_return_undefined]
-let get_attrs = [ Ast_attributes.bs_get ]
+(** For this attributes, its type was wrapped as an option,
+   so we can still reuse existing frame work
+*)  
+
+let get_attrs = [ Ast_attributes.bs_get_arity]
 let set_attrs = [Ast_attributes.bs_set]
 let handleTdcl (tdcl : Parsetree.type_declaration) =
   let core_type = U.core_type_of_type_declaration tdcl in
@@ -88,31 +72,38 @@ let handleTdcl (tdcl : Parsetree.type_declaration) =
             pld_loc
            }:
              Parsetree.label_declaration) (acc, maker, labels) ->
-          let () = checkNotFunciton pld_type in
-          (* TODO: explain why *)
-          let prim, newLabel =
+          let prim_as_name, newLabel =
             match Ast_attributes.iter_process_bs_string_as pld_attributes with
             | None ->
-              [label_name], pld_name
+              label_name, pld_name
             | Some new_name ->
-              [new_name], {pld_name with txt = new_name}
+              new_name, {pld_name with txt = new_name}
           in
-          let is_option = Ast_attributes.has_bs_optional pld_attributes in
-          let maker, getter_type =
-            if is_option then
+          let prim = [prim_as_name] in 
+          let is_optional = Ast_attributes.has_bs_optional pld_attributes in
+          let maker, getter_declaration =
+            if is_optional then
               let optional_type = Ast_core_type.lift_option_type pld_type in
-              Ast_core_type.opt_arrow pld_loc label_name optional_type maker,
-              Typ.arrow ~loc "" core_type optional_type
+              (Ast_core_type.opt_arrow pld_loc label_name optional_type maker,
+              Val.mk pld_name 
+                ~attrs:get_optional_attrs ~prim
+                (Typ.arrow ~loc "" core_type optional_type)
+                )
             else
               Typ.arrow ~loc:pld_loc label_name pld_type maker,
-               Typ.arrow ~loc "" core_type pld_type
+              Val.mk pld_name ~attrs:get_attrs
+              ~prim:(
+                ["" ; (* Not needed actually*)
+                External_ffi_types.to_string 
+                (Ffi_bs (
+                  [{arg_type = Nothing; arg_label = External_arg_spec.empty_label}],
+                  Return_identity,
+                  Js_get {js_get_name = prim_as_name; js_get_scopes = []}
+                  ))] )
+               (Typ.arrow ~loc "" core_type pld_type)
           in
           let acc =
-            Val.mk pld_name
-              ~attrs:(
-                if is_option then get_optional_attrs
-                else get_attrs)
-              ~prim getter_type :: acc in
+           getter_declaration :: acc in
           let is_current_field_mutable = pld_mutable = Mutable in
           let acc =
             if is_current_field_mutable then
@@ -130,7 +121,7 @@ let handleTdcl (tdcl : Parsetree.type_declaration) =
             else acc in
           acc,
           maker,
-          (is_option, newLabel)::labels
+          (is_optional, newLabel)::labels
         ) label_declarations
         ([],
          (if has_optional_field then