TMP: Implement -no-corrections

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

src/context_free.ml

@@ -462,6 +462,36 @@ let handle_attr_inline attrs ~convert_exn ~item ~expanded_item ~loc ~base_ctxt
             let error_item = [ convert_exn exn ] in
             return (error_item :: acc)))
 
+let handle_attr_group_inline_expect attrs rf ~items ~expanded_items ~loc ~base_ctxt
+      ~embed_errors ~convert_exn ~no_corrections =
+  if no_corrections then
+    (* Mark expect attributes as seen *)
+    List.fold_left attrs ~init:(return ())
+      ~f:(fun acc (Rule.Attr_group_inline.T group) ->
+        acc >>= fun () ->
+        get_group group.attribute items >>= fun _ ->
+        get_group group.attribute expanded_items >>= fun _ ->
+        return ())
+    >>= fun () -> return []
+  else
+    handle_attr_group_inline attrs rf ~items ~expanded_items ~loc ~base_ctxt
+      ~embed_errors ~convert_exn
+
+let handle_attr_inline_expect attrs ~convert_exn ~item ~expanded_item ~loc ~base_ctxt
+      ~embed_errors ~no_corrections =
+  if no_corrections then
+    (* Mark expect attributes as seen *)
+    List.fold_left attrs ~init:(return ())
+      ~f:(fun acc (Rule.Attr_inline.T a) ->
+        acc >>= fun () ->
+        Attribute.get_res a.attribute item |> of_result ~default:None >>= fun _ ->
+        Attribute.get_res a.attribute expanded_item |> of_result ~default:None >>= fun _ ->
+        return ())
+    >>= fun () -> return []
+  else
+    handle_attr_inline attrs ~item ~expanded_item ~loc ~base_ctxt
+      ~embed_errors ~convert_exn
+
 module Expect_mismatch_handler = struct
   type t = {
     f : 'a. 'a Attribute.Floating.Context.t -> Location.t -> 'a list -> unit;
@@ -471,7 +501,9 @@ module Expect_mismatch_handler = struct
 end
 
 class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
-  ?(generated_code_hook = Generated_code_hook.nop) ?(embed_errors = false) rules
+        ?(generated_code_hook = Generated_code_hook.nop) ?(embed_errors = false)
+        ?(no_corrections = false)
+        rules
   =
   let hook = generated_code_hook in
 
@@ -546,6 +578,12 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
   let map_nodes = map_nodes ~hook ~embed_errors in
   let handle_attr_group_inline = handle_attr_group_inline ~embed_errors in
   let handle_attr_inline = handle_attr_inline ~embed_errors in
+  let handle_attr_group_inline_expect =
+    handle_attr_group_inline_expect ~no_corrections ~embed_errors
+  in
+  let handle_attr_inline_expect =
+    handle_attr_inline_expect ~no_corrections ~embed_errors
+  in
 
   object (self)
     inherit Ast_traverse.map_with_expansion_context_and_errors as super
@@ -780,7 +818,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
                     handle_attr_group_inline attr_str_type_decls rf ~items:tds
                       ~expanded_items:exp_tds ~loc ~base_ctxt ~convert_exn
                     >>= fun extra_items ->
-                    handle_attr_group_inline attr_str_type_decls_expect rf
+                    handle_attr_group_inline_expect attr_str_type_decls_expect rf
                       ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt
                       ~convert_exn
                     >>= fun expect_items ->
@@ -790,7 +828,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
                     handle_attr_inline attr_str_module_type_decls ~item:mtd
                       ~expanded_item:exp_mtd ~loc ~base_ctxt ~convert_exn
                     >>= fun extra_items ->
-                    handle_attr_inline attr_str_module_type_decls_expect
+                    handle_attr_inline_expect attr_str_module_type_decls_expect
                       ~item:mtd ~expanded_item:exp_mtd ~loc ~base_ctxt
                       ~convert_exn
                     >>= fun expect_items ->
@@ -800,7 +838,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
                     handle_attr_inline attr_str_type_exts ~item:te
                       ~expanded_item:exp_te ~loc ~base_ctxt ~convert_exn
                     >>= fun extra_items ->
-                    handle_attr_inline attr_str_type_exts_expect ~item:te
+                    handle_attr_inline_expect attr_str_type_exts_expect ~item:te
                       ~expanded_item:exp_te ~loc ~base_ctxt ~convert_exn
                     >>= fun expect_items ->
                     with_extra_items expanded_item ~extra_items ~expect_items
@@ -809,7 +847,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
                     handle_attr_inline attr_str_exceptions ~item:ec
                       ~expanded_item:exp_ec ~loc ~base_ctxt ~convert_exn
                     >>= fun extra_items ->
-                    handle_attr_inline attr_str_exceptions_expect ~item:ec
+                    handle_attr_inline_expect attr_str_exceptions_expect ~item:ec
                       ~expanded_item:exp_ec ~loc ~base_ctxt ~convert_exn
                     >>= fun expect_items ->
                     with_extra_items expanded_item ~extra_items ~expect_items
@@ -819,7 +857,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
                       ~items:cds ~expanded_items:exp_cds ~loc ~base_ctxt
                       ~convert_exn
                     >>= fun extra_items ->
-                    handle_attr_group_inline attr_str_class_decls_expect
+                    handle_attr_group_inline_expect attr_str_class_decls_expect
                       Nonrecursive ~items:cds ~expanded_items:exp_cds ~loc
                       ~base_ctxt ~convert_exn
                     >>= fun expect_items ->
@@ -889,7 +927,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
                     handle_attr_group_inline attr_sig_type_decls rf ~items:tds
                       ~expanded_items:exp_tds ~loc ~base_ctxt ~convert_exn
                     >>= fun extra_items ->
-                    handle_attr_group_inline attr_sig_type_decls_expect rf
+                    handle_attr_group_inline_expect attr_sig_type_decls_expect rf
                       ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt
                       ~convert_exn
                     >>= fun expect_items ->
@@ -899,7 +937,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
                     handle_attr_inline attr_sig_module_type_decls ~item:mtd
                       ~expanded_item:exp_mtd ~loc ~base_ctxt ~convert_exn
                     >>= fun extra_items ->
-                    handle_attr_inline attr_sig_module_type_decls_expect
+                    handle_attr_inline_expect attr_sig_module_type_decls_expect
                       ~item:mtd ~expanded_item:exp_mtd ~loc ~base_ctxt
                       ~convert_exn
                     >>= fun expect_items ->
@@ -909,7 +947,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
                     handle_attr_inline attr_sig_type_exts ~item:te
                       ~expanded_item:exp_te ~loc ~base_ctxt ~convert_exn
                     >>= fun extra_items ->
-                    handle_attr_inline attr_sig_type_exts_expect ~item:te
+                    handle_attr_inline_expect attr_sig_type_exts_expect ~item:te
                       ~expanded_item:exp_te ~loc ~base_ctxt ~convert_exn
                     >>= fun expect_items ->
                     with_extra_items expanded_item ~extra_items ~expect_items
@@ -918,7 +956,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
                     handle_attr_inline attr_sig_exceptions ~item:ec
                       ~expanded_item:exp_ec ~loc ~base_ctxt ~convert_exn
                     >>= fun extra_items ->
-                    handle_attr_inline attr_sig_exceptions_expect ~item:ec
+                    handle_attr_inline_expect attr_sig_exceptions_expect ~item:ec
                       ~expanded_item:exp_ec ~loc ~base_ctxt ~convert_exn
                     >>= fun expect_items ->
                     with_extra_items expanded_item ~extra_items ~expect_items
@@ -928,7 +966,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop)
                       ~items:cds ~expanded_items:exp_cds ~loc ~base_ctxt
                       ~convert_exn
                     >>= fun extra_items ->
-                    handle_attr_group_inline attr_sig_class_decls_expect
+                    handle_attr_group_inline_expect attr_sig_class_decls_expect
                       Nonrecursive ~items:cds ~expanded_items:exp_cds ~loc
                       ~base_ctxt ~convert_exn
                     >>= fun expect_items ->

src/context_free.mli

@@ -166,6 +166,7 @@ class map_top_down :
   ?generated_code_hook:
     Generated_code_hook.t (* default: Generated_code_hook.nop *) ->
   ?embed_errors:bool ->
+  ?no_corrections:bool ->
   Rule.t list ->
 object
   inherit Ast_traverse.map_with_expansion_context_and_errors

src/driver.ml

@@ -219,12 +219,12 @@ module Transform = struct
         let last = get_loc (last x l) in
         Some { first with loc_end = last.loc_end }
 
-  let merge_into_generic_mappers t ~embed_errors ~hook ~expect_mismatch_handler
+  let merge_into_generic_mappers t ~no_corrections ~embed_errors ~hook ~expect_mismatch_handler
       ~tool_name ~input_name =
     let { rules; enclose_impl; enclose_intf; impl; intf; _ } = t in
     let map =
       new Context_free.map_top_down
-        rules ~embed_errors ~generated_code_hook:hook ~expect_mismatch_handler
+        rules ~no_corrections ~embed_errors ~generated_code_hook:hook ~expect_mismatch_handler
     in
     let gen_header_and_footer context whole_loc f =
       let header, footer = f whole_loc in
@@ -456,7 +456,7 @@ let debug_dropped_attribute name ~old_dropped ~new_dropped =
   print_diff "disappeared" new_dropped old_dropped;
   print_diff "reappeared" old_dropped new_dropped
 
-let get_whole_ast_passes ~embed_errors ~hook ~expect_mismatch_handler ~tool_name
+let get_whole_ast_passes ~no_corrections ~embed_errors ~hook ~expect_mismatch_handler ~tool_name
     ~input_name =
   let cts =
     match !apply_list with
@@ -486,7 +486,7 @@ let get_whole_ast_passes ~embed_errors ~hook ~expect_mismatch_handler ~tool_name
     if !no_merge then
       List.map transforms
         ~f:
-          (Transform.merge_into_generic_mappers ~embed_errors ~hook ~tool_name
+          (Transform.merge_into_generic_mappers ~no_corrections ~embed_errors ~hook ~tool_name
              ~expect_mismatch_handler ~input_name)
     else
       (let get_enclosers ~f =
@@ -517,7 +517,7 @@ let get_whole_ast_passes ~embed_errors ~hook ~expect_mismatch_handler ~tool_name
                      let footers = List.concat (List.rev footers) in
                      (headers, footers))
            in
-           Transform.builtin_of_context_free_rewriters ~rules ~embed_errors
+           Transform.builtin_of_context_free_rewriters ~rules ~no_corrections ~embed_errors
              ~hook ~expect_mismatch_handler
              ~enclose_impl:(merge_encloser impl_enclosers)
              ~enclose_intf:(merge_encloser intf_enclosers)
@@ -529,9 +529,9 @@ let get_whole_ast_passes ~embed_errors ~hook ~expect_mismatch_handler ~tool_name
   linters @ preprocess @ before_instrs @ make_generic cts @ after_instrs
 
 let apply_transforms ~tool_name ~file_path ~field ~lint_field ~dropped_so_far
-    ~hook ~expect_mismatch_handler ~input_name ~embed_errors ast =
+    ~hook ~expect_mismatch_handler ~input_name ~no_corrections ~embed_errors ast =
   let cts =
-    get_whole_ast_passes ~tool_name ~embed_errors ~hook ~expect_mismatch_handler
+    get_whole_ast_passes ~tool_name ~no_corrections ~embed_errors ~hook ~expect_mismatch_handler
       ~input_name
   in
   let finish (ast, _dropped, lint_errors, errors) =
@@ -612,10 +612,11 @@ let exn_to_extension exn ~(kind : Kind.t) =
 let print_passes () =
   let tool_name = "ppxlib_driver" in
   let embed_errors = false in
+  let no_corrections = false in
   let hook = Context_free.Generated_code_hook.nop in
   let expect_mismatch_handler = Context_free.Expect_mismatch_handler.nop in
   let cts =
-    get_whole_ast_passes ~embed_errors ~hook ~expect_mismatch_handler ~tool_name
+    get_whole_ast_passes ~no_corrections ~embed_errors ~hook ~expect_mismatch_handler ~tool_name
       ~input_name:None
   in
   if !perform_checks then
@@ -635,7 +636,7 @@ let sort_errors_by_loc errors =
 (*$*)
 
 let map_structure_gen st ~tool_name ~hook ~expect_mismatch_handler ~input_name
-    ~embed_errors =
+    ~embed_errors ~no_corrections =
   Cookies.acknowledge_cookies T;
   if !perform_checks then (
     Attribute.reset_checks ();
@@ -694,7 +695,7 @@ let map_structure_gen st ~tool_name ~hook ~expect_mismatch_handler ~input_name
       ~field:(fun (ct : Transform.t) -> ct.impl)
       ~lint_field:(fun (ct : Transform.t) -> ct.lint_impl)
       ~dropped_so_far:Attribute.dropped_so_far_structure ~hook
-      ~expect_mismatch_handler ~input_name ~embed_errors
+      ~expect_mismatch_handler ~input_name ~embed_errors ~no_corrections
   in
   st |> lint lint_errors |> cookies_and_check |> with_errors (List.rev errors)
 
@@ -704,14 +705,14 @@ let map_structure st =
       ~tool_name:(Astlib.Ast_metadata.tool_name ())
       ~hook:Context_free.Generated_code_hook.nop
       ~expect_mismatch_handler:Context_free.Expect_mismatch_handler.nop
-      ~input_name:None ~embed_errors:false
+      ~input_name:None ~embed_errors:false ~no_corrections:false
   with
   | ast -> ast
 
 (*$ str_to_sig _last_text_block *)
 
 let map_signature_gen sg ~tool_name ~hook ~expect_mismatch_handler ~input_name
-    ~embed_errors =
+    ~embed_errors ~no_corrections =
   Cookies.acknowledge_cookies T;
   if !perform_checks then (
     Attribute.reset_checks ();
@@ -770,7 +771,7 @@ let map_signature_gen sg ~tool_name ~hook ~expect_mismatch_handler ~input_name
       ~field:(fun (ct : Transform.t) -> ct.intf)
       ~lint_field:(fun (ct : Transform.t) -> ct.lint_intf)
       ~dropped_so_far:Attribute.dropped_so_far_signature ~hook
-      ~expect_mismatch_handler ~input_name ~embed_errors
+      ~expect_mismatch_handler ~input_name ~embed_errors ~no_corrections
   in
   sg |> lint lint_errors |> cookies_and_check |> with_errors (List.rev errors)
 
@@ -780,7 +781,7 @@ let map_signature sg =
       ~tool_name:(Astlib.Ast_metadata.tool_name ())
       ~hook:Context_free.Generated_code_hook.nop
       ~expect_mismatch_handler:Context_free.Expect_mismatch_handler.nop
-      ~input_name:None ~embed_errors:false
+      ~input_name:None ~embed_errors:false ~no_corrections:false
   with
   | ast -> ast
 
@@ -1038,13 +1039,13 @@ struct
 end
 
 let process_ast (ast : Intf_or_impl.t) ~input_name ~tool_name ~hook
-    ~expect_mismatch_handler ~embed_errors =
+    ~expect_mismatch_handler ~embed_errors ~no_corrections =
   match ast with
   | Intf x ->
       let ast =
         match
           map_signature_gen x ~tool_name ~hook ~expect_mismatch_handler
-            ~input_name:(Some input_name) ~embed_errors
+            ~input_name:(Some input_name) ~embed_errors ~no_corrections
         with
         | ast -> ast
       in
@@ -1053,14 +1054,14 @@ let process_ast (ast : Intf_or_impl.t) ~input_name ~tool_name ~hook
       let ast =
         match
           map_structure_gen x ~tool_name ~hook ~expect_mismatch_handler
-            ~input_name:(Some input_name) ~embed_errors
+            ~input_name:(Some input_name) ~embed_errors ~no_corrections
         with
         | ast -> ast
       in
       Intf_or_impl.Impl ast
 
 let process_file (kind : Kind.t) fn ~input_name ~relocate ~output_mode
-    ~embed_errors ~output =
+    ~embed_errors ~no_corrections ~output =
   File_property.reset_all ();
   List.iter (List.rev !process_file_hooks) ~f:(fun f -> f ());
   corrections := [];
@@ -1098,7 +1099,7 @@ let process_file (kind : Kind.t) fn ~input_name ~relocate ~output_mode
           let ast =
             extract_cookies ast
             |> process_ast ~input_name ~tool_name ~hook ~expect_mismatch_handler
-                 ~embed_errors
+                 ~embed_errors ~no_corrections
           in
           (input_fname, input_version, ast)
         with exn when embed_errors ->
@@ -1450,7 +1451,7 @@ let standalone_main () =
         match !loc_fname with None -> (fn, false) | Some fn -> (fn, true)
       in
       process_file kind fn ~input_name ~relocate ~output_mode:!output_mode
-        ~output:!output ~embed_errors:!embed_errors
+        ~output:!output ~embed_errors:!embed_errors ~no_corrections:!no_corrections
 
 let rewrite_binary_ast_file input_fn output_fn =
   let input_name, input_version, ast = load_input_run_as_ppx input_fn in
@@ -1461,7 +1462,7 @@ let rewrite_binary_ast_file input_fn output_fn =
       let hook = Context_free.Generated_code_hook.nop in
       let expect_mismatch_handler = Context_free.Expect_mismatch_handler.nop in
       process_ast ast ~input_name ~tool_name ~hook ~expect_mismatch_handler
-        ~embed_errors:true
+        ~embed_errors:true ~no_corrections:false
     with exn -> exn_to_extension exn ~kind:(Intf_or_impl.kind ast)
   in
   with_output (Some output_fn) ~binary:true ~f:(fun oc ->