upgrade more syntax to 4.06

Author: bobzhang

jscomp/all.depend

@@ -203,13 +203,13 @@ syntax/ast_derive.cmx : ext/string_map.cmx ext/literals.cmx \
 syntax/ast_comb.cmx : ext/ext_list.cmx syntax/ast_literal.cmx \
     syntax/ast_compatible.cmx syntax/ast_comb.cmi
 syntax/ast_core_type.cmx : ext/ext_list.cmx syntax/bs_syntaxerr.cmx \
-    syntax/ast_comb.cmx syntax/ast_core_type.cmi
+    syntax/ast_compatible.cmx syntax/ast_comb.cmx syntax/ast_core_type.cmi
 syntax/bs_ast_invariant.cmx : ext/literals.cmx ext/hash_set_poly.cmx \
     ext/ext_string.cmx common/bs_warnings.cmx syntax/bs_ast_iterator.cmx \
     syntax/ast_core_type.cmx syntax/bs_ast_invariant.cmi
 syntax/ast_attributes.cmx : ext/ext_string.cmx syntax/bs_syntaxerr.cmx \
     syntax/bs_ast_invariant.cmx syntax/ast_payload.cmx \
-    syntax/ast_attributes.cmi
+    syntax/ast_compatible.cmx syntax/ast_attributes.cmi
 syntax/ast_polyvar.cmx : syntax/external_arg_spec.cmx ext/ext_pervasives.cmx \
     ext/ext_list.cmx syntax/bs_syntaxerr.cmx syntax/ast_attributes.cmx \
     syntax/ast_polyvar.cmi
@@ -299,7 +299,7 @@ syntax/bs_ast_mapper.cmi :
 syntax/ast_derive.cmi : syntax/ast_structure.cmi syntax/ast_signature.cmi \
     syntax/ast_payload.cmi
 syntax/ast_comb.cmi :
-syntax/ast_core_type.cmi :
+syntax/ast_core_type.cmi : syntax/ast_compatible.cmi
 syntax/bs_ast_invariant.cmi : syntax/bs_ast_iterator.cmi
 syntax/ast_attributes.cmi : syntax/ast_payload.cmi
 syntax/ast_polyvar.cmi : syntax/external_arg_spec.cmi

jscomp/bin/all_ounit_tests.ml

@@ -14415,6 +14415,30 @@ val arrow :
   core_type -> 
   core_type ->
   core_type
+
+val label_arrow :
+  ?loc:Location.t -> 
+  ?attrs:attrs -> 
+  string -> 
+  core_type -> 
+  core_type ->
+  core_type
+
+val opt_arrow:
+  ?loc:Location.t -> 
+  ?attrs:attrs -> 
+  string -> 
+  core_type -> 
+  core_type ->
+  core_type
+
+val object_: 
+  ?loc:loc -> 
+  ?attrs:attrs ->
+  (string * attributes * core_type) list -> 
+  (*FIXME shall we use [string loc] instead?*)
+  Asttypes.closed_flag ->
+  core_type  
 end = struct
 #1 "ast_compatible.ml"
 (* Copyright (C) 2018 Authors of BuckleScript
@@ -14558,9 +14582,36 @@ let apply_labels
         fn, 
         args ) }
 
+let object_ = Ast_helper.Typ.object_
+
 
 
 
+let label_arrow ?(loc=default_loc) ?(attrs=[]) s a b : core_type = 
+  {
+      ptyp_desc = Ptyp_arrow(
+
+      s
+      
+      ,
+      a,
+      b);
+      ptyp_loc = loc;
+      ptyp_attributes = attrs
+  }
+
+let opt_arrow ?(loc=default_loc) ?(attrs=[]) s a b : core_type = 
+  {
+      ptyp_desc = Ptyp_arrow( 
+
+        "?" ^ s
+        
+        ,
+        a,
+        b);
+      ptyp_loc = loc;
+      ptyp_attributes = attrs
+  }    
 
 let const_exp_int_list_as_array xs = 
   Ast_helper.Exp.array 

jscomp/syntax/ast_attributes.ml

@@ -360,12 +360,9 @@ let bs_get_arity : attr
     PStr 
     [{pstr_desc =
          Pstr_eval (
-           {pexp_desc =
-              Pexp_constant
-                (Const_int 1);
-            pexp_loc = locg;
-            pexp_attributes = []
-           },[])
+          Ast_compatible.const_exp_int ~loc:locg 1
+           ,
+           [])
       ; pstr_loc = locg}]
 
 
@@ -394,10 +391,6 @@ let deprecated s : attr =
     [
       {pstr_desc =
          Pstr_eval (
-           {pexp_desc =
-              Pexp_constant
-                (Const_string (s,None));
-            pexp_loc = locg;
-            pexp_attributes = []
-           },[])
+           Ast_compatible.const_exp_string ~loc:locg s, 
+           [])
       ; pstr_loc = locg}]

jscomp/syntax/ast_compatible.ml

@@ -141,6 +141,21 @@ let apply_labels
         fn, 
         Ext_list.map (fun (l,a) -> Asttypes.Labelled l, a)  args ) }
 
+let object_ 
+  ?(loc= default_loc)
+  ?(attrs = [])
+  (fields : (string * attributes * core_type) list)
+  (* FIXME after upgrade *)
+  flg : core_type = 
+  {
+    ptyp_desc = 
+      Ptyp_object(
+        Ext_list.map (fun (a,b,c) -> 
+          Parsetree.Otag ({txt = a; loc = c.ptyp_loc},b,c)) fields,flg);
+    ptyp_loc = loc;
+    ptyp_attributes = attrs
+  }
+
 #else 
 
 let const_exp_string 
@@ -179,9 +194,40 @@ let apply_labels
         fn, 
         args ) }
 
+let object_ = Ast_helper.Typ.object_
+
 
 #end 
 
+let label_arrow ?(loc=default_loc) ?(attrs=[]) s a b : core_type = 
+  {
+      ptyp_desc = Ptyp_arrow(
+#if OCAML_VERSION =~ ">4.03.0" then 
+      Asttypes.Labelled s
+#else
+      s
+#end      
+      ,
+      a,
+      b);
+      ptyp_loc = loc;
+      ptyp_attributes = attrs
+  }
+
+let opt_arrow ?(loc=default_loc) ?(attrs=[]) s a b : core_type = 
+  {
+      ptyp_desc = Ptyp_arrow( 
+#if OCAML_VERSION =~ ">4.03.0" then 
+        Asttypes.Optional s
+#else
+        "?" ^ s
+#end        
+        ,
+        a,
+        b);
+      ptyp_loc = loc;
+      ptyp_attributes = attrs
+  }    
 
 let const_exp_int_list_as_array xs = 
   Ast_helper.Exp.array 

jscomp/syntax/ast_compatible.mli

@@ -116,4 +116,28 @@ val arrow :
   ?attrs:attrs -> 
   core_type -> 
   core_type ->
-  core_type
+  core_type
+
+val label_arrow :
+  ?loc:Location.t -> 
+  ?attrs:attrs -> 
+  string -> 
+  core_type -> 
+  core_type ->
+  core_type
+
+val opt_arrow:
+  ?loc:Location.t -> 
+  ?attrs:attrs -> 
+  string -> 
+  core_type -> 
+  core_type ->
+  core_type
+
+val object_: 
+  ?loc:loc -> 
+  ?attrs:attrs ->
+  (string * attributes * core_type) list -> 
+  (*FIXME shall we use [string loc] instead?*)
+  Asttypes.closed_flag ->
+  core_type  

jscomp/syntax/ast_core_type.ml

@@ -138,21 +138,20 @@ let from_labels ~loc arity labels
          Typ.var ~loc ("a" ^ string_of_int i)))) in
   let result_type =
     Ast_comb.to_js_type loc
-      (Typ.object_ ~loc
+      (Ast_compatible.object_ ~loc
          (Ext_list.map2 (fun x y -> x.Asttypes.txt ,[], y) labels tyvars) Closed)
   in
   Ext_list.fold_right2
     (fun {Asttypes.loc ; txt = label }
-      tyvar acc -> Typ.arrow ~loc label tyvar acc) labels tyvars  result_type
+      tyvar acc -> Ast_compatible.label_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)
+    (Ast_compatible.object_  ~loc xs Closed)
+
 
 
-let opt_arrow loc label ty1 ty2 =
-  Typ.arrow ~loc ("?" ^ label) ty1 ty2
 (**
 
 {[ 'a . 'a -> 'b ]}
@@ -169,15 +168,19 @@ let rec get_uncurry_arity_aux  (ty : t) acc =
     | _ -> acc
 
 (**
-   {[ unit -> 'a1 -> a2']}  arity 2
    {[ unit -> 'b ]} return arity 0
+   {[ unit -> 'a1 -> a2']} arity 2
    {[ 'a1 -> 'a2 -> ... 'aN -> 'b ]} return arity N
 *)
 let get_uncurry_arity (ty : t ) =
   match ty.ptyp_desc  with
-  | Ptyp_arrow("", {ptyp_desc = (Ptyp_constr ({txt = Lident "unit"}, []))},
-    ({ptyp_desc = Ptyp_arrow _ } as rest  )) -> `Arity (get_uncurry_arity_aux rest 1 )
-  | Ptyp_arrow("", {ptyp_desc = (Ptyp_constr ({txt = Lident "unit"}, []))}, _) -> `Arity 0
+  | Ptyp_arrow(arg_label, {ptyp_desc = (Ptyp_constr ({txt = Lident "unit"}, []))},
+     rest  ) when Ast_compatible.is_arg_label_simple arg_label -> 
+     begin match rest with 
+     | {ptyp_desc = Ptyp_arrow _ } ->  
+      `Arity (get_uncurry_arity_aux rest 1 )
+    | _ -> `Arity 0 
+    end
   | Ptyp_arrow(_,_,rest ) ->
     `Arity(get_uncurry_arity_aux rest 1)
   | _ -> `Not_function

jscomp/syntax/ast_core_type.mli

@@ -32,7 +32,7 @@ val lift_option_type : t -> t
 val is_any : t -> bool
 val replace_result : t -> t -> t
 
-val opt_arrow: Location.t -> string -> t -> t -> t
+(* val opt_arrow: Location.t -> string -> t -> t -> t *)
 
 val is_unit : t -> bool
 val is_array : t -> bool
@@ -82,6 +82,6 @@ val get_uncurry_arity : t -> [`Arity of int | `Not_function ]
 (** fails when Ptyp_poly *)
 val list_of_arrow :
   t ->
-  t *  (Asttypes.label * t * Parsetree.attributes * Location.t) list
+  t *  (Ast_compatible.arg_label * t * Parsetree.attributes * Location.t) list
 
 val is_arity_one : t -> bool

jscomp/syntax/ast_derive_abstract.ml

@@ -94,7 +94,7 @@ let handleTdcl (tdcl : Parsetree.type_declaration) =
           let maker, acc =
             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,
+              (Ast_compatible.opt_arrow ~loc:pld_loc label_name optional_type maker,
               let aux b pld_name = 
                 (Val.mk ~loc:pld_loc
                  (if b then pld_name else 

jscomp/syntax/ast_derive_dyn.ml

@@ -182,6 +182,12 @@ let exp_of_core_type_exprs
 
 let destruct_constructor_declaration 
     ({pcd_name = {txt ;loc}; pcd_args} : Parsetree.constructor_declaration)  = 
+#if OCAML_VERSION =~ ">4.03.0" then
+  let pcd_args = 
+    match pcd_args with 
+    | Pcstr_tuple pcd_args -> pcd_args
+    | Pcstr_record _ -> assert false in 
+#end    
   let last_i, core_type_exprs, pats = 
     List.fold_left (fun (i,core_type_exps, pats) core_type -> 
       let  txt = "a" ^ string_of_int i  in
@@ -279,10 +285,16 @@ let init ()  =
                      if explict_nonrec then 
                        let names, arities = 
                          Ext_list.fold_right 
-                           (fun (ctdcl : Parsetree.constructor_declaration) 
+                           (fun ( {pcd_name = {txt}; pcd_args} : Parsetree.constructor_declaration) 
                              (names,arities) -> 
-                             ctdcl.pcd_name.txt :: names, 
-                             List.length ctdcl.pcd_args :: arities
+#if OCAML_VERSION =~ ">4.03.0" then                               
+                             let pcd_args = 
+                              match pcd_args with 
+                              | Pcstr_tuple pcd_args -> pcd_args 
+                              | Pcstr_record _ -> assert false in 
+#end                              
+                             txt :: names, 
+                             List.length pcd_args :: arities
                            ) cd ([],[]) in 
                        constraint_ 
                          [

jscomp/syntax/ast_derive_js_mapper.ml

@@ -432,7 +432,7 @@ let init () =
 
                   let objType flag =                     
                     Ast_comb.to_js_type loc @@  
-                    Typ.object_
+                    Ast_compatible.object_
                       (List.map 
                          (fun ({pld_name = {loc; txt }; pld_type } : Parsetree.label_declaration) -> 
                             txt, [], pld_type

jscomp/syntax/ast_derive_projector.ml

@@ -7,6 +7,14 @@ let invalid_config (config : Parsetree.expression) =
 
 type tdcls = Parsetree.type_declaration list 
 
+(* #if OCAML_VERSION =~ ">4.03.0" then 
+let constructor_arguments_length (xs : Parsetree.constructor_arguments) = 
+  match xs with 
+  | Pcstr_tuple xs -> List.length xs 
+  | Pcstr_record xs -> List.length xs (* inline record FIXME*) 
+#else
+let constructor_arguments_length = List.length 
+#end *)
 let derivingName = "accessors" 
 let init () =
 
@@ -41,6 +49,12 @@ let init () =
                     ( {pcd_name = {loc ; txt = con_name} ; pcd_args ; pcd_loc }:
                         Parsetree.constructor_declaration)
                     -> (* TODO: add type annotations *)
+#if OCAML_VERSION =~ ">4.03.0" then
+                      let pcd_args = 
+                        match pcd_args with 
+                        | Pcstr_tuple pcd_args -> pcd_args 
+                        | Pcstr_record _ -> assert false in  
+#end                        
                       let little_con_name = Ext_string.uncapitalize_ascii con_name  in
                       let arity = List.length pcd_args in 
                       Ast_comb.single_non_rec_value {loc ; txt = little_con_name}
@@ -106,6 +120,12 @@ let init () =
                   (fun  ({pcd_name = {loc ; txt = con_name} ; pcd_args ; pcd_loc }:
                            Parsetree.constructor_declaration)
                     -> 
+#if OCAML_VERSION =~ ">4.03.0" then                                          
+                      let pcd_args = 
+                        match pcd_args with 
+                        | Pcstr_tuple pcd_args -> pcd_args 
+                        | Pcstr_record _ -> assert false in 
+#end                        
                       Ast_comb.single_non_rec_val {loc ; txt = (Ext_string.uncapitalize_ascii con_name)}
                         (Ext_list.fold_right 
                            (fun x acc -> Ast_compatible.arrow x acc)