Swap default Ppat_unpack migration

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

Author: Nathan Rebours

astlib/encoding_505.ml

@@ -1,7 +1,7 @@
 module Ext_name = struct
   let pexp_struct_item = "ppxlib.migration.pexp_struct_item_505"
   let ptyp_functor = "ppxlib.migration.ptyp_functor_505"
-  let ppat_unpack = "ppxlib.migration.ppat_unpack_505"
+  let preserve_ppat_constraint = "ppxlib.migration.preserve_ppat_constraint_505"
   let ptype_kind_external = "ppxlib.migration.ptype_kind_external_505"
 end
 
@@ -90,4 +90,27 @@ module To_504 = struct
       when String.equal txt Ext_name.ptype_kind_external ->
         Some name
     | _ -> None
+
+  let must_preserve_ppat_constraint l =
+    let rec aux seen = function
+      | [] -> None
+      | { attr_name = { txt; _ }; _ } :: tl
+        when String.equal txt Ext_name.preserve_ppat_constraint ->
+          Some (List.rev_append seen tl)
+      | hd :: tl -> aux (hd :: seen) tl
+    in
+    aux [] l
+
+  let preserve_ppat_constraint pattern core_type =
+    let loc = pattern.ppat_loc in
+    let flag =
+      {
+        attr_name = { txt = Ext_name.preserve_ppat_constraint; loc };
+        attr_payload = PStr [];
+        attr_loc = loc;
+      }
+    in
+    Ppat_constraint
+      ( { pattern with ppat_attributes = flag :: pattern.ppat_attributes },
+        core_type )
 end

astlib/encoding_505.mli

@@ -0,0 +1,41 @@
+module Ext_name : sig
+  val pexp_struct_item : string
+  val ptyp_functor : string
+  val preserve_ppat_constraint : string
+  val ptype_kind_external : string
+end
+
+module To_504 : sig
+  open Ast_504.Asttypes
+  open Ast_504.Parsetree
+
+  val encode_pexp_struct_item :
+    loc:Location.t -> structure_item * expression -> expression_desc
+
+  val decode_pexp_struct_item :
+    loc:Location.t -> payload -> structure_item * expression
+
+  val encode_ptyp_functor :
+    loc:Location.t ->
+    arg_label * string loc * package_type * core_type ->
+    core_type_desc
+
+  val decode_ptyp_functor :
+    loc:Location.t ->
+    payload ->
+    arg_label * string loc * package_type * core_type
+
+  val encode_ptype_kind_external : string -> attribute
+  val decode_ptype_kind_external : attribute -> string option
+
+  val must_preserve_ppat_constraint : attributes -> attributes option
+  (** Returns [None] if the list does not contain
+      [@ppxlib.migration.preserve_ppat_constraint_505] or [Some l] where [l] is
+      the remainder of the attributes. Should be used to determine whether a
+      [Ppat_constraint (Ppat_unpack m, Ptyp_package s)] node should be preserved
+      when migrated to 5.5 or turned into [Ppat_unpack (m, Some s)]. The
+      attribute should be attached to the [Ppat_unpack] node within the
+      [Ppat_constraint]. *)
+
+  val preserve_ppat_constraint : pattern -> core_type -> pattern_desc
+end

astlib/migrate_504_505.ml

@@ -330,13 +330,14 @@ and copy_pattern_desc :
   | Ast_504.Parsetree.Ppat_constraint
       ( ({ ppat_desc = Ppat_unpack p; ppat_attributes; _ } as x0),
         ({ ptyp_desc = Ptyp_package pkg; _ } as x1) ) -> (
-      match ppat_attributes with
-      | [ { attr_name = { txt; _ } } ]
-        when String.equal txt Encoding_505.Ext_name.ppat_unpack ->
-          Ast_505.Parsetree.Ppat_unpack (p, Some (copy_package_type pkg))
-      | _ ->
-          Ast_505.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1)
-      )
+      let preserve =
+        Encoding_505.To_504.must_preserve_ppat_constraint ppat_attributes
+      in
+      match preserve with
+      | None -> Ast_505.Parsetree.Ppat_unpack (p, Some (copy_package_type pkg))
+      | Some ppat_attributes ->
+          Ast_505.Parsetree.Ppat_constraint
+            (copy_pattern { x0 with ppat_attributes }, copy_core_type x1))
   | Ast_504.Parsetree.Ppat_constraint (x0, x1) ->
       Ast_505.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1)
   | Ast_504.Parsetree.Ppat_type x0 ->

astlib/migrate_505_504.ml

@@ -276,13 +276,13 @@ and copy_pattern : Ast_505.Parsetree.pattern -> Ast_504.Parsetree.pattern =
        Ast_505.Parsetree.ppat_attributes;
      } ->
   {
-    Ast_504.Parsetree.ppat_desc = copy_pattern_desc ppat_desc;
+    Ast_504.Parsetree.ppat_desc = copy_pattern_desc ~loc:ppat_loc ppat_desc;
     Ast_504.Parsetree.ppat_loc = copy_location ppat_loc;
     Ast_504.Parsetree.ppat_loc_stack = copy_location_stack ppat_loc_stack;
     Ast_504.Parsetree.ppat_attributes = copy_attributes ppat_attributes;
   }
 
-and copy_pattern_desc :
+and copy_pattern_desc ~loc :
     Ast_505.Parsetree.pattern_desc -> Ast_504.Parsetree.pattern_desc = function
   | Ast_505.Parsetree.Ppat_any -> Ast_504.Parsetree.Ppat_any
   | Ast_505.Parsetree.Ppat_var x0 ->
@@ -323,6 +323,12 @@ and copy_pattern_desc :
       Ast_504.Parsetree.Ppat_array (List.map copy_pattern x0)
   | Ast_505.Parsetree.Ppat_or (x0, x1) ->
       Ast_504.Parsetree.Ppat_or (copy_pattern x0, copy_pattern x1)
+  | Ast_505.Parsetree.Ppat_constraint
+      ( ({ ppat_desc = Ppat_unpack (_, None); _ } as x0),
+        ({ ptyp_desc = Ptyp_package _; _ } as x1) ) ->
+      let x0' = copy_pattern x0 in
+      let x1' = copy_core_type x1 in
+      Encoding_505.To_504.preserve_ppat_constraint x0' x1'
   | Ast_505.Parsetree.Ppat_constraint (x0, x1) ->
       Ast_504.Parsetree.Ppat_constraint (copy_pattern x0, copy_core_type x1)
   | Ast_505.Parsetree.Ppat_type x0 ->
@@ -336,30 +342,19 @@ and copy_pattern_desc :
       match x1 with
       | None -> unpack
       | Some c ->
-          let ghost_loc loc = { loc with Location.loc_ghost = true } in
-          let flag_attr : Ast_504.Parsetree.attribute =
-            {
-              attr_name =
-                {
-                  txt = Encoding_505.Ext_name.ppat_unpack;
-                  loc = ghost_loc Location.none;
-                };
-              attr_loc = ghost_loc Location.none;
-              attr_payload = PStr [];
-            }
-          in
+          let ghost_loc = { loc with Location.loc_ghost = true } in
           let unpack_pattern : Ast_504.Parsetree.pattern =
             {
               ppat_desc = unpack;
-              ppat_loc = ghost_loc Location.none;
-              ppat_attributes = [ flag_attr ];
+              ppat_loc = ghost_loc;
+              ppat_attributes = [];
               ppat_loc_stack = [];
             }
           in
           let package_type : Ast_504.Parsetree.core_type =
             {
               ptyp_desc = Ptyp_package (copy_package_type c);
-              ptyp_loc = ghost_loc Location.none;
+              ptyp_loc = ghost_loc;
               ptyp_attributes = [];
               ptyp_loc_stack = [];
             }