Add support for 5.4 bivariant type parameters in type declaration

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

Author: Nathan Rebours

astlib/encoding_504.ml

@@ -1,7 +1,11 @@
+open Stdlib0
+
 module Ext_name = struct
   let ptyp_labeled_tuple = "ppxlib.migration.ptyp_labeled_tuple_504"
   let pexp_labeled_tuple = "ppxlib.migration.pexp_labeled_tuple_504"
   let ppat_labeled_tuple = "ppxlib.migration.ppat_labeled_tuple_504"
+  let bivariant_param = "ppxlib.migration.bivariant_param_504"
+  let bivariant_pstr = "ppxlib.migration.bivariant_str_item_504"
 end
 
 let invalid_encoding ~loc name =
@@ -197,7 +201,7 @@ module Make (X : AST) = struct
     | None -> invalid_encoding ~loc Ext_name.ppat_labeled_tuple
 end
 
-module Ast_503 = struct
+module Ast_503_arg = struct
   include Ast_503.Asttypes
   include Ast_503.Parsetree
 
@@ -277,7 +281,7 @@ module Ast_503 = struct
   end
 end
 
-module Ast_502 = struct
+module Ast_502_arg = struct
   include Ast_502.Asttypes
   include Ast_502.Parsetree
 
@@ -358,9 +362,52 @@ module Ast_502 = struct
 end
 
 module To_503 = struct
-  include Make (Ast_503)
+  include Make (Ast_503_arg)
+
+  open Ast_503.Asttypes
+  open Ast_503.Parsetree
+
+  let encode_bivariant_param typ inj =
+    let loc = {typ.ptyp_loc with Location.loc_ghost = true} in
+    let attr =
+      { attr_name = {txt = Ext_name.bivariant_param; loc}
+      ; attr_payload = PStr []
+      ; attr_loc = loc
+      }
+    in
+    ({typ with ptyp_attributes = attr::typ.ptyp_attributes}, (NoVariance, inj))
+
+  let decode_bivariant_param (typ, (var, inj)) =
+    let ptyp_attributes =
+      List.without_first typ.ptyp_attributes
+        ~pred:
+          (fun attr -> String.equal attr.attr_name.txt Ext_name.bivariant_param)
+    in
+    match ptyp_attributes, var with
+    | Some ptyp_attributes, NoVariance -> Some ({typ with ptyp_attributes}, inj)
+    | None, _ -> None
+    | Some _, _ ->
+      invalid_encoding ~loc:typ.ptyp_loc "bivariant type parameter"
+
+  let encode_bivariant_pstr_type ~loc rec_flag tds =
+    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)
+           }
+         ]
+      )
+    in
+    Pstr_extension (ext, [])
+
+  let decode_bivariant_pstr ~loc payload =
+    match payload with
+    | PStr [{pstr_desc = (Pstr_type _) as x; _}] -> x
+    | _ -> invalid_encoding ~loc "bivariant structure_item"
 end
 
 module To_502 = struct
-  include Make (Ast_502)
+  include Make (Ast_502_arg)
 end

astlib/encoding_504.mli

@@ -2,6 +2,7 @@ module Ext_name : sig
   val ptyp_labeled_tuple : string
   val pexp_labeled_tuple : string
   val ppat_labeled_tuple : string
+  val bivariant_pstr : string
 end
 
 module To_503 : sig
@@ -28,6 +29,20 @@ module To_503 : sig
 
   val decode_ppat_labeled_tuple :
     loc:Location.t -> payload -> (string option * pattern) list * closed_flag
+
+  val encode_bivariant_param :
+    core_type -> injectivity ->
+    core_type * (variance * injectivity)
+
+  val decode_bivariant_param :
+    (core_type * (variance * injectivity)) ->
+    (core_type * injectivity) option
+
+  val encode_bivariant_pstr_type :
+    loc:Location.t -> rec_flag -> type_declaration list -> structure_item_desc
+
+  val decode_bivariant_pstr :
+    loc:Location.t -> payload -> structure_item_desc
 end
 
 module To_502 : sig

astlib/migrate_503_504.ml

@@ -544,12 +544,14 @@ and copy_structure : Ast_503.Parsetree.structure -> Ast_504.Parsetree.structure
 and copy_structure_item :
     Ast_503.Parsetree.structure_item -> Ast_504.Parsetree.structure_item =
  fun { Ast_503.Parsetree.pstr_desc; Ast_503.Parsetree.pstr_loc } ->
+ let loc = copy_location pstr_loc in
   {
-    Ast_504.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc;
-    Ast_504.Parsetree.pstr_loc = copy_location pstr_loc;
+    Ast_504.Parsetree.pstr_desc =
+      copy_structure_item_desc_with_loc ~loc pstr_desc;
+    Ast_504.Parsetree.pstr_loc = loc;
   }
 
-and copy_structure_item_desc :
+and copy_structure_item_desc_with_loc ~loc :
     Ast_503.Parsetree.structure_item_desc ->
     Ast_504.Parsetree.structure_item_desc = function
   | Ast_503.Parsetree.Pstr_eval (x0, x1) ->
@@ -583,9 +585,16 @@ and copy_structure_item_desc :
       Ast_504.Parsetree.Pstr_include (copy_include_declaration x0)
   | Ast_503.Parsetree.Pstr_attribute x0 ->
       Ast_504.Parsetree.Pstr_attribute (copy_attribute x0)
+  | Ast_503.Parsetree.Pstr_extension (({txt; _}, payload), [])
+      when String.equal txt Encoding_504.Ext_name.bivariant_pstr ->
+      let desc = Encoding_504.To_503.decode_bivariant_pstr ~loc payload in
+      copy_structure_item_desc_with_loc ~loc desc
   | Ast_503.Parsetree.Pstr_extension (x0, x1) ->
       Ast_504.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1)
 
+and copy_structure_item_desc stri_desc =
+  copy_structure_item_desc_with_loc ~loc:Location.none stri_desc
+
 and copy_include_declaration :
     Ast_503.Parsetree.include_declaration ->
     Ast_504.Parsetree.include_declaration =
@@ -1164,6 +1173,20 @@ and copy_extension_constructor_kind :
   | Ast_503.Parsetree.Pext_rebind x0 ->
       Ast_504.Parsetree.Pext_rebind (copy_loc (copy_Longident_t ~loc:x0.loc) x0)
 
+and copy_type_params params =
+  List.map
+    (fun ((typ, (var, inj)) as param) ->
+       match Encoding_504.To_503.decode_bivariant_param param with
+       | Some (typ, inj) ->
+         ( copy_core_type typ
+         , (Ast_504.Asttypes.Bivariant, copy_injectivity inj)
+         )
+       | None ->
+         ( copy_core_type typ
+         , (copy_variance var, copy_injectivity inj)
+         ))
+    params
+
 and copy_type_declaration :
     Ast_503.Parsetree.type_declaration -> Ast_504.Parsetree.type_declaration =
  fun {
@@ -1178,14 +1201,7 @@ and copy_type_declaration :
      } ->
   {
     Ast_504.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name;
-    Ast_504.Parsetree.ptype_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) ))
-        ptype_params;
+    Ast_504.Parsetree.ptype_params = copy_type_params ptype_params;
     Ast_504.Parsetree.ptype_cstrs =
       List.map
         (fun x ->

astlib/migrate_504_503.ml

@@ -2,9 +2,16 @@ open Stdlib0
 module From = Ast_504
 module To = Ast_503
 
-let migration_error loc missing_feature =
-  Location.raise_errorf ~loc
-    "migration error: %s are not supported before OCaml 5.4" missing_feature
+module Bivariant_param = struct
+  type exn +=
+    | T
+    | Type_decl of Ast_503.Parsetree.type_declaration
+    | Type_decl_list of Ast_503.Parsetree.type_declaration list
+
+(* TODO: register exception printers to display those as location errors
+   pointing to the right AST element and displaying a clear migration error
+   message *)
+end
 
 let rec copy_toplevel_phrase :
     Ast_504.Parsetree.toplevel_phrase -> Ast_503.Parsetree.toplevel_phrase =
@@ -528,12 +535,14 @@ and copy_structure : Ast_504.Parsetree.structure -> Ast_503.Parsetree.structure
 and copy_structure_item :
     Ast_504.Parsetree.structure_item -> Ast_503.Parsetree.structure_item =
  fun { Ast_504.Parsetree.pstr_desc; Ast_504.Parsetree.pstr_loc } ->
+   let loc = copy_location pstr_loc in
   {
-    Ast_503.Parsetree.pstr_desc = copy_structure_item_desc pstr_desc;
-    Ast_503.Parsetree.pstr_loc = copy_location pstr_loc;
+    Ast_503.Parsetree.pstr_desc =
+      copy_structure_item_desc_with_loc ~loc pstr_desc;
+    Ast_503.Parsetree.pstr_loc = loc;
   }
 
-and copy_structure_item_desc :
+and copy_structure_item_desc_with_loc ~loc :
     Ast_504.Parsetree.structure_item_desc ->
     Ast_503.Parsetree.structure_item_desc = function
   | Ast_504.Parsetree.Pstr_eval (x0, x1) ->
@@ -544,8 +553,12 @@ and copy_structure_item_desc :
   | Ast_504.Parsetree.Pstr_primitive x0 ->
       Ast_503.Parsetree.Pstr_primitive (copy_value_description x0)
   | Ast_504.Parsetree.Pstr_type (x0, x1) ->
-      Ast_503.Parsetree.Pstr_type
-        (copy_rec_flag x0, List.map copy_type_declaration x1)
+    let rec_flag = copy_rec_flag x0 in
+    (match copy_type_declaration_list x1 with
+    | 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_exception x0 ->
@@ -570,6 +583,9 @@ and copy_structure_item_desc :
   | Ast_504.Parsetree.Pstr_extension (x0, x1) ->
       Ast_503.Parsetree.Pstr_extension (copy_extension x0, copy_attributes x1)
 
+and copy_structure_item_desc stri_d =
+  copy_structure_item_desc_with_loc ~loc:Location.none stri_d
+
 and copy_include_declaration :
     Ast_504.Parsetree.include_declaration ->
     Ast_503.Parsetree.include_declaration =
@@ -1143,6 +1159,21 @@ and copy_extension_constructor_kind :
   | Ast_504.Parsetree.Pext_rebind x0 ->
       Ast_503.Parsetree.Pext_rebind (copy_loc copy_Longident_t x0)
 
+and copy_type_params params =
+  let contains_bivariant_param = ref false in
+  let params' =
+    List.map
+      (fun (typ, (variance, injectivity)) ->
+         let typ' = copy_core_type typ in
+         let injectivity' = copy_injectivity injectivity in
+         try (typ', (copy_variance variance, injectivity'))
+         with Bivariant_param.T ->
+           contains_bivariant_param := true;
+           Encoding_504.To_503.encode_bivariant_param typ' injectivity')
+      params
+  in
+  params', !contains_bivariant_param
+
 and copy_type_declaration :
     Ast_504.Parsetree.type_declaration -> Ast_503.Parsetree.type_declaration =
  fun {
@@ -1155,28 +1186,46 @@ and copy_type_declaration :
        Ast_504.Parsetree.ptype_attributes;
        Ast_504.Parsetree.ptype_loc;
      } ->
-  {
-    Ast_503.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name;
-    Ast_503.Parsetree.ptype_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) ))
-        ptype_params;
-    Ast_503.Parsetree.ptype_cstrs =
-      List.map
-        (fun x ->
-          let x0, x1, x2 = x in
-          (copy_core_type x0, copy_core_type x1, copy_location x2))
-        ptype_cstrs;
-    Ast_503.Parsetree.ptype_kind = copy_type_kind ptype_kind;
-    Ast_503.Parsetree.ptype_private = copy_private_flag ptype_private;
-    Ast_503.Parsetree.ptype_manifest = Option.map copy_core_type ptype_manifest;
-    Ast_503.Parsetree.ptype_attributes = copy_attributes ptype_attributes;
-    Ast_503.Parsetree.ptype_loc = copy_location ptype_loc;
-  }
+   let params, contains_bivariant = copy_type_params ptype_params in
+   let td =
+     {
+       Ast_503.Parsetree.ptype_name = copy_loc (fun x -> x) ptype_name;
+       Ast_503.Parsetree.ptype_params = params;
+         Ast_503.Parsetree.ptype_cstrs =
+         List.map
+           (fun x ->
+              let x0, x1, x2 = x in
+              (copy_core_type x0, copy_core_type x1, copy_location x2))
+           ptype_cstrs;
+       Ast_503.Parsetree.ptype_kind = copy_type_kind ptype_kind;
+       Ast_503.Parsetree.ptype_private = copy_private_flag ptype_private;
+       Ast_503.Parsetree.ptype_manifest = Option.map copy_core_type ptype_manifest;
+       Ast_503.Parsetree.ptype_attributes = copy_attributes ptype_attributes;
+       Ast_503.Parsetree.ptype_loc = copy_location ptype_loc;
+     }
+   in
+   if contains_bivariant then
+     raise (Bivariant_param.Type_decl td)
+   else
+     td
+
+and copy_type_declaration_list :
+  Ast_504.Parsetree.type_declaration list ->
+  Ast_503.Parsetree.type_declaration list = fun l ->
+  let contains_bivariant_param = ref false in
+  let tds =
+    List.map
+      (fun td ->
+         try copy_type_declaration td
+         with Bivariant_param.Type_decl td' ->
+           contains_bivariant_param := true;
+           td')
+      l
+  in
+  if !contains_bivariant_param then
+    raise (Bivariant_param.Type_decl_list tds)
+  else
+    tds
 
 and copy_private_flag :
     Ast_504.Asttypes.private_flag -> Ast_503.Asttypes.private_flag = function
@@ -1253,7 +1302,7 @@ and copy_variance : Ast_504.Asttypes.variance -> Ast_503.Asttypes.variance =
   | Ast_504.Asttypes.Covariant -> Ast_503.Asttypes.Covariant
   | Ast_504.Asttypes.Contravariant -> Ast_503.Asttypes.Contravariant
   | Ast_504.Asttypes.NoVariance -> Ast_503.Asttypes.NoVariance
-  | Ast_504.Asttypes.Bivariant -> migration_error Location.none "bivariance"
+  | Ast_504.Asttypes.Bivariant -> raise Bivariant_param.T
 
 and copy_value_description :
     Ast_504.Parsetree.value_description -> Ast_503.Parsetree.value_description =

astlib/stdlib0.ml

@@ -30,3 +30,15 @@ module Option = struct
       aux [] l
   end
 end
+
+module List = struct
+  include List
+
+  let without_first l ~pred =
+    let rec aux seen = function
+      | [] -> None
+      | hd::tl when pred hd -> Some (List.rev_append seen tl)
+      | hd::tl -> aux (hd::seen) tl
+    in
+    aux [] l
+end

test/encoding/504/migrations/run.t

@@ -42,3 +42,17 @@ And same for patterns:
 
   $ ./id_driver.exe pattern.ml --use-compiler-pp
   let (~a, ~b:_, c, ..) = x
+
+We also check that bivariant type parameters are correctly encoded and migrated:
+
+  $ cat > bivariant.ml << EOF
+  > type +-'a t = A
+  > EOF
+
+  $ ./id_driver.exe bivariant.ml
+  [%%ppxlib.migration.bivariant_str_item_504 type 'a t =
+                                               | A ]
+
+  $ ./id_driver.exe bivariant.ml --use-compiler-pp
+  type +-'a t =
+    | A