Remove the unused restoring of the PPX context

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

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

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

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

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
 

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. *)

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;
        ]