Add migrations for ppx.context's load_path

Signed-off-by: Nathan Rebours <[email protected]>

astlib/migrate_501_502.ml

@@ -7,13 +7,62 @@ module To = Ast_502
     attribute is not found. *)
 let extract_attr name (attrs : Ast_501.Parsetree.attributes) =
   let rec loop acc = function
-    | [] -> (false, List.rev acc)
-    | { Ast_501.Parsetree.attr_name = { txt; _ }; _ } :: q when txt = name ->
-        (true, List.rev_append acc q)
+    | [] -> (None, List.rev acc)
+    | { Ast_501.Parsetree.attr_name = { txt; _ }; attr_payload; _ } :: q
+      when txt = name ->
+        (Some attr_payload, List.rev_append acc q)
     | hd :: tl -> loop (hd :: acc) tl
   in
   loop [] attrs
 
+let migrate_ppx_context_load_path expr =
+  let open Ast_501.Parsetree in
+  let visible = { expr with pexp_attributes = [] } in
+  let payload, other_attrs =
+    extract_attr "ppxlib.migration.hidden_load_path" expr.pexp_attributes
+  in
+  let hidden =
+    match payload with
+    | None ->
+        (* An empty list *)
+        let pexp_desc =
+          Pexp_construct ({ txt = Lident "[]"; loc = expr.pexp_loc }, None)
+        in
+        { expr with pexp_desc; pexp_attributes = [] }
+    | Some (PStr [ { pstr_desc = Pstr_eval (expr, []); _ } ]) -> expr
+    | Some _ -> invalid_arg "Invalid ppxlib.migration.hidden_load_path paylaod"
+  in
+  {
+    expr with
+    pexp_attributes = other_attrs;
+    pexp_desc = Pexp_tuple [ visible; hidden ];
+  }
+
+let migrate_ppx_context_fields fields =
+  List.map
+    (fun (lident_loc, expr) ->
+      match lident_loc.Ast_501.Asttypes.txt with
+      | Longident.Lident "load_path" ->
+          (lident_loc, migrate_ppx_context_load_path expr)
+      | _ -> (lident_loc, expr))
+    fields
+
+let migrate_ppx_context_payload payload =
+  let open Ast_501.Parsetree in
+  match payload with
+  | PStr
+      [
+        ({
+           pstr_desc =
+             Pstr_eval
+               (({ pexp_desc = Pexp_record (fields, None) } as expr), attributes);
+         } as stri);
+      ] ->
+      let new_fields = migrate_ppx_context_fields fields in
+      let new_expr = { expr with pexp_desc = Pexp_record (new_fields, None) } in
+      PStr [ { stri with pstr_desc = Pstr_eval (new_expr, attributes) } ]
+  | _ -> payload
+
 let rec copy_toplevel_phrase :
     Ast_501.Parsetree.toplevel_phrase -> Ast_502.Parsetree.toplevel_phrase =
   function
@@ -514,7 +563,11 @@ and copy_attribute : Ast_501.Parsetree.attribute -> Ast_502.Parsetree.attribute
      } ->
   {
     Ast_502.Parsetree.attr_name = copy_loc (fun x -> x) attr_name;
-    Ast_502.Parsetree.attr_payload = copy_payload attr_payload;
+    Ast_502.Parsetree.attr_payload =
+      (match attr_name.txt with
+      | "ocaml.ppx.context" ->
+          copy_payload (migrate_ppx_context_payload attr_payload)
+      | _ -> copy_payload attr_payload);
     Ast_502.Parsetree.attr_loc = copy_location attr_loc;
   }
 

astlib/migrate_502_501.ml

@@ -13,6 +13,48 @@ let mk_ghost_attr name =
     attr_loc = Location.none;
   }
 
+let migrate_ppx_context_load_path expr =
+  let open Ast_502.Parsetree in
+  let loc = Location.none in
+  match expr.pexp_desc with
+  | Pexp_tuple [ visible; hidden ] ->
+      let hidden_attr =
+        {
+          attr_name =
+            { Location.txt = "ppxlib.migration.hidden_load_path"; loc };
+          attr_loc = loc;
+          attr_payload =
+            PStr [ { pstr_loc = loc; pstr_desc = Pstr_eval (hidden, []) } ];
+        }
+      in
+      { visible with pexp_attributes = hidden_attr :: expr.pexp_attributes }
+  | _ -> expr
+
+let migrate_ppx_context_fields fields =
+  List.map
+    (fun (lident_loc, expr) ->
+      match lident_loc.Ast_502.Asttypes.txt with
+      | Longident.Lident "load_path" ->
+          (lident_loc, migrate_ppx_context_load_path expr)
+      | _ -> (lident_loc, expr))
+    fields
+
+let migrate_ppx_context_payload payload =
+  let open Ast_502.Parsetree in
+  match payload with
+  | PStr
+      [
+        ({
+           pstr_desc =
+             Pstr_eval
+               (({ pexp_desc = Pexp_record (fields, None) } as expr), attributes);
+         } as stri);
+      ] ->
+      let new_fields = migrate_ppx_context_fields fields in
+      let new_expr = { expr with pexp_desc = Pexp_record (new_fields, None) } in
+      PStr [ { stri with pstr_desc = Pstr_eval (new_expr, attributes) } ]
+  | _ -> payload
+
 let rec copy_toplevel_phrase :
     Ast_502.Parsetree.toplevel_phrase -> Ast_501.Parsetree.toplevel_phrase =
   function
@@ -511,7 +553,11 @@ and copy_attribute : Ast_502.Parsetree.attribute -> Ast_501.Parsetree.attribute
      } ->
   {
     Ast_501.Parsetree.attr_name = copy_loc (fun x -> x) attr_name;
-    Ast_501.Parsetree.attr_payload = copy_payload attr_payload;
+    Ast_501.Parsetree.attr_payload =
+      (match attr_name.txt with
+      | "ocaml.ppx.context" ->
+          copy_payload (migrate_ppx_context_payload attr_payload)
+      | _ -> copy_payload attr_payload);
     Ast_501.Parsetree.attr_loc = copy_location attr_loc;
   }
 

test/driver/ocaml-ppx-context-load-path-migration/driver.ml

@@ -0,0 +1,92 @@
+module To_before_502 =
+  Ppxlib_ast.Convert (Ppxlib_ast.Js) (Ppxlib_ast__.Versions.OCaml_501)
+
+module From_before_502 =
+  Ppxlib_ast.Convert (Ppxlib_ast__.Versions.OCaml_501) (Ppxlib_ast.Js)
+
+module Before_502_to_ocaml =
+  Ppxlib_ast.Convert
+    (Ppxlib_ast__.Versions.OCaml_501)
+    (Ppxlib_ast.Compiler_version)
+
+module OCaml_501 = Ppxlib_ast__.Versions.OCaml_501.Ast
+
+let rec unfold_list_lit x next =
+  let open OCaml_501.Parsetree in
+  let open Astlib.Longident in
+  match next.pexp_desc with
+  | Pexp_construct ({ txt = Lident "[]"; _ }, None) -> [ x ]
+  | Pexp_construct
+      ( { txt = Lident "::"; _ },
+        Some { pexp_desc = Pexp_tuple [ elm; rest ]; _ } ) ->
+      x :: unfold_list_lit elm rest
+  | _ -> invalid_arg "list_lit"
+
+(* Only deals with the basic blocks needed for ocaml.ppx.context *)
+let rec basic_expr_to_string expr =
+  let open OCaml_501.Parsetree in
+  let open Astlib.Longident in
+  match expr.pexp_desc with
+  | Pexp_constant (Pconst_string (s, _, None)) -> Printf.sprintf "%S" s
+  | Pexp_ident { txt = Lident name; _ } -> name
+  | Pexp_tuple l ->
+      let strs = List.map basic_expr_to_string l in
+      "(" ^ String.concat ", " strs ^ ")"
+  | Pexp_construct ({ txt = Lident s; _ }, None) -> s
+  | Pexp_construct
+      ( { txt = Lident "::"; _ },
+        Some { pexp_desc = Pexp_tuple [ elm; rest ]; _ } ) ->
+      let exprs = unfold_list_lit elm rest in
+      let strs = List.map basic_expr_to_string exprs in
+      "[" ^ String.concat "; " strs ^ "]"
+  | _ -> invalid_arg "basic_expr_to_string"
+
+let print_field (lident_loc, expr) =
+  match lident_loc with
+  | { OCaml_501.Asttypes.txt = Astlib.Longident.Lident name; _ } ->
+      Printf.printf "    %s: %s;\n" name (basic_expr_to_string expr)
+  | _ -> ()
+
+let print_ocaml_ppx_context stri =
+  let open OCaml_501.Parsetree in
+  match stri.pstr_desc with
+  | Pstr_attribute
+      {
+        attr_payload =
+          PStr
+            [
+              {
+                pstr_desc =
+                  Pstr_eval ({ pexp_desc = Pexp_record (fields, None); _ }, _);
+                _;
+              };
+            ];
+        _;
+      } ->
+      Printf.printf "[@@@ocaml.ppx.context\n";
+      Printf.printf "  {\n";
+      List.iter print_field fields;
+      Printf.printf "  }\n";
+      Printf.printf "]\n"
+  | _ -> ()
+
+let is_ppx_context stri =
+  let open OCaml_501.Parsetree in
+  match stri.pstr_desc with
+  | Pstr_attribute
+      { attr_name = { OCaml_501.Asttypes.txt = "ocaml.ppx.context"; _ }; _ } ->
+      true
+  | _ -> false
+
+let impl _ctxt str =
+  let before_502_ast = To_before_502.copy_structure str in
+  let ppx_context = List.find is_ppx_context before_502_ast in
+  Printf.printf "ocaml.ppx.context before 5.02:\n";
+  print_ocaml_ppx_context ppx_context;
+  let round_trip = Before_502_to_ocaml.copy_structure_item ppx_context in
+  Printf.printf "ocaml.ppx.context round tripped:\n";
+  Ocaml_common.Pprintast.structure_item Format.std_formatter round_trip;
+  From_before_502.copy_structure before_502_ast
+
+let () = Ppxlib.Driver.V2.register_transformation ~impl "ocaml.ppx.context-test"
+let () = Ppxlib.Driver.standalone ()

test/driver/ocaml-ppx-context-load-path-migration/dune

@@ -0,0 +1,13 @@
+; Remember to bump the enabled if to the latest supported OCaml
+
+(executable
+ (name driver)
+ (enabled_if
+  (>= %{ocaml_version} "5.2"))
+ (libraries ppxlib ppxlib.ast ppxlib.astlib ocaml-compiler-libs.common
+   compiler-libs.common))
+
+(cram
+ (enabled_if
+  (>= %{ocaml_version} "5.2"))
+ (deps driver.exe))

test/driver/ocaml-ppx-context-load-path-migration/run.t

@@ -0,0 +1,76 @@
+Note that this test shoud only be enabled with the latest supported OCaml
+version.
+
+In 5.2 the format of ocaml.ppx.context load_path changed.
+To ensure compat, we defined migration for ocaml.ppx.context attributes
+
+We write such an attribute to an .ml file. The compiler will add its own
+and it should be consumed by the driver but our handwritten attribute will
+be migrated as well and should remain in the AST.
+  $ cat > test.ml << EOF
+  > let x = 1
+  > [@@@ocaml.ppx.context
+  >   {
+  >     tool_name = "ocaml";
+  >     include_dirs = ["foo"];
+  >     hidden_include_dirs = [];
+  >     load_path = (["foo"; "bar"], ["baz"]);
+  >     open_modules = [];
+  >     for_package = None;
+  >     debug = true;
+  >     use_threads = false;
+  >     use_vmthreads = false;
+  >     recursive_types = false;
+  >     principal = false;
+  >     transparent_modules = false;
+  >     unboxed_types = false;
+  >     unsafe_string = false;
+  >     cookies = []
+  >   }]
+  > EOF
+
+We then run a custom driver that will read our ast, migrate it back to 5.01,
+pretty print the ocaml.ppx.context, convert it back to the latest version and
+pretty print it again. This last, round-tripped version should be identical to
+the one above.
+
+  $ ./driver.exe --impl test.ml -o ignore.ml
+  ocaml.ppx.context before 5.02:
+  [@@@ocaml.ppx.context
+    {
+      tool_name: "ocaml";
+      include_dirs: ["foo"];
+      hidden_include_dirs: [];
+      load_path: ["foo"; "bar"];
+      open_modules: [];
+      for_package: None;
+      debug: true;
+      use_threads: false;
+      use_vmthreads: false;
+      recursive_types: false;
+      principal: false;
+      transparent_modules: false;
+      unboxed_types: false;
+      unsafe_string: false;
+      cookies: [];
+    }
+  ]
+  ocaml.ppx.context round tripped:
+  [@@@ocaml.ppx.context
+    {
+      tool_name = "ocaml";
+      include_dirs = ["foo"];
+      hidden_include_dirs = [];
+      load_path = (["foo"; "bar"], ["baz"]);
+      open_modules = [];
+      for_package = None;
+      debug = true;
+      use_threads = false;
+      use_vmthreads = false;
+      recursive_types = false;
+      principal = false;
+      transparent_modules = false;
+      unboxed_types = false;
+      unsafe_string = false;
+      cookies = []
+    }]

test/driver/standalone-supports-old-binary-ast/test.t/run.t

@@ -5,10 +5,6 @@ The version is preserved.
   Magic number: Caml1999N022
 
   $ ../identity_standalone.exe --intf 406_binary_ast -o transformed --dump-ast
-  File "_none_", line 1:
-  Error: Internal error: invalid [@@ocaml.ppx.context { load_path }] pair syntax
-  [1]
 
   $ ../print_magic_number.exe < transformed
-  cannot open transformed: No such file
-  [2]
+  Magic number: Caml1999N022