From 0609ceae388fccb592cd53b9aa3601b4eac60c17 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Tue, 19 Mar 2024 17:50:49 +0100 Subject: [PATCH] Add -dune-optional-output mode for dune's internal use Fixes #461 This PR adds a new command line flag that tells the driver not to write to the output file if there is no rewriting to be done. It's not 100% accurate if there are non context free transformations registered as we do not compare the AST for this feature but simply keep track of generated code via a hook. If any non context free transformation is registered, we simply assume it will rewrite something and always output. Signed-off-by: Nathan Rebours --- CHANGES.md | 2 + src/driver.ml | 90 +++++++++++++------ .../context_free_only_driver.ml | 12 +++ .../dune-optional-output/driver_with_impl.ml | 16 ++++ test/driver/dune-optional-output/dune | 16 ++++ test/driver/dune-optional-output/run.t | 52 +++++++++++ .../run_as_ppx_rewriter_preserve_version/dune | 4 + 7 files changed, 166 insertions(+), 26 deletions(-) create mode 100644 test/driver/dune-optional-output/context_free_only_driver.ml create mode 100644 test/driver/dune-optional-output/driver_with_impl.ml create mode 100644 test/driver/dune-optional-output/dune create mode 100644 test/driver/dune-optional-output/run.t diff --git a/CHANGES.md b/CHANGES.md index 2fe145e83..475aaaea4 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,8 @@ unreleased ---------- +- Add `-dune-optional-output` mode for dune's internal use + (#482, @NathanReb) - Insert errors from caught located exceptions in place of the code that should have been generated by context-free rules. (#472, @NathanReb) diff --git a/src/driver.ml b/src/driver.ml index 659df1d3f..41abe6cf5 100644 --- a/src/driver.ml +++ b/src/driver.ml @@ -304,11 +304,13 @@ module Transform = struct in { t with impl = Some map_impl; intf = Some map_intf } + let builtin_context_free_name = "" + let builtin_of_context_free_rewriters ~hook ~rules ~enclose_impl ~enclose_intf ~input_name = merge_into_generic_mappers ~hook ~input_name { - name = ""; + name = builtin_context_free_name; aliases = []; impl = None; intf = None; @@ -323,6 +325,21 @@ module Transform = struct registered_at = Caller_id.get ~skip:[]; } + (* Meant to be used after partitioning *) + let rewrites_not_context_free t = + match t with + | { name; _ } when String.equal name builtin_context_free_name -> false + | { + impl = None; + intf = None; + instrument = None; + preprocess_impl = None; + preprocess_intf = None; + _; + } -> + false + | _ -> true + let partition_transformations ts = let before_instrs, after_instrs, rest = List.fold_left ts ~init:([], [], []) ~f:(fun (bef_i, aft_i, rest) t -> @@ -528,11 +545,21 @@ 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 ~embed_errors ?rewritten ast = + let _ = rewritten in let cts = get_whole_ast_passes ~tool_name ~embed_errors ~hook ~expect_mismatch_handler ~input_name in + (match rewritten with + | None -> () + | Some rewritten -> ( + match List.filter cts ~f:Transform.rewrites_not_context_free with + | [] -> () + | _ -> + (* We won't be able to accurately tell whether any rewriting has + happened *) + rewritten := true)); let finish (ast, _dropped, lint_errors, errors) = ( ast, List.map lint_errors ~f:(fun (loc, s) -> @@ -633,8 +660,8 @@ let sort_errors_by_loc errors = (*$*) -let map_structure_gen st ~tool_name ~hook ~expect_mismatch_handler ~input_name - ~embed_errors = +let map_structure_gen ~tool_name ~hook ~expect_mismatch_handler ~input_name + ~embed_errors ?rewritten st = Cookies.acknowledge_cookies T; if !perform_checks then ( Attribute.reset_checks (); @@ -693,7 +720,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 ?rewritten in st |> lint lint_errors |> cookies_and_check |> with_errors (List.rev errors) @@ -703,14 +730,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 ?rewritten:None with | ast -> ast (*$ str_to_sig _last_text_block *) -let map_signature_gen sg ~tool_name ~hook ~expect_mismatch_handler ~input_name - ~embed_errors = +let map_signature_gen ~tool_name ~hook ~expect_mismatch_handler ~input_name + ~embed_errors ?rewritten sg = Cookies.acknowledge_cookies T; if !perform_checks then ( Attribute.reset_checks (); @@ -769,7 +796,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 ?rewritten in sg |> lint lint_errors |> cookies_and_check |> with_errors (List.rev errors) @@ -779,7 +806,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 ?rewritten:None with | ast -> ast @@ -917,6 +944,7 @@ type output_mode = | Dparsetree | Reconcile of Reconcile.mode | Null + | Dune_optional_output (*$*) let extract_cookies_str st = @@ -1036,14 +1064,14 @@ struct let set x = t.data <- Some x end -let process_ast (ast : Intf_or_impl.t) ~input_name ~tool_name ~hook - ~expect_mismatch_handler ~embed_errors = +let process_ast ~input_name ~tool_name ~hook ~expect_mismatch_handler + ~embed_errors ?rewritten (ast : Intf_or_impl.t) = 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 ?rewritten with | ast -> ast in @@ -1052,18 +1080,28 @@ 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 ?rewritten with | ast -> ast in Intf_or_impl.Impl ast +let pp_ast ~output (ast : Intf_or_impl.t) = + with_output output ~binary:false ~f:(fun oc -> + let ppf = Stdlib.Format.formatter_of_out_channel oc in + (match ast with + | Intf ast -> Pprintast.signature ppf ast + | Impl ast -> Pprintast.structure ppf ast); + let null_ast = match ast with Intf [] | Impl [] -> true | _ -> false in + if not null_ast then Stdlib.Format.pp_print_newline ppf ()) + let process_file (kind : Kind.t) fn ~input_name ~relocate ~output_mode ~embed_errors ~output = File_property.reset_all (); List.iter (List.rev !process_file_hooks) ~f:(fun f -> f ()); corrections := []; let replacements = ref [] in + let rewritten = ref false in let tool_name = "ppx_driver" in let hook : Context_free.Generated_code_hook.t = match output_mode with @@ -1075,6 +1113,7 @@ let process_file (kind : Kind.t) fn ~input_name ~relocate ~output_mode (Reconcile.Replacement.make () ~context:(Extension context) ~start:loc.loc_start ~stop:loc.loc_end ~repl:generated)); } + | Dune_optional_output -> { f = (fun _ _ _ -> rewritten := true) } | _ -> Context_free.Generated_code_hook.nop in let expect_mismatch_handler : Context_free.Expect_mismatch_handler.t = @@ -1097,7 +1136,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 ~rewritten in (input_fname, input_version, ast) with exn when embed_errors -> @@ -1134,16 +1173,8 @@ let process_file (kind : Kind.t) fn ~input_name ~relocate ~output_mode (match output_mode with | Null -> () - | Pretty_print -> - with_output output ~binary:false ~f:(fun oc -> - let ppf = Stdlib.Format.formatter_of_out_channel oc in - (match ast with - | Intf ast -> Pprintast.signature ppf ast - | Impl ast -> Pprintast.structure ppf ast); - let null_ast = - match ast with Intf [] | Impl [] -> true | _ -> false - in - if not null_ast then Stdlib.Format.pp_print_newline ppf ()) + | Pretty_print -> pp_ast ~output ast + | Dune_optional_output -> if !rewritten then pp_ast ~output ast | Dump_ast -> with_output output ~binary:true ~f:(fun oc -> Ast_io.write oc @@ -1191,7 +1222,10 @@ let set_output_mode mode = match (!output_mode, mode) with | Pretty_print, _ -> output_mode := mode | _, Pretty_print -> assert false - | Dump_ast, Dump_ast | Dparsetree, Dparsetree -> () + | Dune_optional_output, Dune_optional_output + | Dump_ast, Dump_ast + | Dparsetree, Dparsetree -> + () | Reconcile a, Reconcile b when Poly.equal a b -> () | x, y -> let arg_of_output_mode = function @@ -1201,6 +1235,7 @@ let set_output_mode mode = | Reconcile Using_line_directives -> "-reconcile" | Reconcile Delimiting_generated_blocks -> "-reconcile-with-comments" | Null -> "-null" + | Dune_optional_output -> "-dune-optional-output" in raise (Arg.Bad @@ -1409,6 +1444,9 @@ let standalone_args = ( "-corrected-suffix", Arg.Set_string corrected_suffix, "SUFFIX Suffix to append to corrected files" ); + ( "-dune-optional-output", + Arg.Unit (fun () -> set_output_mode Dune_optional_output), + " For dune's internal use only" ); ] let get_args ?(standalone_args = standalone_args) () = diff --git a/test/driver/dune-optional-output/context_free_only_driver.ml b/test/driver/dune-optional-output/context_free_only_driver.ml new file mode 100644 index 000000000..2a1af72ac --- /dev/null +++ b/test/driver/dune-optional-output/context_free_only_driver.ml @@ -0,0 +1,12 @@ +open Ppxlib + +let rule = + Context_free.Rule.extension + (Extension.V3.declare "iam1" Extension.Context.expression + Ast_pattern.(pstr nil) + (fun ~ctxt -> + let loc = Expansion_context.Extension.extension_point_loc ctxt in + [%expr 1])) + +let () = Driver.register_transformation ~rules:[ rule ] "iam1" +let () = Driver.standalone () diff --git a/test/driver/dune-optional-output/driver_with_impl.ml b/test/driver/dune-optional-output/driver_with_impl.ml new file mode 100644 index 000000000..a88024635 --- /dev/null +++ b/test/driver/dune-optional-output/driver_with_impl.ml @@ -0,0 +1,16 @@ +open Ppxlib + +let rule = + Context_free.Rule.extension + (Extension.V3.declare "iam1" Extension.Context.expression + Ast_pattern.(pstr nil) + (fun ~ctxt -> + let loc = Expansion_context.Extension.extension_point_loc ctxt in + [%expr 1])) + +let () = Driver.register_transformation ~rules:[ rule ] "iam1" + +let () = + Driver.register_transformation ~impl:(fun str -> str) "IdentityInDisguise" + +let () = Driver.standalone () diff --git a/test/driver/dune-optional-output/dune b/test/driver/dune-optional-output/dune new file mode 100644 index 000000000..936762c80 --- /dev/null +++ b/test/driver/dune-optional-output/dune @@ -0,0 +1,16 @@ +(executable + (name context_free_only_driver) + (libraries ppxlib) + (preprocess + (pps ppxlib.metaquot)) + (modules context_free_only_driver)) + +(executable + (name driver_with_impl) + (libraries ppxlib) + (preprocess + (pps ppxlib.metaquot)) + (modules driver_with_impl)) + +(cram + (deps context_free_only_driver.exe driver_with_impl.exe)) diff --git a/test/driver/dune-optional-output/run.t b/test/driver/dune-optional-output/run.t new file mode 100644 index 000000000..3221fe171 --- /dev/null +++ b/test/driver/dune-optional-output/run.t @@ -0,0 +1,52 @@ +The -dune-optional-output flag is meant for dune to be able +to use ppx internally without having a build dependency on ppxlib +or any ppx. + +When enabled, it should not write to the output if it can absolutely +tell no transformation occured. + +We have a driver with a single context free rule to expand [%iam1] extension + +Let us consider the following file: + + $ cat > foo.ml << EOF + > let x = 1 + > let y = 2 + > EOF + +If we call the driver with the -dune-optional-output flag, it should not write a file: + + $ ./context_free_only_driver.exe -impl -dune-optional-output -o foo.pp.ml foo.ml + $ ls foo.* + foo.ml + +We can see that it did not write test.pp.ml + +Now if we actually use the extension: + + $ cat > bar.ml << EOF + > let x = [%iam1] + > let y = 2 + > EOF + +It should actually detect the transformation and therefore write the output file: + + $ ./context_free_only_driver.exe -impl -dune-optional-output -o bar.pp.ml bar.ml + $ ls bar.* + bar.ml + bar.pp.ml + +Now we have another driver that has the same context free rule but also another +transformation with an "impl", i.e. a rule to rewrite the whole AST unconditionnally. +This rule does not rewrite anything and is just the identity rewriter. +We cannot tell without actually comparing the ASTs if any rewriting happened so in +that case we always write to the output. + + $ cat > baz.ml << EOF + > let x = 1 + > let y = 2 + > EOF + $ ./driver_with_impl.exe -impl -dune-optional-output -o baz.pp.ml baz.ml + $ ls baz.* + baz.ml + baz.pp.ml diff --git a/test/driver/run_as_ppx_rewriter_preserve_version/dune b/test/driver/run_as_ppx_rewriter_preserve_version/dune index 9b74d4f75..31ee14bc5 100644 --- a/test/driver/run_as_ppx_rewriter_preserve_version/dune +++ b/test/driver/run_as_ppx_rewriter_preserve_version/dune @@ -1,11 +1,15 @@ (executable (name identity_standalone) (libraries ppxlib) + (preprocess + (pps ppxlib.metaquot)) (modules identity_standalone)) (executable (name print_magic_number) (libraries astlib) + (preprocess + (pps ppxlib.metaquot)) (modules print_magic_number)) (cram