From 61434334286551bf462ddb046a8a253ba84e9a31 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Fri, 16 Feb 2024 12:05:38 +0100 Subject: [PATCH] Add migrations for ppx.context's load_path Signed-off-by: Nathan Rebours --- astlib/migrate_501_502.ml | 61 +++++++++++- astlib/migrate_502_501.ml | 48 +++++++++- .../driver.ml | 92 +++++++++++++++++++ .../dune | 13 +++ .../run.t | 76 +++++++++++++++ .../test.t/run.t | 6 +- 6 files changed, 286 insertions(+), 10 deletions(-) create mode 100644 test/driver/ocaml-ppx-context-load-path-migration/driver.ml create mode 100644 test/driver/ocaml-ppx-context-load-path-migration/dune create mode 100644 test/driver/ocaml-ppx-context-load-path-migration/run.t diff --git a/astlib/migrate_501_502.ml b/astlib/migrate_501_502.ml index 6e7fec94..e4a0d0fe 100644 --- a/astlib/migrate_501_502.ml +++ b/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; } diff --git a/astlib/migrate_502_501.ml b/astlib/migrate_502_501.ml index b756d890..c7af15a8 100644 --- a/astlib/migrate_502_501.ml +++ b/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; } diff --git a/test/driver/ocaml-ppx-context-load-path-migration/driver.ml b/test/driver/ocaml-ppx-context-load-path-migration/driver.ml new file mode 100644 index 00000000..048d91bb --- /dev/null +++ b/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 () diff --git a/test/driver/ocaml-ppx-context-load-path-migration/dune b/test/driver/ocaml-ppx-context-load-path-migration/dune new file mode 100644 index 00000000..e5acf6f7 --- /dev/null +++ b/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)) diff --git a/test/driver/ocaml-ppx-context-load-path-migration/run.t b/test/driver/ocaml-ppx-context-load-path-migration/run.t new file mode 100644 index 00000000..b3de2c03 --- /dev/null +++ b/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 = [] + }] diff --git a/test/driver/standalone-supports-old-binary-ast/test.t/run.t b/test/driver/standalone-supports-old-binary-ast/test.t/run.t index c269cb16..8baa6e85 100644 --- a/test/driver/standalone-supports-old-binary-ast/test.t/run.t +++ b/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