From 25266ebef4c12c4b636f51a75ebcbe9ce1fd88f3 Mon Sep 17 00:00:00 2001 From: Christoph Knittel Date: Tue, 13 Oct 2026 14:52:11 +0000 Subject: [PATCH] Remove the unused restoring of the PPX context Every caller drops the context without restoring it, so the cookie store was never filled. PPXs still receive an empty cookies field. Co-Authored-By: Claude Opus 5.5 Claude-Session: https://claude.ai/code/session_01WZbCuRQ1Tn31bnKzLj5e72 Signed-off-by: Christoph Knittel --- .../remove-ppx-context-restore.internal.md | 1 + compiler/bsc/rescript_compiler_main.ml | 6 +- compiler/core/cmd_ppx_apply.ml | 16 +-- compiler/core/js_implementation.ml | 6 +- compiler/ml/ast_mapper.ml | 105 +----------------- compiler/ml/ast_mapper.mli | 13 +-- tests/ounit_tests/ounit_ast_mapper0_tests.ml | 49 ++++++++ 7 files changed, 73 insertions(+), 123 deletions(-) create mode 100644 changes/remove-ppx-context-restore.internal.md diff --git a/changes/remove-ppx-context-restore.internal.md b/changes/remove-ppx-context-restore.internal.md new file mode 100644 index 00000000000..561172619bd --- /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 949d42f6c5f..463fd73a63b 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 111eae078d2..6dde3d56d8f 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 265adedb2bd..d4008617d81 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 cc0da9a6325..b1c8e151a3c 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 887c9b4049d..d16efadec55 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 6198163f066..eb5322e1bd9 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; ]