Remove class type processing from compiler ppx.

CHANGELOG.md

@@ -49,6 +49,7 @@ These are only breaking changes for unformatted code.
 - Syntax: process uncurried function declarations explicitly in the parser/printer https://github.com/rescript-lang/rescript-compiler/pull/5794
 - PPX V4: allow uncurried `make` function and treat it like a curried one [#5802](https://github.com/rescript-lang/rescript-compiler/pull/5802) [#5808](https://github.com/rescript-lang/rescript-compiler/pull/5808) [#5812](https://github.com/rescript-lang/rescript-compiler/pull/5812)
 - Remove processing of objects expressions, which don't exist in `.res` syntax (`Pexp_object`) https://github.com/rescript-lang/rescript-compiler/pull/5841
+- Remove class type processing from compiler ppx https://github.com/rescript-lang/rescript-compiler/pull/5842
 
 # 10.1.0-rc.6
 

jscomp/frontend/ast_core_type_class_type.ml

@@ -56,60 +56,6 @@ let process_getter_setter ~not_getter_setter
           pctf_attributes
         :: get_acc
 
-let handle_class_type_field self
-    ({ pctf_loc = loc } as ctf : Parsetree.class_type_field) acc =
-  match ctf.pctf_desc with
-  | Pctf_method (name, private_flag, virtual_flag, ty) ->
-      let not_getter_setter (ty : Parsetree.core_type) =
-        let ty =
-          match ty.ptyp_desc with
-          | Ptyp_arrow (label, args, body) ->
-              Ast_typ_uncurry.to_method_type ty.ptyp_loc self label args body
-          | Ptyp_poly
-              (strs, { ptyp_desc = Ptyp_arrow (label, args, body); ptyp_loc })
-            ->
-              {
-                ty with
-                ptyp_desc =
-                  Ptyp_poly
-                    ( strs,
-                      Ast_typ_uncurry.to_method_type ptyp_loc self label args
-                        body );
-              }
-          | _ -> self.typ self ty
-        in
-        {
-          ctf with
-          pctf_desc = Pctf_method (name, private_flag, virtual_flag, ty);
-        }
-      in
-      let get ty name pctf_attributes =
-        {
-          ctf with
-          pctf_desc =
-            Pctf_method (name, private_flag, virtual_flag, self.typ self ty);
-          pctf_attributes;
-        }
-      in
-      let set ty name pctf_attributes =
-        {
-          ctf with
-          pctf_desc =
-            Pctf_method
-              ( name,
-                private_flag,
-                virtual_flag,
-                Ast_typ_uncurry.to_method_type loc self Nolabel ty
-                  (Ast_literal.type_unit ~loc ()) );
-          pctf_attributes;
-        }
-      in
-      process_getter_setter ~not_getter_setter ~get ~set loc name
-        ctf.pctf_attributes ty acc
-  | Pctf_inherit _ | Pctf_val _ | Pctf_constraint _ | Pctf_attribute _
-  | Pctf_extension _ ->
-      Bs_ast_mapper.default_mapper.class_type_field self ctf :: acc
-
 let default_typ_mapper = Bs_ast_mapper.default_mapper.typ
 (*
   Attributes are very hard to attribute
@@ -191,6 +137,3 @@ let typ_mapper (self : Bs_ast_mapper.mapper) (ty : Parsetree.core_type) =
       in
       { ty with ptyp_desc = Ptyp_object (new_methods, closed_flag) }
   | _ -> default_typ_mapper self ty
-
-let handle_class_type_fields self fields =
-  Ext_list.fold_right fields [] (handle_class_type_field self)

jscomp/frontend/ast_core_type_class_type.mli

@@ -22,10 +22,5 @@
  * along with this program; if not, write to the Free Software
  * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
 
-val handle_class_type_fields :
-  Bs_ast_mapper.mapper ->
-  Parsetree.class_type_field list ->
-  Parsetree.class_type_field list
-
 val typ_mapper :
   Bs_ast_mapper.mapper -> Parsetree.core_type -> Parsetree.core_type

jscomp/frontend/bs_builtin_ppx.ml

@@ -238,42 +238,6 @@ let expr_mapper ~async_context ~in_function_def (self : mapper)
 let typ_mapper (self : mapper) (typ : Parsetree.core_type) =
   Ast_core_type_class_type.typ_mapper self typ
 
-let class_type_mapper (self : mapper)
-    ({ pcty_attributes; pcty_loc } as ctd : Parsetree.class_type) =
-  let pcty_attributes =
-    match Ast_attributes.process_bs pcty_attributes with
-    | false, _ -> pcty_attributes
-    | true, pcty_attributes ->
-        Location.prerr_warning pcty_loc
-          (Bs_ffi_warning "Here @bs attribute is not needed any more.");
-        pcty_attributes
-  in
-  match ctd.pcty_desc with
-  | Pcty_signature { pcsig_self; pcsig_fields } ->
-      let pcsig_self = self.typ self pcsig_self in
-      {
-        ctd with
-        pcty_desc =
-          Pcty_signature
-            {
-              pcsig_self;
-              pcsig_fields =
-                Ast_core_type_class_type.handle_class_type_fields self
-                  pcsig_fields;
-            };
-        pcty_attributes;
-      }
-  | Pcty_open _ (* let open M in CT *) | Pcty_constr _ | Pcty_extension _
-  | Pcty_arrow _ ->
-      default_mapper.class_type self ctd
-(* {[class x : int -> object
-     end [@bs]
-   ]}
-           Actually this is not going to happpen as below is an invalid syntax
-   {[class type x = int -> object
-       end[@bs]]}
-*)
-
 let signature_item_mapper (self : mapper) (sigi : Parsetree.signature_item) :
     Parsetree.signature_item =
   match sigi.psig_desc with
@@ -544,7 +508,6 @@ let mapper : mapper =
     expr = expr_mapper ~async_context:(ref false) ~in_function_def:(ref false);
     pat = pat_mapper;
     typ = typ_mapper;
-    class_type = class_type_mapper;
     signature_item = signature_item_mapper;
     value_bindings = Ast_tuple_pattern_flatten.value_bindings_mapper;
     structure_item = structure_item_mapper;

jscomp/test/class_type_ffi_test.js

@@ -2,30 +2,6 @@
 
 var Curry = require("../../lib/js/curry.js");
 
-function sum_float_array(arr) {
-  var v = 0;
-  for(var i = 0 ,i_finish = arr.length; i < i_finish; ++i){
-    v = v + arr.case(i);
-  }
-  return v;
-}
-
-function sum_int_array(arr) {
-  var v = 0;
-  for(var i = 0 ,i_finish = arr.length; i < i_finish; ++i){
-    v = v + arr.case(i) | 0;
-  }
-  return v;
-}
-
-function sum_poly(zero, add, arr) {
-  var v = zero;
-  for(var i = 0 ,i_finish = arr.length; i < i_finish; ++i){
-    v = add(v, arr.case(i));
-  }
-  return v;
-}
-
 function test_set(x) {
   x.length = 3;
 }
@@ -66,9 +42,6 @@ function mk_f(param) {
   };
 }
 
-exports.sum_float_array = sum_float_array;
-exports.sum_int_array = sum_int_array;
-exports.sum_poly = sum_poly;
 exports.test_set = test_set;
 exports.f = f;
 exports.ff = ff;

jscomp/test/class_type_ffi_test.ml

@@ -1,43 +1,8 @@
 
-class type ['k,'v] arrayLike = 
-  object 
-    method case : 'k -> 'v Js.Null.t 
-    method caseSet : 'k * 'v -> unit 
-    method case__unsafe : 'k -> 'v 
-    method length : int 
-  end
 
-class type floatArray = [int, float] arrayLike
-(** here we can see [@bs] is really attached to `object end` instead of `class type` *)
 
 
 
-class type intArray = [int, int] arrayLike
-
-
-let sum_float_array (arr : floatArray ) = 
-  let v = ref 0. in
-  for i = 0 to arr##length - 1 do 
-    v := !v +. arr##case__unsafe i     
-  done;
-  !v 
-
-let sum_int_array (arr : intArray ) = 
-  let v = ref 0 in
-  for i = 0 to arr##length - 1 do 
-    v := !v + arr## case__unsafe i     
-  done;
-  !v 
-
-(* TODO: warning about unprocessed attributes *)
-let sum_poly zero add (arr : _ arrayLike ) = 
-  let v = ref zero in 
-  for i = 0 to arr##length - 1 do 
-    v := add  !v  (arr##case__unsafe i ) [@bs] 
-  done;
-  !v 
-
-
 (* TODO: create a special type 
    ['a Js.prop_set] for better error message
 *)