diff --git a/src/code_matcher.ml b/src/code_matcher.ml index 27cc24c8f..52c2ad491 100644 --- a/src/code_matcher.ml +++ b/src/code_matcher.ml @@ -58,6 +58,13 @@ struct in loop [] l + let see_end_marker item = + match Attribute.Floating.convert_res [ M.end_marker ] item with + | Ok None -> Ok () + | Ok (Some ()) -> Ok () + | Error e -> Error e + | exception Failure _ -> Ok () + let remove_loc = object inherit Ast_traverse.map @@ -212,3 +219,6 @@ let match_signature_res = Sig.do_match let match_signature ~pos ~expected ~mismatch_handler l = match_signature_res ~pos ~expected ~mismatch_handler l |> Result.handle_error ~f:(fun (err, _) -> Location.Error.raise err) + +let see_end_marker_str = Str.see_end_marker +let see_end_marker_sig = Sig.see_end_marker diff --git a/src/code_matcher.mli b/src/code_matcher.mli index 6f1c9e434..fbd843127 100644 --- a/src/code_matcher.mli +++ b/src/code_matcher.mli @@ -39,3 +39,12 @@ val match_signature : signature -> unit (** Same for signatures *) + +(** The following functions mark [@@@deriving.end] as seen. Useful when + purposefully ignoring correction based transformations. *) + +val see_end_marker_str : + structure_item -> (unit, Location.Error.t NonEmptyList.t) result + +val see_end_marker_sig : + signature_item -> (unit, Location.Error.t NonEmptyList.t) result diff --git a/src/context_free.ml b/src/context_free.ml index 81f9e3105..4ce1e950d 100644 --- a/src/context_free.ml +++ b/src/context_free.ml @@ -462,6 +462,35 @@ 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,8 +500,8 @@ 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 let special_functions = @@ -546,6 +575,15 @@ 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 + let see_end_marker f item = + (if no_corrections then f item else Ok ()) |> of_result ~default:() + in object (self) inherit Ast_traverse.map_with_expansion_context_and_errors as super @@ -748,6 +786,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) | [] -> return [] | item :: rest -> ( let loc = item.pstr_loc in + see_end_marker Code_matcher.see_end_marker_str item >>= fun () -> match item.pstr_desc with | Pstr_extension (ext, attrs) -> ( let extension_point_loc = item.pstr_loc in @@ -780,8 +819,8 @@ 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 - ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt + 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 -> with_extra_items expanded_item ~extra_items ~expect_items @@ -790,7 +829,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 +839,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,8 +848,9 @@ 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 - ~expanded_item:exp_ec ~loc ~base_ctxt ~convert_exn + 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 ~rest ~in_generated_code @@ -819,7 +859,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 -> @@ -857,6 +897,7 @@ class map_top_down ?(expect_mismatch_handler = Expect_mismatch_handler.nop) | [] -> return [] | item :: rest -> ( let loc = item.psig_loc in + see_end_marker Code_matcher.see_end_marker_sig item >>= fun () -> match item.psig_desc with | Psig_extension (ext, attrs) -> ( let extension_point_loc = item.psig_loc in @@ -889,8 +930,8 @@ 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 - ~items:tds ~expanded_items:exp_tds ~loc ~base_ctxt + 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 -> with_extra_items expanded_item ~extra_items ~expect_items @@ -899,7 +940,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 +950,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,8 +959,9 @@ 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 - ~expanded_item:exp_ec ~loc ~base_ctxt ~convert_exn + 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 ~rest ~in_generated_code @@ -928,7 +970,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 -> diff --git a/src/context_free.mli b/src/context_free.mli index c59c04731..e7a09f677 100644 --- a/src/context_free.mli +++ b/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 diff --git a/src/driver.ml b/src/driver.ml index 5d91a6b42..cb62af690 100644 --- a/src/driver.ml +++ b/src/driver.ml @@ -24,6 +24,7 @@ let pretty = ref false let styler = ref None let output_metadata_filename = ref None let corrected_suffix = ref ".ppx-corrected" +let no_corrections = ref false let ghost = object @@ -218,12 +219,13 @@ 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 - ~tool_name ~input_name = + 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 @@ -455,8 +457,8 @@ 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 - ~input_name = +let get_whole_ast_passes ~no_corrections ~embed_errors ~hook + ~expect_mismatch_handler ~tool_name ~input_name = let cts = match !apply_list with | None -> List.rev !Transform.all @@ -485,8 +487,8 @@ 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 - ~expect_mismatch_handler ~input_name) + (Transform.merge_into_generic_mappers ~no_corrections ~embed_errors + ~hook ~tool_name ~expect_mismatch_handler ~input_name) else (let get_enclosers ~f = List.filter_map transforms ~f:(fun (ct : Transform.t) -> @@ -516,8 +518,8 @@ 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 - ~hook ~expect_mismatch_handler + 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) ~tool_name ~input_name @@ -528,10 +530,11 @@ 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 - ~input_name + get_whole_ast_passes ~tool_name ~no_corrections ~embed_errors ~hook + ~expect_mismatch_handler ~input_name in let finish (ast, _dropped, lint_errors, errors) = ( ast, @@ -611,11 +614,12 @@ 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 - ~input_name:None + get_whole_ast_passes ~no_corrections ~embed_errors ~hook + ~expect_mismatch_handler ~tool_name ~input_name:None in if !perform_checks then Printf.printf "\n"; @@ -634,7 +638,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 (); @@ -693,7 +697,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) @@ -703,14 +707,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 (); @@ -769,7 +773,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) @@ -779,7 +783,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 @@ -1037,13 +1041,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 @@ -1052,14 +1056,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 := []; @@ -1097,7 +1101,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 -> @@ -1409,6 +1413,9 @@ let standalone_args = ( "-corrected-suffix", Arg.Set_string corrected_suffix, "SUFFIX Suffix to append to corrected files" ); + ( "-no-corrections", + Arg.Set no_corrections, + "Skip correction generations such as [@@deriving_inline]" ); ] let get_args ?(standalone_args = standalone_args) () = @@ -1447,6 +1454,7 @@ let standalone_main () = in process_file kind fn ~input_name ~relocate ~output_mode:!output_mode ~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 @@ -1457,7 +1465,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 -> diff --git a/test/driver/no-corrections/driver_all.ml b/test/driver/no-corrections/driver_all.ml new file mode 100644 index 000000000..e3cba4049 --- /dev/null +++ b/test/driver/no-corrections/driver_all.ml @@ -0,0 +1 @@ +let () = Ppxlib.Driver.standalone () diff --git a/test/driver/no-corrections/driver_deriving_x.ml b/test/driver/no-corrections/driver_deriving_x.ml new file mode 100644 index 000000000..e3cba4049 --- /dev/null +++ b/test/driver/no-corrections/driver_deriving_x.ml @@ -0,0 +1 @@ +let () = Ppxlib.Driver.standalone () diff --git a/test/driver/no-corrections/dune b/test/driver/no-corrections/dune new file mode 100644 index 000000000..1a7f25e85 --- /dev/null +++ b/test/driver/no-corrections/dune @@ -0,0 +1,36 @@ +(library + (name ppx_deriving_x) + (modules ppx_deriving_x) + (libraries ppxlib) + (preprocess + (pps ppxlib.metaquot)) + (kind ppx_deriver)) + +(library + (name ppx_deriving_y) + (modules ppx_deriving_y) + (libraries ppxlib) + (preprocess + (pps ppxlib.metaquot)) + (kind ppx_deriver)) + +(library + (name ppx_gen_stuff) + (modules ppx_gen_stuff) + (libraries ppxlib) + (preprocess + (pps ppxlib.metaquot)) + (kind ppx_deriver)) + +(executable + (name driver_all) + (modules driver_all) + (libraries ppxlib ppx_deriving_x ppx_deriving_y ppx_gen_stuff)) + +(executable + (name driver_deriving_x) + (modules driver_deriving_x) + (libraries ppxlib ppx_deriving_x)) + +(cram + (deps driver_all.exe driver_deriving_x.exe)) diff --git a/test/driver/no-corrections/ppx_deriving_x.ml b/test/driver/no-corrections/ppx_deriving_x.ml new file mode 100644 index 000000000..035cf0e1b --- /dev/null +++ b/test/driver/no-corrections/ppx_deriving_x.ml @@ -0,0 +1,8 @@ +open Ppxlib + +let str_type_decl = + Deriving.Generator.V2.make_noarg (fun ~ctxt _type_decl -> + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + [%str let x = 2]) + +let _ = Deriving.add ~str_type_decl "x" diff --git a/test/driver/no-corrections/ppx_deriving_y.ml b/test/driver/no-corrections/ppx_deriving_y.ml new file mode 100644 index 000000000..208b2d5f7 --- /dev/null +++ b/test/driver/no-corrections/ppx_deriving_y.ml @@ -0,0 +1,8 @@ +open Ppxlib + +let str_type_decl = + Deriving.Generator.V2.make_noarg (fun ~ctxt _type_decl -> + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + [%str let y = 3]) + +let _ = Deriving.add ~str_type_decl "y" diff --git a/test/driver/no-corrections/ppx_gen_stuff.ml b/test/driver/no-corrections/ppx_gen_stuff.ml new file mode 100644 index 000000000..fd97c0f5b --- /dev/null +++ b/test/driver/no-corrections/ppx_gen_stuff.ml @@ -0,0 +1,10 @@ +open Ppxlib + +let attr = Attribute.declare_flag "gen_stuff" Attribute.Context.type_declaration + +let expand ~ctxt _rec_flag _type_decl _values = + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + [%str let stuff = 4] + +let rules = [ Context_free.Rule.attr_str_type_decl_expect attr expand ] +let () = Driver.V2.register_transformation ~rules "gen_stuff" diff --git a/test/driver/no-corrections/run.t b/test/driver/no-corrections/run.t new file mode 100644 index 000000000..573fa111e --- /dev/null +++ b/test/driver/no-corrections/run.t @@ -0,0 +1,125 @@ +Here we will test the -no-corrections flag. + +First, a bit of context on that feature: + +Before the introduction of this flag, the only viable use case for +someone that wanted to use [@@deriving_inline ...] to avoid having a build +dependency on a ppx was fairly limited. They couldn't use anything but +correction based ppx-es, i.e. [@@deriving_inline] itself or ppx-es that used the +same correction style. +The way they had to go about it was to have no preprocess field declared in their +dune file, i.e. at build time no ppx were involved. They would run those ppx by +configuring a (lint (pps ...)) field instead in their dune file. + +There are situations where one might want to use a set of ppx-es without having +a dependency on a subset of those and this was not possible because the driver +would error out upon finding a `[@@deriving_inline x]` node when ppx x was not +linked with the driver. That means that you had to add ppx-es used with +deriving_inline to your (preprocess (pps ...)) field, making them a build +dependency of your project and defeating the purpose of [@@deriving_inline]. + +The -no-correction flag allows to work around this limitation. By adding +this flag to the driver invocation (it can be done by adding the flag directly +to the (preprocess (pps ...)) field), [@@deriving_inline] and other such +attributes are properly ignored. + +Now with the test. + +To properly test this we define three ppx-es: +- ppx_deriving_x which is a regular deriver +- ppx_deriving_y which is another regular deriver but one that we'll only use +with [@@deriving_inline] +- ppx_gen_stuff which is a custom ppx that use the same mechanism as +[@@deriving_inline] and that should also be ignored when -no-corrections is +passed + +We also manually build two different drivers: +- driver_all.exe which is a driver with all three ppx-es linked, that +corresponds to the driver dune would generate for the (lint (pps ...)) field +- driver_deriving_x which is a driver with only ppx_deriving_x linked, that +corresponds to the driver dune would generate for the (preprocess (pps ...)) +field + +Let's consider the following source file: + + $ cat > test.ml << EOF + > type t [@@deriving x] + > type t2 + > [@@deriving_inline y] + > [@@@deriving.end] + > type t3 [@@gen_stuff] + > [@@@deriving.end] + > EOF + +If we run our driver for preprocessing, it will produce errors for the unknown +deriver y in the .ppx-corrected along with unused attribute errors for [@@gen_stuff] +and the last [@@@deriving.end] that comes with it. + + $ ./driver_deriving_x.exe -impl test.ml -check -diff-cmd diff + [%%ocaml.error "Attribute `gen_stuff' was not used"] + [%%ocaml.error "Attribute `deriving.end' was not used"] + type t[@@deriving x] + include struct let _ = fun (_ : t) -> () + let x = 2 + let _ = x end[@@ocaml.doc "@inline"][@@merlin.hide ] + type t2[@@deriving_inline y] + [@@@deriving.end ] + type t3[@@gen_stuff ] + [@@@deriving.end ] + 3a4,6 + > let _ = fun (_ : t2) -> () + > [%%ocaml.error + > "Ppxlib.Deriving: 'y' is not a supported type deriving generator"] + [1] + +Now if we run it with -no-corrections, there should be no .ppx-corrected file +and associated diff and the [@@@deriving.end] attribute error should go away. +We unfortunately cannot prevent the unused [@@gen_stuff] attribute as the driver +has no knowledge of it but we consider this to be an okay limitation, especially +since the unused attributes check is disabled by default. + + $ ./driver_deriving_x.exe -impl test.ml -check -no-corrections -diff-cmd diff + [%%ocaml.error "Attribute `gen_stuff' was not used"] + type t[@@deriving x] + include struct let _ = fun (_ : t) -> () + let x = 2 + let _ = x end[@@ocaml.doc "@inline"][@@merlin.hide ] + type t2[@@deriving_inline y] + [@@@deriving.end ] + type t3[@@gen_stuff ] + [@@@deriving.end ] + +Now if we run our driver with the whole set of ppx-es, everything should go as +expected and all corrections will be correctly generated + + $ ./driver_all.exe -impl test.ml -check -diff-cmd diff + type t[@@deriving x] + include struct let _ = fun (_ : t) -> () + let x = 2 + let _ = x end[@@ocaml.doc "@inline"][@@merlin.hide ] + type t2[@@deriving_inline y] + [@@@deriving.end ] + type t3[@@gen_stuff ] + [@@@deriving.end ] + 3a4,6 + > let _ = fun (_ : t2) -> () + > let y = 3 + > let _ = y + 5a9 + > let stuff = 4 + [1] + +For reference and to document the behaviour of the -no-corrections flag in this +situation, running the same driver with the flag will generate no corrections and +no attribute warnings since this time, it knows about the [@@gen_stuff] attribute +and explicitly skips it. + + $ ./driver_all.exe -impl test.ml -check -no-corrections -diff-cmd diff + type t[@@deriving x] + include struct let _ = fun (_ : t) -> () + let x = 2 + let _ = x end[@@ocaml.doc "@inline"][@@merlin.hide ] + type t2[@@deriving_inline y] + [@@@deriving.end ] + type t3[@@gen_stuff ] + [@@@deriving.end ]