Skip to content

Commit

Permalink
Add -dune-optional-output mode for dune's internal use
Browse files Browse the repository at this point in the history
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 <nathan.p.rebours@gmail.com>
  • Loading branch information
NathanReb committed Mar 20, 2024
1 parent 455f217 commit 0695d62
Show file tree
Hide file tree
Showing 7 changed files with 166 additions and 26 deletions.
2 changes: 2 additions & 0 deletions CHANGES.md
Original file line number Diff line number Diff line change
@@ -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)

Expand Down
90 changes: 64 additions & 26 deletions src/driver.ml
Original file line number Diff line number Diff line change
Expand Up @@ -304,11 +304,13 @@ module Transform = struct
in
{ t with impl = Some map_impl; intf = Some map_intf }

let builtin_context_free_name = "<builtin:context-free>"

let builtin_of_context_free_rewriters ~hook ~rules ~enclose_impl ~enclose_intf
~input_name =
merge_into_generic_mappers ~hook ~input_name
{
name = "<builtin:context-free>";
name = builtin_context_free_name;
aliases = [];
impl = None;
intf = None;
Expand All @@ -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 ->
Expand Down Expand Up @@ -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) ->
Expand Down Expand Up @@ -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 ();
Expand Down Expand Up @@ -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)

Expand All @@ -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 ();
Expand Down Expand Up @@ -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)

Expand All @@ -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

Expand Down Expand Up @@ -917,6 +944,7 @@ type output_mode =
| Dparsetree
| Reconcile of Reconcile.mode
| Null
| Dune_optional_output

(*$*)
let extract_cookies_str st =
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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 =
Expand All @@ -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 ->
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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) () =
Expand Down
12 changes: 12 additions & 0 deletions test/driver/dune-optional-output/context_free_only_driver.ml
Original file line number Diff line number Diff line change
@@ -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 ()
16 changes: 16 additions & 0 deletions test/driver/dune-optional-output/driver_with_impl.ml
Original file line number Diff line number Diff line change
@@ -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 ()
16 changes: 16 additions & 0 deletions test/driver/dune-optional-output/dune
Original file line number Diff line number Diff line change
@@ -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))
52 changes: 52 additions & 0 deletions test/driver/dune-optional-output/run.t
Original file line number Diff line number Diff line change
@@ -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
4 changes: 4 additions & 0 deletions test/driver/run_as_ppx_rewriter_preserve_version/dune
Original file line number Diff line number Diff line change
@@ -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
Expand Down

0 comments on commit 0695d62

Please sign in to comment.