Add support for 5.4 bivariant params in type_extension

Signed-off-by: Nathan Rebours <nathan.rebours@ocamlpro.com>

Author: Nathan Rebours

astlib/encoding_504.ml

@@ -390,38 +390,52 @@ module To_503 = struct
     | None, _ -> None
     | Some _, _ -> invalid_encoding ~loc:typ.ptyp_loc "bivariant type parameter"
 
-  let encode_bivariant_pstr_type ~loc rec_flag tds =
+  let encode_bivariant_pstr ~loc pstr_desc =
     let loc = { loc with Location.loc_ghost = true } in
     let ext =
       ( { txt = Ext_name.bivariant_pstr; loc },
-        PStr [ { pstr_loc = loc; pstr_desc = Pstr_type (rec_flag, tds) } ] )
+        PStr [ { pstr_loc = loc; pstr_desc } ] )
     in
     Pstr_extension (ext, [])
 
-  let encode_bivariant_psig_type ~loc rec_flag tds =
+  let encode_bivariant_pstr_type ~loc rec_flag tds =
+    encode_bivariant_pstr ~loc (Pstr_type (rec_flag, tds))
+
+  let encode_bivariant_pstr_typext ~loc te =
+    encode_bivariant_pstr ~loc (Pstr_typext te)
+
+  let encode_bivariant_psig ~loc psig_desc =
     let loc = { loc with Location.loc_ghost = true } in
     let ext =
       ( { txt = Ext_name.bivariant_psig; loc },
-        PSig [ { psig_loc = loc; psig_desc = Psig_type (rec_flag, tds) } ] )
+        PSig [ { psig_loc = loc; psig_desc } ] )
     in
     Psig_extension (ext, [])
 
+  let encode_bivariant_psig_type ~loc rec_flag tds =
+    encode_bivariant_psig ~loc (Psig_type (rec_flag, tds))
+
   let encode_bivariant_psig_typesubst ~loc tds =
-    let loc = { loc with Location.loc_ghost = true } in
-    let ext =
-      ( { txt = Ext_name.bivariant_psig; loc },
-        PSig [ { psig_loc = loc; psig_desc = Psig_typesubst tds } ] )
-    in
-    Psig_extension (ext, [])
+    encode_bivariant_psig ~loc (Psig_typesubst tds)
+
+  let encode_bivariant_psig_typext ~loc te =
+    encode_bivariant_psig ~loc (Psig_typext te)
 
   let decode_bivariant_pstr ~loc payload =
     match payload with
-    | PStr [ { pstr_desc = Pstr_type _ as x; _ } ] -> x
+    | PStr [ { pstr_desc = (Pstr_type _ | Pstr_typext _) as x; _ } ] -> x
     | _ -> invalid_encoding ~loc "bivariant structure_item"
 
   let decode_bivariant_psig ~loc payload =
     match payload with
-    | PSig [ { psig_desc = (Psig_type _ | Psig_typesubst _) as x; _ } ] -> x
+    | PSig
+        [
+          {
+            psig_desc = (Psig_type _ | Psig_typesubst _ | Psig_typext _) as x;
+            _;
+          };
+        ] ->
+        x
     | _ -> invalid_encoding ~loc "bivariant signature_item"
 end
 

astlib/encoding_504.mli

@@ -40,12 +40,18 @@ module To_503 : sig
   val encode_bivariant_pstr_type :
     loc:Location.t -> rec_flag -> type_declaration list -> structure_item_desc
 
+  val encode_bivariant_pstr_typext :
+    loc:Location.t -> type_extension -> structure_item_desc
+
   val encode_bivariant_psig_type :
     loc:Location.t -> rec_flag -> type_declaration list -> signature_item_desc
 
   val encode_bivariant_psig_typesubst :
     loc:Location.t -> type_declaration list -> signature_item_desc
 
+  val encode_bivariant_psig_typext :
+    loc:Location.t -> type_extension -> signature_item_desc
+
   val decode_bivariant_pstr : loc:Location.t -> payload -> structure_item_desc
   val decode_bivariant_psig : loc:Location.t -> payload -> signature_item_desc
 end

astlib/migrate_503_504.ml

@@ -1140,14 +1140,7 @@ and copy_type_extension :
   {
     Ast_504.Parsetree.ptyext_path =
       copy_loc (copy_Longident_t ~loc:ptyext_path.loc) ptyext_path;
-    Ast_504.Parsetree.ptyext_params =
-      List.map
-        (fun x ->
-          let x0, x1 = x in
-          ( copy_core_type x0,
-            let x0, x1 = x1 in
-            (copy_variance x0, copy_injectivity x1) ))
-        ptyext_params;
+    Ast_504.Parsetree.ptyext_params = copy_type_params ptyext_params;
     Ast_504.Parsetree.ptyext_constructors =
       List.map copy_extension_constructor ptyext_constructors;
     Ast_504.Parsetree.ptyext_private = copy_private_flag ptyext_private;

astlib/migrate_504_503.ml

@@ -5,6 +5,7 @@ module To = Ast_503
 module Bivariant_param = struct
   type exn +=
     | T
+    | Type_ext of Ast_503.Parsetree.type_extension
     | Type_decl of Ast_503.Parsetree.type_declaration
     | Type_decl_list of Ast_503.Parsetree.type_declaration list
 
@@ -558,8 +559,11 @@ and copy_structure_item_desc_with_loc ~loc :
       | tds -> Ast_503.Parsetree.Pstr_type (rec_flag, tds)
       | exception Bivariant_param.Type_decl_list tds ->
           Encoding_504.To_503.encode_bivariant_pstr_type ~loc rec_flag tds)
-  | Ast_504.Parsetree.Pstr_typext x0 ->
-      Ast_503.Parsetree.Pstr_typext (copy_type_extension x0)
+  | Ast_504.Parsetree.Pstr_typext x0 -> (
+      match copy_type_extension x0 with
+      | ty_ext -> Ast_503.Parsetree.Pstr_typext ty_ext
+      | exception Bivariant_param.Type_ext ty_ext ->
+          Encoding_504.To_503.encode_bivariant_pstr_typext ~loc ty_ext)
   | Ast_504.Parsetree.Pstr_exception x0 ->
       Ast_503.Parsetree.Pstr_exception (copy_type_exception x0)
   | Ast_504.Parsetree.Pstr_module x0 ->
@@ -843,8 +847,11 @@ and copy_signature_item_desc_with_loc ~loc :
       | tds -> Ast_503.Parsetree.Psig_typesubst tds
       | exception Bivariant_param.Type_decl_list tds ->
           Encoding_504.To_503.encode_bivariant_psig_typesubst ~loc tds)
-  | Ast_504.Parsetree.Psig_typext x0 ->
-      Ast_503.Parsetree.Psig_typext (copy_type_extension x0)
+  | Ast_504.Parsetree.Psig_typext x0 -> (
+      match copy_type_extension x0 with
+      | ty_ext -> Ast_503.Parsetree.Psig_typext ty_ext
+      | exception Bivariant_param.Type_ext ty_ext ->
+          Encoding_504.To_503.encode_bivariant_psig_typext ~loc ty_ext)
   | Ast_504.Parsetree.Psig_exception x0 ->
       Ast_503.Parsetree.Psig_exception (copy_type_exception x0)
   | Ast_504.Parsetree.Psig_module x0 ->
@@ -1125,22 +1132,19 @@ and copy_type_extension :
        Ast_504.Parsetree.ptyext_loc;
        Ast_504.Parsetree.ptyext_attributes;
      } ->
-  {
-    Ast_503.Parsetree.ptyext_path = copy_loc copy_Longident_t ptyext_path;
-    Ast_503.Parsetree.ptyext_params =
-      List.map
-        (fun x ->
-          let x0, x1 = x in
-          ( copy_core_type x0,
-            let x0, x1 = x1 in
-            (copy_variance x0, copy_injectivity x1) ))
-        ptyext_params;
-    Ast_503.Parsetree.ptyext_constructors =
-      List.map copy_extension_constructor ptyext_constructors;
-    Ast_503.Parsetree.ptyext_private = copy_private_flag ptyext_private;
-    Ast_503.Parsetree.ptyext_loc = copy_location ptyext_loc;
-    Ast_503.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes;
-  }
+  let params, contains_bivariant = copy_type_params ptyext_params in
+  let te =
+    {
+      Ast_503.Parsetree.ptyext_path = copy_loc copy_Longident_t ptyext_path;
+      Ast_503.Parsetree.ptyext_params = params;
+      Ast_503.Parsetree.ptyext_constructors =
+        List.map copy_extension_constructor ptyext_constructors;
+      Ast_503.Parsetree.ptyext_private = copy_private_flag ptyext_private;
+      Ast_503.Parsetree.ptyext_loc = copy_location ptyext_loc;
+      Ast_503.Parsetree.ptyext_attributes = copy_attributes ptyext_attributes;
+    }
+  in
+  if contains_bivariant then raise (Bivariant_param.Type_ext te) else te
 
 and copy_extension_constructor :
     Ast_504.Parsetree.extension_constructor ->

test/encoding/504/migrations/run.t

@@ -47,26 +47,36 @@ We also check that bivariant type parameters are correctly encoded and migrated:
 
   $ cat > bivariant.ml << EOF
   > type +-'a t = A
+  > type +-'a extensible += B
   > EOF
 
   $ ./id_driver.exe bivariant.ml
   [%%ppxlib.migration.bivariant_str_item_5_4 type 'a t =
                                                | A ]
+  [%%ppxlib.migration.bivariant_str_item_5_4 type 'a extensible +=  
+                                               | B ]
 
   $ ./id_driver.exe bivariant.ml --use-compiler-pp
   type +-'a t =
     | A 
+  type +-'a extensible +=  
+    | B 
 Bivariant are also correctly handled in a signature context:
 
   $ cat > bivariant.mli << EOF
   > type +-'a t
   > type +-'a u := 'a v
+  > type +-'a extensible += B
   > EOF
 
   $ ./id_driver.exe bivariant.mli
   [%%ppxlib.migration.bivariant_sig_item_5_4 : type 'a t]
   [%%ppxlib.migration.bivariant_sig_item_5_4 : type 'a u := 'a v]
+  [%%ppxlib.migration.bivariant_sig_item_5_4 : type 'a extensible +=  
+                                                 | B ]
 
   $ ./id_driver.exe bivariant.mli --use-compiler-pp
   type +-'a t
   type +-'a u := 'a v
+  type +-'a extensible +=  
+    | B