Migration: Use an attribute for generative functor migration

Two 501 constructs are represented the same way in 500. One of them
raise a warning.
During the 501 -> 500 -> 501 migration, we need to be careful to keep
the warning where it was originally.
We use attributes to remember which 501 representation to choose. The
reserved namespace is "ppxlib.migration".

Signed-off-by: Paul-Elliot <peada@free.fr>

astlib/migrate_500_501.ml

@@ -751,7 +751,27 @@ and copy_module_expr_desc :
       Ast_501.Parsetree.Pmod_functor
         (copy_functor_parameter x0, copy_module_expr x1)
   | Ast_500.Parsetree.Pmod_apply (x0, x1) ->
-      Ast_501.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1)
+      let x1, is_unit =
+        match x1.pmod_desc with
+        | Pmod_structure [] ->
+            let rec extract_attr acc : Ast_500.Parsetree.attributes -> _ =
+              function
+              | [] -> (List.rev acc, true)
+              | {
+                  attr_name = { txt = "ppxlib.migration.keep_structure"; _ };
+                  _;
+                }
+                :: q ->
+                  (List.rev_append acc q, false)
+              | hd :: tl -> extract_attr (hd :: acc) tl
+            in
+            let pmod_attributes, b = extract_attr [] x1.pmod_attributes in
+            ({ x1 with pmod_attributes }, b)
+        | _ -> (x1, false)
+      in
+      if is_unit then Ast_501.Parsetree.Pmod_apply_unit (copy_module_expr x0)
+      else
+        Ast_501.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1)
   | Ast_500.Parsetree.Pmod_constraint (x0, x1) ->
       Ast_501.Parsetree.Pmod_constraint
         (copy_module_expr x0, copy_module_type x1)

astlib/migrate_501_500.ml

@@ -769,8 +769,8 @@ and copy_module_expr :
        Ast_501.Parsetree.pmod_desc;
        Ast_501.Parsetree.pmod_loc;
        Ast_501.Parsetree.pmod_attributes;
-   } ->
- let loc = copy_location pmod_loc in
+     } ->
+  let loc = copy_location pmod_loc in
   {
     Ast_500.Parsetree.pmod_desc = copy_module_expr_desc loc pmod_desc;
     Ast_500.Parsetree.pmod_loc = loc;
@@ -788,7 +788,26 @@ and copy_module_expr_desc loc :
       Ast_500.Parsetree.Pmod_functor
         (copy_functor_parameter x0, copy_module_expr x1)
   | Ast_501.Parsetree.Pmod_apply (x0, x1) ->
-      Ast_500.Parsetree.Pmod_apply (copy_module_expr x0, copy_module_expr x1)
+      let x1 = copy_module_expr x1 in
+      let x1 =
+        match x1.pmod_desc with
+        | Pmod_structure [] ->
+            let pmod_attributes =
+              {
+                Ast_500.Parsetree.attr_name =
+                  {
+                    txt = "ppxlib.migration.keep_structure";
+                    loc = { x1.pmod_loc with loc_ghost = true };
+                  };
+                attr_payload = Ast_500.Parsetree.PStr [];
+                attr_loc = Location.none;
+              }
+              :: x1.pmod_attributes
+            in
+            { x1 with pmod_attributes }
+        | _ -> x1
+      in
+      Ast_500.Parsetree.Pmod_apply (copy_module_expr x0, x1)
   | Ast_501.Parsetree.Pmod_apply_unit x0 ->
       let empty_struct =
         Ast_500.Parsetree.

src/name.ml

@@ -123,6 +123,7 @@ module Reserved_namespaces = struct
   let () = reserve "res" (* rescript *)
   let () = reserve "metaocaml"
   let () = reserve "ocamlformat"
+  let () = reserve "ppxlib.migration"
 
   let is_in_reserved_namespaces name =
     match get_outer_namespace name with

src/name.mli

@@ -109,7 +109,8 @@ module Reserved_namespaces : sig
       This is here to insure that the rewriter cohabits well with other rewriter
       or tools (e.g. merlin) which might leave attribute on the AST.
 
-      N.B. the "merlin" namespace is reserved by default. *)
+      N.B. the following namespaces are reserved by default: [merlin], [reason],
+      [refmt] [ns], [res], [metaocaml], [ocamlformat] and [ppxlib]. *)
 
   val is_in_reserved_namespaces : string -> bool
 end

test/501_migrations/normal_migrations.t

@@ -160,19 +160,7 @@ Tests for the Parsetree change for generative functor applications
   > module M = F ()
   > EOF
   $ ./compare_on.exe file.ml ./identity_driver.exe | grep -v "without_migrations" | grep -v "with_migrations"
-  @@ -14 +14 @@
-  -        Pmod_apply_unit
-  +        Pmod_apply
-  @@ -16,0 +17,3 @@
-  +        module_expr (file.ml[2,25+11]..[2,25+15])
-  +          Pmod_structure
-  +          []
-  @@ -18,0 +22,5 @@
-  +File "file.ml", line 2, characters 11-15:
-  +2 | module M = F ()
-  +               ^^^^
-  +Warning 73 [generative-application-expects-unit]: A generative functor
-  +should be applied to '()'; using '(struct end)' is deprecated.
+  [1]
 
   $ cat > file.ml << EOF
   > module F () = struct end

test/501_migrations/reverse_migrations.t

@@ -179,16 +179,23 @@ Tests for the Parsetree change for generative functor applications
   $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations"
   [1]
 
+When going up, F(struct end) is turned into F(), which makes the location be lost.
+It could be stored in an attribute, or turned into F(struct end [@warning "-73"]).
+
   $ cat > file.ml << EOF
   > module F () = struct end
   > module M = F(struct end)
   > EOF
   $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations"
-  [1]
+  @@ -17 +17 @@
+  -        module_expr (file.ml[2,25+13]..[2,25+23])
+  +        module_expr (file.ml[2,25+11]..[2,25+24])
 
   $ cat > file.ml << EOF
   > module F (N : sig end) = struct end
   > module M = F (struct end)
   > EOF
   $ ./compare_on.exe file.ml ./reverse_migrations.exe | grep -v "without_migrations" | grep -v "with_migrations"
-  [1]
+  @@ -20 +20 @@
+  -        module_expr (file.ml[2,36+14]..[2,36+24])
+  +        module_expr (file.ml[2,36+11]..[2,36+25])