Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Add -dune-optional-output mode for dune's internal use #482

Open
wants to merge 1 commit into
base: main
Choose a base branch
from
Open

Add -dune-optional-output mode for dune's internal use #482

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 2 additions & 0 deletions CHANGES.md
View file
Open in desktop
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
89 changes: 63 additions & 26 deletions src/driver.ml
View file
Open in desktop
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
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm not quite sure I follow why checking this name is enough for deciding that this rewrite is not context free? Is it okay because we assume that people will not use that name externally (probably a fine assumption)? For example, if you change the driver_with_impl.ml to be called

let () =
  Driver.register_transformation ~impl:(fun str -> str) "<builtin:context-free>"

The pp file is no longer generated. Sorry this might just be that I am too new to the codebase!

Copy link
Collaborator Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

ppxlib's driver will assemble several AST traversal passes. One of them is meant to apply all context-free rules, it is built by ppxlib itself and is named "builtin:context-free".

All other passes come from ppx-es registering str -> str or sig -> sig rewriting functions.

Indeed there are no guarantees a user won't use that name when registering a ppx of their own but it is very unlikely.

I think this all part of the code could be refactored and simplified significantly and that might help distinguish between this special pass and all others.

In the meantime we could try to forbid this name for outside users. The transformation name is only used for error reporting as far as I remember so it usually is the name of the ppx itself, it's unlikely that we would break anything by adding such a restriction.

I think it should be alright but if you feel this is too much of a risk, I'm happy to look into refactoring this part in a way that allows us not to check by name.

| {
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,20 @@ 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 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 +659,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 +719,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 +729,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 +795,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 +805,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 +943,7 @@ type output_mode =
| Dparsetree
| Reconcile of Reconcile.mode
| Null
| Dune_optional_output

(*$*)
let extract_cookies_str st =
Expand Down Expand Up @@ -1036,14 +1063,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 +1079,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 +1112,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 +1135,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 +1172,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 +1221,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 +1234,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 +1443,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
View file
Open in desktop
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
View file
Open in desktop
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
View file
Open in desktop
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
View file
Open in desktop
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 foo.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 unconditionally.
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
View file
Open in desktop
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
Loading