Merge pull request #4207 from BuckleScript/uniform_nonrecur_handling

bobzhang · web-flow · commit ffe810f73bed · 2020-03-02T16:28:04.000+08:00
uniform nonrecursive handling for bs.deriving
diff --git a/jscomp/main/native_ppx_main.ml b/jscomp/main/native_ppx_main.ml
@@ -66,17 +66,17 @@ let typ_mapper (self : mapper) (typ : Parsetree.core_type) =
 let structure_item_mapper (self : mapper) (str : Parsetree.structure_item) =
   match str.pstr_desc with
   | Pstr_type (
-      _rf,
+      rf,
     (_ :: _ as tdcls )) ->
-      Ast_tdcls.handleTdclsInStru self str tdcls
+      Ast_tdcls.handleTdclsInStru self str rf tdcls
   | _ -> default_str_mapper self str
 
 let signature_item_mapper (self : mapper) (sigi : Parsetree.signature_item) =
   match sigi.psig_desc with
   | Psig_type (
-      _rf,
+      rf,
        (_ :: _ as tdcls)) ->  (*FIXME: check recursive handling*)
-      Ast_tdcls.handleTdclsInSigi self sigi tdcls
+      Ast_tdcls.handleTdclsInSigi self sigi rf tdcls
   | _ -> default_sig_mapper self sigi
 
 let my_mapper : mapper = {
diff --git a/jscomp/syntax/ast_attributes.ml b/jscomp/syntax/ast_attributes.ml
@@ -154,12 +154,11 @@ let has_inline_payload_in_sig (attrs : t)  =
     ) 
 
 type derive_attr = {
-  explict_nonrec : bool;
   bs_deriving : Ast_payload.action list option
-}
+} [@@unboxed]
 
 let process_derive_type (attrs : t) : derive_attr * t =
-  Ext_list.fold_left attrs ({explict_nonrec = false; bs_deriving = None }, []) 
+  Ext_list.fold_left attrs ({bs_deriving = None }, []) 
     (fun (st, acc) ({txt ; loc}, payload  as attr)  ->
       match  st, txt  with
       |  {bs_deriving = None}, "bs.deriving"
@@ -172,10 +171,6 @@ let process_derive_type (attrs : t) : derive_attr * t =
         Bs_syntaxerr.err loc Duplicated_bs_deriving
 
       | _ , _ ->
-        let st =
-          if txt = "nonrec" then
-            { st with explict_nonrec = true }
-          else st in
         st, attr::acc
     ) 
 
diff --git a/jscomp/syntax/ast_attributes.mli b/jscomp/syntax/ast_attributes.mli
@@ -59,9 +59,8 @@ val has_inline_payload_in_sig :
   attr option 
 
 type derive_attr = {
-  explict_nonrec : bool;
   bs_deriving : Ast_payload.action list option
-}
+} [@@unboxed]
 
 
 val iter_process_bs_string_int_unwrap_uncurry :
diff --git a/jscomp/syntax/ast_compatible.ml b/jscomp/syntax/ast_compatible.ml
@@ -196,27 +196,25 @@ let opt_arrow ?(loc=default_loc) ?(attrs=[]) s a b : core_type =
       ptyp_attributes = attrs
   }    
 
-let rec_type_str ?(loc=default_loc)  tds : structure_item = 
+let rec_type_str 
+  ?(loc=default_loc) 
+  rf tds : structure_item = 
   {
     pstr_loc = loc;
     pstr_desc = Pstr_type ( 
-      Recursive,
+      rf,
       tds)
   }
 
-(* let nonrec_type_str ?(loc=default_loc)  tds : structure_item = 
-  {
-    pstr_loc = loc;
-    pstr_desc = Pstr_type ( 
-      Nonrecursive,
-      tds)
-  }   *)
 
-let rec_type_sig ?(loc=default_loc)  tds : signature_item = 
+
+let rec_type_sig 
+  ?(loc=default_loc)
+   rf tds : signature_item = 
   {
     psig_loc = loc;
     psig_desc = Psig_type ( 
-      Recursive,
+      rf,
       tds)
   }
 
diff --git a/jscomp/syntax/ast_compatible.mli b/jscomp/syntax/ast_compatible.mli
@@ -157,6 +157,7 @@ val object_:
 
 val rec_type_str:  
   ?loc:loc -> 
+  Asttypes.rec_flag -> 
   type_declaration list -> 
   structure_item
 
@@ -167,6 +168,7 @@ val rec_type_str:
 
 val rec_type_sig:  
   ?loc:loc -> 
+  Asttypes.rec_flag -> 
   type_declaration list -> 
   signature_item
 
diff --git a/jscomp/syntax/ast_derive.ml b/jscomp/syntax/ast_derive.ml
@@ -25,8 +25,8 @@
 type tdcls = Parsetree.type_declaration list
 
 type gen = {
-  structure_gen : tdcls -> bool -> Ast_structure.t ;
-  signature_gen : tdcls -> bool -> Ast_signature.t ; 
+  structure_gen : tdcls -> Asttypes.rec_flag -> Ast_structure.t ;
+  signature_gen : tdcls -> Asttypes.rec_flag -> Ast_signature.t ; 
   expression_gen : (Parsetree.core_type -> Parsetree.expression) option ; 
 }
 
@@ -58,7 +58,7 @@ let register key value =
 let gen_signature
     tdcls
     (actions :  Ast_payload.action list ) 
-    (explict_nonrec : bool )
+    (explict_nonrec : Asttypes.rec_flag )
   : Ast_signature.t = 
   Ext_list.flat_map actions
     (fun action -> 
@@ -80,7 +80,7 @@ let gen_structure_signature
     loc
     (tdcls : tdcls)   
     (action : Ast_payload.action)
-    (explicit_nonrec : bool) = 
+    (explicit_nonrec : Asttypes.rec_flag) = 
   let derive_table = !derive_table in  
   let u = 
     Ast_payload.table_dispatch derive_table action in  
diff --git a/jscomp/syntax/ast_derive.mli b/jscomp/syntax/ast_derive.mli
@@ -25,8 +25,8 @@
 type tdcls = Parsetree.type_declaration list 
 
 type gen = {
-  structure_gen : tdcls -> bool -> Ast_structure.t ;
-  signature_gen : tdcls -> bool -> Ast_signature.t ; 
+  structure_gen : tdcls -> Asttypes.rec_flag -> Ast_structure.t ;
+  signature_gen : tdcls -> Asttypes.rec_flag -> Ast_signature.t ; 
   expression_gen : (Parsetree.core_type -> Parsetree.expression) option ; 
 }
 
@@ -48,7 +48,7 @@ val register :
 val gen_signature: 
   tdcls ->
   Ast_payload.action list -> 
-  bool -> 
+  Asttypes.rec_flag -> 
   Ast_signature.t
 
 
@@ -63,5 +63,5 @@ val gen_structure_signature :
   Location.t -> 
   Parsetree.type_declaration list ->
   Ast_payload.action -> 
-  bool -> 
+  Asttypes.rec_flag -> 
   Parsetree.structure_item
diff --git a/jscomp/syntax/ast_derive_abstract.ml b/jscomp/syntax/ast_derive_abstract.ml
@@ -197,23 +197,23 @@ let handleTdcl
     (* U.notApplicable tdcl.ptype_loc derivingName;  *)
     tdcl, []
 
-let handleTdclsInStr ~light tdcls =
+let handleTdclsInStr ~light rf tdcls =
   let tdcls, code =
     Ext_list.fold_right tdcls ([],[]) (fun tdcl (tdcls, sts)  ->
         match handleTdcl light tdcl with
           ntdcl, value_descriptions ->
           ntdcl::tdcls,
           Ext_list.map_append value_descriptions sts (fun x -> Str.primitive x) 
       ) in
-Ast_compatible.rec_type_str tdcls :: code
+Ast_compatible.rec_type_str rf tdcls :: code
 (* still need perform transformation for non-abstract type*)
 
-let handleTdclsInSig ~light tdcls =
+let handleTdclsInSig ~light rf tdcls =
   let tdcls, code =
     Ext_list.fold_right tdcls ([],[]) (fun tdcl (tdcls, sts)  ->
         match handleTdcl light tdcl with
           ntdcl, value_descriptions ->
           ntdcl::tdcls,
           Ext_list.map_append value_descriptions sts (fun x -> Sig.value x) 
       ) in
-  Ast_compatible.rec_type_sig tdcls :: code
+  Ast_compatible.rec_type_sig rf tdcls :: code
diff --git a/jscomp/syntax/ast_derive_abstract.mli b/jscomp/syntax/ast_derive_abstract.mli
@@ -37,8 +37,12 @@ val isAbstract :
 
 val handleTdclsInStr : 
   light:bool -> 
-  Parsetree.type_declaration list -> Parsetree.structure
+  Asttypes.rec_flag -> 
+  Parsetree.type_declaration list ->
+  Parsetree.structure
 
 val handleTdclsInSig:  
   light:bool ->
-  Parsetree.type_declaration list -> Parsetree.signature
+  Asttypes.rec_flag -> 
+  Parsetree.type_declaration list ->
+  Parsetree.signature
diff --git a/jscomp/syntax/ast_derive_js_mapper.ml b/jscomp/syntax/ast_derive_js_mapper.ml
@@ -181,7 +181,9 @@ let init () =
                let exp_param = Exp.ident ident_param in 
                let newType,newTdcl =
                  U.new_type_of_type_declaration tdcl ("abs_" ^ name) in 
-               let newTypeStr = Ast_compatible.rec_type_str [newTdcl] in   
+               let newTypeStr = 
+                  (* Abstract type *)
+                  Ast_compatible.rec_type_str Nonrecursive [newTdcl] in   
                let toJsBody body = 
                  Ast_comb.single_non_rec_value patToJs
                    (Ast_compatible.fun_ (Pat.constraint_ (Pat.var pat_param) core_type) 
@@ -428,7 +430,7 @@ let init () =
                   Ast_comb.single_non_rec_val patToJs (Ast_compatible.arrow core_type result) in
                 let newType,newTdcl =
                   U.new_type_of_type_declaration tdcl ("abs_" ^ name) in 
-                let newTypeStr = Ast_compatible.rec_type_sig [newTdcl] in                     
+                let newTypeStr = Ast_compatible.rec_type_sig Nonrecursive [newTdcl] in                     
                 let (+?) v rest = if createType then v :: rest else rest in 
                 match tdcl.ptype_kind with  
                 | Ptype_record label_declarations ->            
diff --git a/jscomp/syntax/ast_tdcls.ml b/jscomp/syntax/ast_tdcls.ml
@@ -72,11 +72,12 @@ let turn_bs_optional_into_optional (tdcls : Parsetree.type_declaration list) =
 let handleTdclsInSigi
     (self : Bs_ast_mapper.mapper)
     (sigi : Parsetree.signature_item)
+    rf 
     (tdcls : Parsetree.type_declaration list)
   : Ast_signature.item =
   begin match Ast_attributes.process_derive_type
                 (Ext_list.last tdcls).ptype_attributes  with
-  | {bs_deriving = Some actions; explict_nonrec}, newAttrs
+  | {bs_deriving = Some actions}, newAttrs
     ->
     let loc = sigi.psig_loc in
     let originalTdclsNewAttrs = newTdcls tdcls newAttrs in (* remove the processed attr*)
@@ -86,7 +87,7 @@ let handleTdclsInSigi
 #if BS_NATIVE_PPX then
       let  codes = Native_ast_derive_abstract.handleTdclsInSig ~light:(kind = Light_abstract) originalTdclsNewAttrs in
 #else
-      let  codes = Ast_derive_abstract.handleTdclsInSig ~light:(kind = Light_abstract) originalTdclsNewAttrs in
+      let  codes = Ast_derive_abstract.handleTdclsInSig ~light:(kind = Light_abstract) rf originalTdclsNewAttrs in
 #end
       Ast_signature.fuseAll ~loc
         (
@@ -98,7 +99,7 @@ let handleTdclsInSigi
 #if BS_NATIVE_PPX then
                          Ast_compatible.rec_type_str ~loc (turn_bs_optional_into_optional newTdclsNewAttrs)
 #else
-                         Ast_compatible.rec_type_str ~loc newTdclsNewAttrs
+                         Ast_compatible.rec_type_str ~loc rf newTdclsNewAttrs
 #end
                          ] )
                      (Mty.signature ~loc [])) ) )
@@ -108,11 +109,11 @@ let handleTdclsInSigi
     else
       Ast_signature.fuseAll ~loc
         ( 
-          Ast_compatible.rec_type_sig ~loc newTdclsNewAttrs
+          Ast_compatible.rec_type_sig ~loc rf newTdclsNewAttrs
         ::
          self.signature
            self
-           (Ast_derive.gen_signature tdcls actions explict_nonrec))
+           (Ast_derive.gen_signature tdcls actions rf))
   | {bs_deriving = None }, _  ->
     Bs_ast_mapper.default_mapper.signature_item self sigi
 
@@ -122,18 +123,18 @@ let handleTdclsInSigi
 let handleTdclsInStru
     (self : Bs_ast_mapper.mapper)
     (str : Parsetree.structure_item)
+    rf
     (tdcls : Parsetree.type_declaration list)
   : Ast_structure.item =
   begin match
       Ast_attributes.process_derive_type
         ((Ext_list.last tdcls).ptype_attributes) with
   | {bs_deriving = Some actions;
-     explict_nonrec
     }, newAttrs ->
     let loc = str.pstr_loc in
     let originalTdclsNewAttrs = newTdcls tdcls newAttrs in
     let newStr : Parsetree.structure_item =
-      Ast_compatible.rec_type_str ~loc (self.type_declaration_list self originalTdclsNewAttrs)
+      Ast_compatible.rec_type_str ~loc rf (self.type_declaration_list self originalTdclsNewAttrs)
     in
     let kind = Ast_derive_abstract.isAbstract actions in 
     if kind <> Not_abstract then
@@ -145,7 +146,7 @@ let handleTdclsInStru
          (self.signature self codes_sig)
 #else
       let codes =
-          Ast_derive_abstract.handleTdclsInStr ~light:(kind = Light_abstract) originalTdclsNewAttrs in
+          Ast_derive_abstract.handleTdclsInStr ~light:(kind = Light_abstract) rf originalTdclsNewAttrs in
       (* use [tdcls2] avoid nonterminating *)
       Ast_structure.fuseAll ~loc
         (
@@ -163,7 +164,7 @@ let handleTdclsInStru
                (fun action ->
                   Ast_derive.gen_structure_signature
                     loc
-                    tdcls action explict_nonrec
+                    tdcls action rf
                )    actions
            ))
   | {bs_deriving = None }, _  ->
diff --git a/jscomp/syntax/ast_tdcls.mli b/jscomp/syntax/ast_tdcls.mli
@@ -26,10 +26,12 @@
 val handleTdclsInSigi :
   Bs_ast_mapper.mapper ->
   Parsetree.signature_item ->
+  Asttypes.rec_flag ->   
   Parsetree.type_declaration list -> Ast_signature.item
 
 
 val handleTdclsInStru :
   Bs_ast_mapper.mapper ->
   Parsetree.structure_item ->
+  Asttypes.rec_flag -> 
   Parsetree.type_declaration list -> Ast_structure.item
diff --git a/jscomp/syntax/bs_builtin_ppx.ml b/jscomp/syntax/bs_builtin_ppx.ml
@@ -211,9 +211,9 @@ let class_type_mapper (self : mapper) ({pcty_attributes; pcty_loc} as ctd : Pars
 let signature_item_mapper (self : mapper) (sigi : Parsetree.signature_item) =        
       match sigi.psig_desc with
       | Psig_type (
-          _rf, 
-           (_ :: _ as tdcls)) ->  (*FIXME: check recursive handling*)
-          Ast_tdcls.handleTdclsInSigi self sigi tdcls
+          rf, 
+          tdcls) ->  
+          Ast_tdcls.handleTdclsInSigi self sigi rf tdcls
       | Psig_value ({pval_attributes; pval_prim} as value_desc)
         
         ->
@@ -279,9 +279,9 @@ let local_module_name =
 let structure_item_mapper (self : mapper) (str : Parsetree.structure_item) =
   match str.pstr_desc with
   | Pstr_type (
-          _rf, (* FIXME *)
-          (_ :: _ as tdcls )) (* [ {ptype_attributes} as tdcl ] *)->
-          Ast_tdcls.handleTdclsInStru self str tdcls
+          rf, 
+          tdcls) (* [ {ptype_attributes} as tdcl ] *)->
+          Ast_tdcls.handleTdclsInStru self str rf tdcls
    | Pstr_primitive prim when Ast_attributes.external_needs_to_be_encoded prim.pval_attributes
       ->
       Ast_external.handleExternalInStru self prim str
diff --git a/jscomp/syntax/native_ast_derive_abstract.ml b/jscomp/syntax/native_ast_derive_abstract.ml
@@ -209,7 +209,7 @@ let code_sig_transform sigi = match sigi with
 #else assert false    
 #end
 
-let handleTdclsInStr ~light tdcls =
+let handleTdclsInStr ~light rf tdcls =
   let tdcls, tdcls_sig, code, code_sig =
     Ext_list.fold_right tdcls ([],[], [], []) (fun tdcl (tdcls, tdcls_sig, sts, code_sig)  ->
         match handleTdcl light tdcl with
@@ -222,11 +222,11 @@ let handleTdclsInStr ~light tdcls =
             Ext_list.map_append value_descriptions code_sig code_sig_transform
           )
       )  in
-  (Ast_compatible.rec_type_str tdcls :: code,
-   Ast_compatible.rec_type_sig tdcls_sig :: code_sig)
+  (Ast_compatible.rec_type_str rf tdcls :: code,
+   Ast_compatible.rec_type_sig rf tdcls_sig :: code_sig)
   (* still need perform transformation for non-abstract type*)
 
-let handleTdclsInSig ~light tdcls =
+let handleTdclsInSig ~light rf tdcls =
   let tdcls_sig, code =
     Ext_list.fold_right tdcls ([], []) (fun tdcl (tdcls_sig, sts)  ->
         match handleTdcl light tdcl with
@@ -237,4 +237,4 @@ let handleTdclsInSig ~light tdcls =
             Ext_list.map_append value_descriptions sts code_sig_transform
           )
       )  in
-   Ast_compatible.rec_type_sig tdcls_sig :: code
+   Ast_compatible.rec_type_sig rf tdcls_sig :: code
diff --git a/lib/4.06.1/unstable/all_ounit_tests.ml b/lib/4.06.1/unstable/all_ounit_tests.ml
diff --git a/lib/4.06.1/unstable/js_compiler.ml b/lib/4.06.1/unstable/js_compiler.ml
diff --git a/lib/4.06.1/unstable/js_refmt_compiler.ml b/lib/4.06.1/unstable/js_refmt_compiler.ml
diff --git a/lib/4.06.1/unstable/native_ppx.ml b/lib/4.06.1/unstable/native_ppx.ml
diff --git a/lib/4.06.1/whole_compiler.ml b/lib/4.06.1/whole_compiler.ml
