diff --git a/changes/remove-ppx-context-restore.internal.md b/changes/remove-ppx-context-restore.internal.md new file mode 100644 index 0000000000..561172619b --- /dev/null +++ b/changes/remove-ppx-context-restore.internal.md @@ -0,0 +1 @@ +- Remove the unused restoring of the PPX context, including the cookie store. https://github.com/rescript-lang/rescript/pull/8859 diff --git a/compiler/bsc/rescript_compiler_main.ml b/compiler/bsc/rescript_compiler_main.ml index 949d42f6c5..463fd73a63 100644 --- a/compiler/bsc/rescript_compiler_main.ml +++ b/compiler/bsc/rescript_compiler_main.ml @@ -116,8 +116,7 @@ let reprint_source_file sourcefile = exit 1); Res_compmisc.init_path (); parse_result.parsetree - |> Cmd_ppx_apply.apply_rewriters ~restore:false - ~tool_name:Js_config.tool_name Ml + |> Cmd_ppx_apply.apply_rewriters ~tool_name:Js_config.tool_name Ml |> Ppx_entry.rewrite_implementation |> Res_printer.print_implementation ~width:100 ~comments:parse_result.comments @@ -132,8 +131,7 @@ let reprint_source_file sourcefile = exit 1); Res_compmisc.init_path (); parse_result.parsetree - |> Cmd_ppx_apply.apply_rewriters ~restore:false - ~tool_name:Js_config.tool_name Mli + |> Cmd_ppx_apply.apply_rewriters ~tool_name:Js_config.tool_name Mli |> Ppx_entry.rewrite_signature |> Res_printer.print_interface ~width:100 ~comments:parse_result.comments |> print_endline diff --git a/compiler/core/cmd_ppx_apply.ml b/compiler/core/cmd_ppx_apply.ml index 111eae078d..6dde3d56d8 100644 --- a/compiler/core/cmd_ppx_apply.ml +++ b/compiler/core/cmd_ppx_apply.ml @@ -93,7 +93,7 @@ let rewrite kind ppxs ast = out | _ -> assert false -let apply_rewriters_str ?(restore = true) ~tool_name ast = +let apply_rewriters_str ~tool_name ast = match !Clflags.all_ppx with | [] -> if !Js_config.test_ast_conversion then @@ -103,9 +103,9 @@ let apply_rewriters_str ?(restore = true) ~tool_name ast = ast |> Ast_mapper.add_ppx_context_str ~tool_name |> rewrite Ml ppxs |> Ml_binary.ast0_to_structure - |> Ast_mapper.drop_ppx_context_str ~restore + |> Ast_mapper.drop_ppx_context_str -let apply_rewriters_sig ?(restore = true) ~tool_name ast = +let apply_rewriters_sig ~tool_name ast = match !Clflags.all_ppx with | [] -> if !Js_config.test_ast_conversion then @@ -115,10 +115,10 @@ let apply_rewriters_sig ?(restore = true) ~tool_name ast = ast |> Ast_mapper.add_ppx_context_sig ~tool_name |> rewrite Mli ppxs |> Ml_binary.ast0_to_signature - |> Ast_mapper.drop_ppx_context_sig ~restore + |> Ast_mapper.drop_ppx_context_sig -let apply_rewriters ?restore ~tool_name (type a) (kind : a Ml_binary.kind) - (ast : a) : a = +let apply_rewriters ~tool_name (type a) (kind : a Ml_binary.kind) (ast : a) : a + = match kind with - | Ml_binary.Ml -> apply_rewriters_str ?restore ~tool_name ast - | Ml_binary.Mli -> apply_rewriters_sig ?restore ~tool_name ast + | Ml_binary.Ml -> apply_rewriters_str ~tool_name ast + | Ml_binary.Mli -> apply_rewriters_sig ~tool_name ast diff --git a/compiler/core/js_implementation.ml b/compiler/core/js_implementation.ml index 265adedb2b..d4008617d8 100644 --- a/compiler/core/js_implementation.ml +++ b/compiler/core/js_implementation.ml @@ -64,8 +64,7 @@ let interface ~parser ppf ?outputprefix fname = in Res_compmisc.init_path (); parser fname - |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name - Mli + |> Cmd_ppx_apply.apply_rewriters ~tool_name:Js_config.tool_name Mli |> Ppx_entry.rewrite_signature |> print_if_pipe ppf Clflags.dump_parsetree Printast.interface |> print_if_pipe ppf Clflags.dump_source Pprintast.signature @@ -151,8 +150,7 @@ let implementation ~parser ppf ?outputprefix fname = in Res_compmisc.init_path (); parser fname - |> Cmd_ppx_apply.apply_rewriters ~restore:false ~tool_name:Js_config.tool_name - Ml + |> Cmd_ppx_apply.apply_rewriters ~tool_name:Js_config.tool_name Ml |> Ppx_entry.rewrite_implementation |> print_if_pipe ppf Clflags.dump_parsetree Printast.implementation |> print_if_pipe ppf Clflags.dump_source Pprintast.structure diff --git a/compiler/ml/ast_mapper.ml b/compiler/ml/ast_mapper.ml index cc0da9a632..b1c8e151a3 100644 --- a/compiler/ml/ast_mapper.ml +++ b/compiler/ml/ast_mapper.ml @@ -612,13 +612,6 @@ let rec extension_of_error {loc; msg; if_highlight; sub} = ] @ List.map (fun ext -> Str.extension (extension_of_error ext)) sub) ) -module String_map = Map.Make (struct - type t = string - let compare = compare -end) - -let cookies = ref String_map.empty - module Ppx_context = struct open Longident open Asttypes @@ -641,18 +634,6 @@ module Ppx_context = struct Exp.construct (lid "::") (Location.mknoloc [f x; make_list f rest]) | [] -> Exp.construct (lid "[]") (Location.mknoloc []) - let make_pair f1 f2 (x1, x2) = Exp.tuple [f1 x1; f2 x2] - - let get_cookies () = - { - lid = lid "cookies"; - x = - make_list - (make_pair make_string (fun x -> x)) - (String_map.bindings !cookies); - opt = false; - } - let mk fields = ( {txt = "ocaml.ppx.context"; loc = Location.none}, Parsetree.PStr [Str.eval (Exp.record fields None)] ) @@ -677,98 +658,24 @@ module Ppx_context = struct opt = false; }; {lid = lid "debug"; x = make_bool !Clflags.debug; opt = false}; - get_cookies (); + (* The compiler doesn't read back the cookies a PPX sets. *) + {lid = lid "cookies"; x = make_list Fun.id []; opt = false}; ] in mk fields - - let get_fields = function - | PStr - [{pstr_desc = Pstr_eval ({pexp_desc = Pexp_record (fields, None)}, [])}] - -> - fields - | _ -> raise_errorf "Internal error: invalid [@@@ocaml.ppx.context] syntax" - - let restore fields = - let field name payload = - let rec get_string = function - | {pexp_desc = Pexp_constant (Pconst_string payload)} -> - String_literal.string_semantic payload - | _ -> - raise_errorf - "Internal error: invalid [@@@ocaml.ppx.context { %s }] string \ - syntax" - name - and get_bool pexp = - match pexp with - | { - pexp_desc = Pexp_construct ({txt = Longident.Lident "true"}, {txt = []}); - } -> - true - | { - pexp_desc = - Pexp_construct ({txt = Longident.Lident "false"}, {txt = []}); - } -> - false - | _ -> - raise_errorf - "Internal error: invalid [@@@ocaml.ppx.context { %s }] bool syntax" - name - and get_list elem = function - | { - pexp_desc = - Pexp_construct ({txt = Longident.Lident "::"}, {txt = [exp; rest]}); - } -> - elem exp :: get_list elem rest - | { - pexp_desc = - Pexp_construct ({txt = Longident.Lident "[]"}, {txt = []}); - } -> - [] - | _ -> - raise_errorf - "Internal error: invalid [@@@ocaml.ppx.context { %s }] list syntax" - name - and get_pair f1 f2 = function - | {pexp_desc = Pexp_tuple [e1; e2]} -> (f1 e1, f2 e2) - | _ -> - raise_errorf - "Internal error: invalid [@@@ocaml.ppx.context { %s }] pair syntax" - name - in - match name with - | "include_dirs" -> Clflags.include_dirs := get_list get_string payload - | "load_path" -> Config.load_path := get_list get_string payload - | "open_modules" -> Clflags.open_modules := get_list get_string payload - | "debug" -> Clflags.debug := get_bool payload - | "cookies" -> - let l = get_list (get_pair get_string (fun x -> x)) payload in - cookies := - List.fold_left - (fun s (k, v) -> String_map.add k v s) - String_map.empty l - | _ -> () - in - List.iter - (function - | {lid = {txt = Lident name}; x} -> field name x - | _ -> ()) - fields end let ppx_context = Ppx_context.make -let drop_ppx_context_str ~restore = function - | {pstr_desc = Pstr_attribute ({Location.txt = "ocaml.ppx.context"}, a)} +let drop_ppx_context_str = function + | {pstr_desc = Pstr_attribute ({Location.txt = "ocaml.ppx.context"}, _)} :: items -> - if restore then Ppx_context.restore (Ppx_context.get_fields a); items | items -> items -let drop_ppx_context_sig ~restore = function - | {psig_desc = Psig_attribute ({Location.txt = "ocaml.ppx.context"}, a)} +let drop_ppx_context_sig = function + | {psig_desc = Psig_attribute ({Location.txt = "ocaml.ppx.context"}, _)} :: items -> - if restore then Ppx_context.restore (Ppx_context.get_fields a); items | items -> items diff --git a/compiler/ml/ast_mapper.mli b/compiler/ml/ast_mapper.mli index 887c9b4049..d16efadec5 100644 --- a/compiler/ml/ast_mapper.mli +++ b/compiler/ml/ast_mapper.mli @@ -114,12 +114,9 @@ val add_ppx_context_sig : tool_name:string -> Parsetree.signature -> Parsetree.signature (** Same as [add_ppx_context_str], but for signatures. *) -val drop_ppx_context_str : - restore:bool -> Parsetree.structure -> Parsetree.structure -(** Drop the ocaml.ppx.context attribute from a structure. If - [restore] is true, also restore the associated data in the current - process. *) - -val drop_ppx_context_sig : - restore:bool -> Parsetree.signature -> Parsetree.signature +val drop_ppx_context_str : Parsetree.structure -> Parsetree.structure +(** Drop the ocaml.ppx.context attribute from a structure. The compiler does + not take back any of its data, such as cookies a PPX set. *) + +val drop_ppx_context_sig : Parsetree.signature -> Parsetree.signature (** Same as [drop_ppx_context_str], but for signatures. *) diff --git a/tests/ounit_tests/ounit_ast_mapper0_tests.ml b/tests/ounit_tests/ounit_ast_mapper0_tests.ml index 6198163f06..eb5322e1bd 100644 --- a/tests/ounit_tests/ounit_ast_mapper0_tests.ml +++ b/tests/ounit_tests/ounit_ast_mapper0_tests.ml @@ -28,6 +28,54 @@ let record_pat0 attrs = let map_pat0 pat = Ast_mapper_from0.default_mapper.pat Ast_mapper_from0.default_mapper pat +(* The [ocaml.ppx.context] attribute a PPX receives. *) +let ppx_context_fields0 ast0 = + match ast0 with + | Ml_binary.Impl + ({ + Parsetree0.pstr_desc = + Pstr_attribute + ( {txt = "ocaml.ppx.context"}, + PStr + [ + { + pstr_desc = + Pstr_eval ({pexp_desc = Pexp_record (fields, None)}, _); + }; + ] ); + } + :: _) -> + fields + | _ -> assert_failure "the structure starts with the PPX context" + +let test_ppx_context_on_the_wire _ = + let structure = + Ast_mapper.add_ppx_context_str ~tool_name:"rescript" + [ + Ast_helper.Str.eval + (Ast_helper.Exp.constant (Pconst_integer ("1", None))); + ] + in + let fields = + ppx_context_fields0 (Ml_binary.to_ast0 Ml_binary.Ml structure) + |> List.map (fun (({txt} : Longident.t Location.loc), value) -> + (Longident.last txt, value)) + in + OUnit.assert_equal ~printer:(String.concat ", ") + [ + "tool_name"; + "include_dirs"; + "load_path"; + "open_modules"; + "debug"; + "cookies"; + ] + (List.map fst fields); + (match List.assoc "cookies" fields with + | {Parsetree0.pexp_desc = Pexp_construct ({txt = Lident "[]"}, None)} -> () + | _ -> assert_failure "the PPX gets no cookies"); + OUnit.assert_equal 1 (List.length (Ast_mapper.drop_ppx_context_str structure)) + let test_removed_open_pattern_is_rejected_from_ast0 _ = let pat = Ast_helper0.Pat.open_ ~loc @@ -2126,4 +2174,5 @@ let suites = >:: test_field_runtime_name_keeps_ppx_order_on_the_wire; "constructor_runtime_tag_reaches_ast0_as_an_attribute" >:: test_constructor_runtime_tag_reaches_ast0_as_an_attribute; + "ppx_context_on_the_wire" >:: test_ppx_context_on_the_wire; ]