support string, int and customization

jscomp/js_exp_make.ml

@@ -1190,22 +1190,19 @@ let rec int32_band ?comment (e1 : J.expression) (e2 : J.expression) : J.expressi
 (* TODO -- alpha conversion 
     remember to add parens..
 *)
-let of_block ?comment block e : t = 
+let of_block ?comment ?e block : t = 
   call ~info:Js_call_info.ml_full_call
     {
       comment ;
       expression_desc = 
-        Fun (false, [], (block @ [{J.statement_desc = Return {return_value = e } ;
-                            comment}]) , Js_fun_env.empty 0)
-    } []
-
-(** TODO: merge with [of_block] *)
-let of_block_only ?comment block : t = 
-  call ~info:Js_call_info.ml_full_call
-    {
-      comment ;
-      expression_desc = 
-        Fun (false, [], block  , Js_fun_env.empty 0)
+        Fun (false, [], 
+             begin match e with 
+               | None -> block 
+               | Some e -> 
+                 block @ [{J.statement_desc = Return {return_value = e } ;
+                           comment}]
+             end
+            , Js_fun_env.empty 0)
     } []
 
 let is_nil ?comment x = triple_equal ?comment x nil 

jscomp/js_exp_make.mli

@@ -267,9 +267,8 @@ val is_instance_array  : unary_op
 val dummy_obj : ?comment:string ->  unit -> t 
 
 (** convert a block to expresion by using IIFE *)    
-val of_block : ?comment:string -> J.statement list -> J.expression -> t
-val of_block_only : 
-  ?comment:string -> J.block -> t
+val of_block : ?comment:string -> ?e:J.expression -> J.statement list -> t
+
 val bind : binary_op
 
 val raw_js_code : ?comment:string -> J.code_info ->  string -> t

jscomp/js_of_lam_variant.ml

@@ -30,10 +30,23 @@ let eval (arg : J.expression) (dispatches : (int * string) list ) =
   | Number (Int {i} | Uint i) -> 
     E.str (List.assoc (Int32.to_int i) dispatches)
   | _ ->  
-    E.of_block_only 
+    E.of_block
       [(S.int_switch arg
       (List.map (fun (i,r) -> 
               {J.case = i ; 
                body = [S.return (E.str r)],
                       false (* FIXME: if true, still print break*)
               }) dispatches))]
+
+let eval_as_int (arg : J.expression) (dispatches : (int * int) list ) = 
+  match arg.expression_desc with
+  | Number (Int {i} | Uint i) -> 
+    E.int (Int32.of_int (List.assoc (Int32.to_int i) dispatches))
+  | _ ->  
+    E.of_block
+      [(S.int_switch arg
+      (List.map (fun (i,r) -> 
+              {J.case = i ; 
+               body = [S.return (E.int (Int32.of_int  r))],
+                      false (* FIXME: if true, still print break*)
+              }) dispatches))]

jscomp/js_of_lam_variant.mli

@@ -23,3 +23,4 @@
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
 val eval : J.expression -> (int * string) list -> J.expression
+val eval_as_int : J.expression -> (int * int) list -> J.expression

jscomp/lam_compile.ml

@@ -1310,7 +1310,7 @@ and
          let e = 
            match block with
            | [] -> e 
-           | _ -> E.of_block block e  in
+           | _ -> E.of_block block ~e  in
          let block = 
            [
              S.while_

jscomp/lam_compile_external_call.ml

@@ -65,9 +65,12 @@ let ocaml_to_js last
     else  assert false
   else if Ast_core_type.is_unit ty then [] (* ignore unit *)
   else match Ast_core_type.string_type ty with 
-  | Some dispatches -> 
+  | `String dispatches -> 
     [Js_of_lam_variant.eval arg dispatches]
-  | None  -> 
+  | `Int dispatches -> 
+    [Js_of_lam_variant.eval_as_int arg dispatches]
+
+  | `Nothing  -> 
     match Ast_core_type.label_name label with 
     | `Optional label -> [Js_of_lam_option.get_default_undefined arg]
     | `Label _ | `Empty ->  [arg]  

jscomp/syntax/ast_attributes.ml

@@ -155,19 +155,54 @@ let process_derive_type attrs =
     ) ( {explict_nonrec = false; bs_deriving = `Nothing }, []) attrs
 
 
-let process_bs_name attrs = 
+
+let process_bs_string_int attrs = 
+  List.fold_left 
+    (fun st
+      (({txt ; loc}, payload ): attr)  ->
+      match  txt, st  with
+      | "bs.string", (`Nothing | `String)
+        -> `String
+      | "bs.int", (`Nothing | `Int)
+        ->  `Int
+      | "bs.int", _
+      | "bs.string", _
+        -> 
+        Location.raise_errorf ~loc "conflict attributes "
+      | _ , _ -> st 
+    ) `Nothing attrs
+
+let process_bs_string_as  attrs = 
   List.fold_left 
     (fun st
       (({txt ; loc}, payload ): attr)  ->
       match  txt, st  with
-      | "bs.name", None
+      | "bs.as", None
         ->
         begin match Ast_payload.is_single_string payload with 
-        | None -> 
-          Location.raise_errorf ~loc "expect string literal "
-        | Some _ as v->  v 
+          | None -> 
+            Location.raise_errorf ~loc "expect string literal "
+          | Some  _ as v->  v  
+        end
+      | "bs.as",  _ 
+        -> 
+          Location.raise_errorf ~loc "duplicated bs.name "
+      | _ , _ -> st 
+    ) None attrs
+
+let process_bs_int_as  attrs = 
+  List.fold_left 
+    (fun st
+      (({txt ; loc}, payload ): attr)  ->
+      match  txt, st  with
+      | "bs.as", None
+        ->
+        begin match Ast_payload.is_single_int payload with 
+          | None -> 
+            Location.raise_errorf ~loc "expect string literal "
+          | Some  _ as v->  v  
         end
-      | "bs.name", Some _ 
+      | "bs.as",  _ 
         -> 
           Location.raise_errorf ~loc "duplicated bs.name "
       | _ , _ -> st 

jscomp/syntax/ast_attributes.mli

@@ -44,7 +44,15 @@ type derive_attr = {
   explict_nonrec : bool;
   bs_deriving : [`Has_deriving of Ast_payload.action list | `Nothing ]
 }
-val process_bs_name : t -> string option
+val process_bs_string_int : 
+  t -> [`Nothing | `String | `Int] 
+
+val process_bs_string_as :
+  t -> string option 
+val process_bs_int_as : 
+  t -> int option 
+
+
 val process_derive_type : 
   t -> derive_attr * t 
 

jscomp/syntax/ast_core_type.ml

@@ -57,22 +57,45 @@ let label_name l =
 let string_type (ty : t) = 
   match ty with 
   | {ptyp_desc; ptyp_attributes; ptyp_loc = loc} -> 
-    if List.exists (fun ({Location.txt;_}, _) -> txt = "bs.stringify" ) ptyp_attributes
-    then 
-      match ptyp_desc with 
+    match Ast_attributes.process_bs_string_int ptyp_attributes with 
+    | `String  -> 
+      begin match ptyp_desc with 
       | Ptyp_variant ( row_fields, Closed, None)
         -> 
-        Some 
+        `String
           (List.map (function 
           | Parsetree.Rtag (label, attrs, true,  [])
             -> 
             let name = 
-              match Ast_attributes.process_bs_name attrs with 
+              match Ast_attributes.process_bs_string_as attrs with 
               | Some name -> name 
               | None -> label in
             Btype.hash_variant label, name
           | _ -> Location.raise_errorf ~loc "Not a valid string type"
           ) row_fields)
       | _ -> Location.raise_errorf ~loc "Not a valid string type"
-    else 
-      None 
+      end
+    | `Int  -> 
+      begin match ptyp_desc with 
+      | Ptyp_variant ( row_fields, Closed, None)
+        -> 
+        let _, acc = 
+          (List.fold_left 
+             (fun (i,acc) rtag -> 
+                match rtag with 
+                | Parsetree.Rtag (label, attrs, true,  [])
+                  -> 
+                  let name = 
+                    match Ast_attributes.process_bs_int_as attrs with 
+                    | Some name -> name 
+                    | None -> i in
+                  name + 1, ((Btype.hash_variant label , name):: acc )
+                | _ -> Location.raise_errorf ~loc "Not a valid string type"
+             ) (0, []) row_fields) in 
+        `Int (List.rev acc)
+
+      | _ -> Location.raise_errorf ~loc "Not a valid string type"
+      end
+
+    | `Nothing -> `Nothing
+

jscomp/syntax/ast_core_type.mli

@@ -37,4 +37,7 @@ val is_array : t -> bool
 val label_name : string -> [ `Label of string | `Optional of string  | `Empty]
 
 
-val string_type : t -> (int * string) list option
+val string_type : t -> 
+  [ `Int of (int * int) list |
+    `String of (int * string) list |
+    `Nothing ]

jscomp/syntax/ast_payload.ml

@@ -36,6 +36,18 @@ let is_single_string (x : t ) =
       _}] -> Some name
   | _  -> None
 
+let is_single_int (x : t ) = 
+  match x with  (** TODO also need detect empty phrase case *)
+  | PStr [ {
+      pstr_desc =  
+        Pstr_eval (
+          {pexp_desc = 
+             Pexp_constant 
+               (Const_int name);
+           _},_);
+      _}] -> Some name
+  | _  -> None
+
 let as_string_exp (x : t ) = 
   match x with  (** TODO also need detect empty phrase case *)
   | PStr [ {

jscomp/syntax/ast_payload.mli

@@ -34,6 +34,8 @@ type action =
    lid * Parsetree.expression option 
 
 val is_single_string : t -> string option
+val is_single_int : t -> int option 
+
 val as_string_exp : t -> Parsetree.expression option 
 val as_empty_structure :  t -> bool 
 val is_string_or_strings : 

jscomp/test/.depend

@@ -17,6 +17,7 @@ map_test.cmi :
 mt.cmi :
 mt_global.cmi : mt.cmi
 ocaml_proto_test.cmi :
+poly_variant_test.cmi :
 polymorphism_test.cmi :
 scanf_reference_error_regression_test.cmi :
 simple_derive_test.cmi : ../others/js_dyn.cmi
@@ -415,8 +416,8 @@ offset.cmj : ../stdlib/string.cmi ../stdlib/set.cmi
 offset.cmx : ../stdlib/string.cmx ../stdlib/set.cmx
 optional_ffi_test.cmj : mt.cmi
 optional_ffi_test.cmx : mt.cmx
-poly_variant_test.cmj :
-poly_variant_test.cmx :
+poly_variant_test.cmj : poly_variant_test.cmi
+poly_variant_test.cmx : poly_variant_test.cmi
 polymorphism_test.cmj : polymorphism_test.cmi
 polymorphism_test.cmx : polymorphism_test.cmi
 ppx_apply_test.cmj : mt.cmi
@@ -1149,8 +1150,8 @@ offset.cmo : ../stdlib/string.cmi ../stdlib/set.cmi
 offset.cmj : ../stdlib/string.cmj ../stdlib/set.cmj
 optional_ffi_test.cmo : mt.cmi
 optional_ffi_test.cmj : mt.cmj
-poly_variant_test.cmo :
-poly_variant_test.cmj :
+poly_variant_test.cmo : poly_variant_test.cmi
+poly_variant_test.cmj : poly_variant_test.cmi
 polymorphism_test.cmo : polymorphism_test.cmi
 polymorphism_test.cmj : polymorphism_test.cmi
 ppx_apply_test.cmo : mt.cmi

jscomp/test/poly_variant_test.js

@@ -1,37 +1,42 @@
 'use strict';
 
 
-function u() {
-  return hey("on_open");
-}
 
-function v() {
-  return hey("on_closed");
+function hey_string (option){
+  switch(option){
+  case "on_closed" : return 1 ;
+  case "on_open" : return 2 ; 
+  case "in" : return 3;
+  default : throw Error ("impossible")
+ }
 }
+function hey_int (option){
+  switch (option){
+   case 0 : return 1;
+   case 3 : return 3;
+   case 4 : return 4;
+   default : throw Error("impossible")
+  }
+ }
 
-function ff(h) {
-  return hey(function () {
-                switch (h) {
-                  case 119688204 : 
-                      return "on_closed";
-                  case -2798038 : 
-                      return "on_open";
-                  case 5246170 : 
-                      return "in";
-
-                }
-              }());
-}
+;
 
-function xx() {
-  return hey("in");
-}
+var uu = /* int array */[
+  hey_string("on_open"),
+  hey_string("on_closed"),
+  hey_string("in")
+];
+
+var vv = /* int array */[
+  hey_int(3),
+  hey_int(0),
+  hey_int(4)
+];
+
+hey_string("on_closed");
 
-var option = /* on_closed */119688204;
+hey_string("in");
 
-exports.u      = u;
-exports.option = option;
-exports.v      = v;
-exports.ff     = ff;
-exports.xx     = xx;
-/* No side effect */
+exports.uu = uu;
+exports.vv = vv;
+/*  Not a pure module */