From cc26ff861110554e342ff7ef0e9ade8f9c415997 Mon Sep 17 00:00:00 2001 From: Nathan Rebours Date: Mon, 13 Jan 2025 17:07:00 +0100 Subject: [PATCH] Add --use-compiler-pp flag to standalone driver This flag allows user to force the driver to print AST as source code using the installed compiler printers rather than its own. This can be useful in situation where one is using the driver source output on older OCaml version to prevent outputting incompatible syntax. In addition it can prevent the driver to output uninterpreted extensions when migrating down newer compiler features before we bumped the internal AST. --- CHANGES.md | 5 +++ astlib/astlib.ml | 9 ++++ src/driver.ml | 22 +++++++--- src/dune | 3 +- src/reconcile.ml | 71 ++++++++++++++++++++++++++++--- src/reconcile.mli | 1 + src/utils.ml | 10 +++++ src/utils.mli | 4 ++ test/driver/compiler-pp/driver.ml | 34 +++++++++++++++ test/driver/compiler-pp/dune | 12 ++++++ test/driver/compiler-pp/run.t | 65 ++++++++++++++++++++++++++++ 11 files changed, 223 insertions(+), 13 deletions(-) create mode 100644 test/driver/compiler-pp/driver.ml create mode 100644 test/driver/compiler-pp/dune create mode 100644 test/driver/compiler-pp/run.t diff --git a/CHANGES.md b/CHANGES.md index 76467b62f..921508e85 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,11 @@ unreleased ---------- +- Add a `--use-compiler-pp` flag to the standalone driver. This flag + can be set when the driver outputs source code to make it use the compiler's + `Pprintast` instead of ppxlib's. + (#555, @NathanReb) + 0.34.0 (2025-01-06) ------------------- diff --git a/astlib/astlib.ml b/astlib/astlib.ml index 604450db3..2b9e03770 100644 --- a/astlib/astlib.ml +++ b/astlib/astlib.ml @@ -94,6 +94,15 @@ module Compiler_pprintast = struct let structure_item fmt t = structure fmt [t] let signature_item fmt t = signature fmt [t] + + exception Unavailable + + (*IF_NOT_AT_LEAST 414 let class_field _fmt _t = raise Unavailable *) + (*IF_NOT_AT_LEAST 414 let class_type_field _fmt _t = raise Unavailable *) + (*IF_NOT_AT_LEAST 414 let class_expr _fmt _t = raise Unavailable *) + (*IF_NOT_AT_LEAST 414 let class_type _fmt _t = raise Unavailable *) + (*IF_NOT_AT_LEAST 414 let module_type _fmt _t = raise Unavailable *) + (*IF_NOT_AT_LEAST 414 let module_expr _fmt _t = raise Unavailable *) end let init_error_reporting_style_using_env_vars () = diff --git a/src/driver.ml b/src/driver.ml index 910902fe5..4e7e7e883 100644 --- a/src/driver.ml +++ b/src/driver.ml @@ -1059,8 +1059,8 @@ let process_ast (ast : Intf_or_impl.t) ~input_name ~tool_name ~hook in Intf_or_impl.Impl ast -let process_file (kind : Kind.t) fn ~input_name ~relocate ~output_mode - ~embed_errors ~output = +let process_file (kind : Kind.t) fn ~input_name ~relocate ~use_compiler_pprint + ~output_mode ~embed_errors ~output = File_property.reset_all (); List.iter (List.rev !process_file_hooks) ~f:(fun f -> f ()); corrections := []; @@ -1129,7 +1129,7 @@ let process_file (kind : Kind.t) fn ~input_name ~relocate ~output_mode Reconcile.reconcile corrections ~contents:(Lazy.force input_contents) ~output:(Some corrected) ~input_filename:fn ~input_name - ~target:Corrected ?styler:!styler ~kind; + ~target:Corrected ?styler:!styler ~kind ~use_compiler_pprint; true in @@ -1138,9 +1138,11 @@ let process_file (kind : Kind.t) fn ~input_name ~relocate ~output_mode | 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); + (if use_compiler_pprint then Utils.print_as_compiler_source ppf ast + else + 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 @@ -1162,7 +1164,7 @@ let process_file (kind : Kind.t) fn ~input_name ~relocate ~output_mode Reconcile.reconcile !replacements ~contents:(Lazy.force input_contents) ~output ~input_filename:fn ~input_name ~target:(Output mode) - ?styler:!styler ~kind); + ?styler:!styler ~kind ~use_compiler_pprint); if mismatches_found && match !diff_command with Some "-" -> false | _ -> true @@ -1176,6 +1178,7 @@ let output = ref None let kind = ref None let input = ref None let embed_errors = ref false +let use_compiler_pprint = ref false let set_input fn = match !input with @@ -1418,6 +1421,10 @@ let standalone_args = ( "--keywords", Arg.String (fun s -> keywords := Some s), " Same as -keywords" ); + ( "--use-compiler-pp", + Arg.Set use_compiler_pprint, + "Force migrating the AST back to the compiler's version before printing \ + it as source code using the compiler's Pprintast utilities." ); ] let get_args ?(standalone_args = standalone_args) () = @@ -1457,6 +1464,7 @@ let standalone_main () = in process_file kind fn ~input_name ~relocate ~output_mode:!output_mode ~output:!output ~embed_errors:!embed_errors + ~use_compiler_pprint:!use_compiler_pprint let rewrite_binary_ast_file input_fn output_fn = let input_name, input_version, ast = load_input_run_as_ppx input_fn in diff --git a/src/dune b/src/dune index a9152b2a3..675d109a0 100644 --- a/src/dune +++ b/src/dune @@ -10,7 +10,8 @@ ppxlib_traverse_builtins stdppx stdlib-shims - sexplib0) + sexplib0 + compiler-libs.common) (flags (:standard -safe-string)) (ppx.driver diff --git a/src/reconcile.ml b/src/reconcile.ml index b148d4d21..2be7a7831 100644 --- a/src/reconcile.ml +++ b/src/reconcile.ml @@ -28,6 +28,64 @@ module Context = struct | Floating_attribute Signature_item -> Pprintast.signature_item | Floating_attribute Class_field -> Pprintast.class_field | Floating_attribute Class_type_field -> Pprintast.class_type_field + + let compiler_printer : type a. a t -> Stdlib.Format.formatter -> a -> unit = + fun ctx ppf a -> + let open Extension.Context in + let open Attribute.Floating.Context in + let module Ppxlib_to_compiler = Convert (Js) (Compiler_version) in + match ctx with + | Extension Class_expr -> + Astlib.Compiler_pprintast.class_expr ppf + (Ppxlib_to_compiler.copy_class_expr a) + | Extension Class_field -> + Astlib.Compiler_pprintast.class_field ppf + (Ppxlib_to_compiler.copy_class_field a) + | Extension Class_type -> + Astlib.Compiler_pprintast.class_type ppf + (Ppxlib_to_compiler.copy_class_type a) + | Extension Class_type_field -> + Astlib.Compiler_pprintast.class_type_field ppf + (Ppxlib_to_compiler.copy_class_type_field a) + | Extension Core_type -> + paren Astlib.Compiler_pprintast.core_type ppf + (Ppxlib_to_compiler.copy_core_type a) + | Extension Expression -> + paren Astlib.Compiler_pprintast.expression ppf + (Ppxlib_to_compiler.copy_expression a) + | Extension Module_expr -> + Astlib.Compiler_pprintast.module_expr ppf + (Ppxlib_to_compiler.copy_module_expr a) + | Extension Module_type -> + Astlib.Compiler_pprintast.module_type ppf + (Ppxlib_to_compiler.copy_module_type a) + | Extension Pattern -> + paren Astlib.Compiler_pprintast.pattern ppf + (Ppxlib_to_compiler.copy_pattern a) + | Extension Signature_item -> + Astlib.Compiler_pprintast.signature_item ppf + (Ppxlib_to_compiler.copy_signature_item a) + | Extension Structure_item -> + Astlib.Compiler_pprintast.structure_item ppf + (Ppxlib_to_compiler.copy_structure_item a) + | Extension Ppx_import -> + let stri_a = + { pstr_desc = Pstr_type (Recursive, [ a ]); pstr_loc = Location.none } + in + Astlib.Compiler_pprintast.structure_item ppf + (Ppxlib_to_compiler.copy_structure_item stri_a) + | Floating_attribute Structure_item -> + Astlib.Compiler_pprintast.structure_item ppf + (Ppxlib_to_compiler.copy_structure_item a) + | Floating_attribute Signature_item -> + Astlib.Compiler_pprintast.signature_item ppf + (Ppxlib_to_compiler.copy_signature_item a) + | Floating_attribute Class_field -> + Astlib.Compiler_pprintast.class_field ppf + (Ppxlib_to_compiler.copy_class_field a) + | Floating_attribute Class_type_field -> + Astlib.Compiler_pprintast.class_type_field ppf + (Ppxlib_to_compiler.copy_class_type_field a) end module Replacement = struct @@ -44,12 +102,15 @@ module Replacement = struct let make_text ~start ~stop ~repl () = { start; stop; data = Text repl } - let text block = + let text ~use_compiler_pprint block = match block.data with | Text s -> s | Values (context, generated) -> let s = - let printer = Context.printer context in + let printer = + if use_compiler_pprint then Context.compiler_printer context + else Context.printer context + in match generated with | Single x -> Stdlib.Format.asprintf "%a" printer x | Many l -> @@ -189,7 +250,7 @@ let with_output ~styler ~(kind : Kind.t) fn ~f = Stdlib.exit 1) let reconcile ?styler (repls : Replacements.t) ~kind ~contents ~input_filename - ~output ~input_name ~target = + ~output ~input_name ~target ~use_compiler_pprint = let repls = Replacements.check_and_sort ~input_filename ~input_name repls in let output_name = match output with None -> "" | Some fn -> fn in with_output output ~styler ~kind ~f:(fun oc -> @@ -230,7 +291,7 @@ let reconcile ?styler (repls : Replacements.t) ~kind ~contents ~input_filename copy_input pos ~up_to:repl.start.pos_cnum ~line ~last_is_text ~is_text in - let s = Replacement.text repl in + let s = Replacement.text ~use_compiler_pprint repl in let line = match target with | Output Using_line_directives -> @@ -255,7 +316,7 @@ let reconcile ?styler (repls : Replacements.t) ~kind ~contents ~input_filename if pos.pos_cnum < repl.start.pos_cnum then end_consecutive_repls line pos repls ~last_is_text else - let s = Replacement.text repl in + let s = Replacement.text ~use_compiler_pprint repl in output_string oc s; let line = line + count_newlines s in let last_is_text = diff --git a/src/reconcile.mli b/src/reconcile.mli index e4c701b90..d1fa61b0a 100644 --- a/src/reconcile.mli +++ b/src/reconcile.mli @@ -34,4 +34,5 @@ val reconcile : output:string option -> input_name:string -> target:target -> + use_compiler_pprint:bool -> unit diff --git a/src/utils.ml b/src/utils.ml index b02cc14c8..66ff303d4 100644 --- a/src/utils.ml +++ b/src/utils.ml @@ -248,3 +248,13 @@ module System = struct if Stdlib.Sys.command command = 0 then Ok () else Error (command, Ast_io.fall_back_input_version) end + +let print_as_compiler_source ppf ast = + let module Ppxlib_to_compiler = Convert (Js) (Compiler_version) in + match (ast : Intf_or_impl.t) with + | Intf sg -> + let sg = Ppxlib_to_compiler.copy_signature sg in + Astlib.Compiler_pprintast.signature ppf sg + | Impl st -> + let st = Ppxlib_to_compiler.copy_structure st in + Astlib.Compiler_pprintast.structure ppf st diff --git a/src/utils.mli b/src/utils.mli index 88157dcc3..4a9359118 100644 --- a/src/utils.mli +++ b/src/utils.mli @@ -60,3 +60,7 @@ module System : sig output:string -> (unit, string * Ast_io.input_version) result end + +val print_as_compiler_source : Stdlib.Format.formatter -> Intf_or_impl.t -> unit +(** Migrates the given AST to the compiler version and print it as source code + using Pprintast. *) diff --git a/test/driver/compiler-pp/driver.ml b/test/driver/compiler-pp/driver.ml new file mode 100644 index 000000000..23af1a565 --- /dev/null +++ b/test/driver/compiler-pp/driver.ml @@ -0,0 +1,34 @@ +open Ppxlib + +let existential ~loc = + let lident = { loc; txt = Longident.parse "Constructor" } in + let pattern = + { + ppat_loc = loc; + ppat_loc_stack = []; + ppat_attributes = []; + ppat_desc = + Ppat_construct (lident, Some ([ { loc; txt = "a" } ], [%pat? _])); + } + in + [%stri let f x = match x with [%p pattern] -> ()] + +let named_existential = + Context_free.Rule.extension + (Extension.V3.declare "named_existentials" Extension.Context.structure_item + Ast_pattern.(pstr nil) + (fun ~ctxt -> + let loc = Expansion_context.Extension.extension_point_loc ctxt in + existential ~loc)) + +let () = + Driver.V2.register_transformation ~rules:[ named_existential ] + "named_existentials" + +let str_type_decl = + Deriving.Generator.V2.make_noarg (fun ~ctxt _type_decl -> + let loc = Expansion_context.Deriver.derived_item_loc ctxt in + [ existential ~loc ]) + +let _ = Deriving.add ~str_type_decl "named_existentials" +let () = Driver.standalone () diff --git a/test/driver/compiler-pp/dune b/test/driver/compiler-pp/dune new file mode 100644 index 000000000..537d897fe --- /dev/null +++ b/test/driver/compiler-pp/dune @@ -0,0 +1,12 @@ +(executable + (name driver) + (enabled_if + (< %{ocaml_version} "4.13")) + (libraries ppxlib) + (preprocess + (pps ppxlib.metaquot))) + +(cram + (enabled_if + (< %{ocaml_version} "4.13")) + (deps driver.exe)) diff --git a/test/driver/compiler-pp/run.t b/test/driver/compiler-pp/run.t new file mode 100644 index 000000000..f8ed60250 --- /dev/null +++ b/test/driver/compiler-pp/run.t @@ -0,0 +1,65 @@ +The --use-compiler-pp flag can be used when using the driver's source code +output, either directly are when generating a .corrected file, to force +printing the AST as source using the installed compiler's printer. + +Our driver has a deriver and an extension that produces a pattern-matching with +named existentials. + +This feature has been introduced in 4.13 so the syntax is unsupported before that. + +If we run the driver in source output mode, without the `--use-compiler-pp` flag, +it will successfully print out the source using the 4.13 syntax. If we're running +on an older compiler, like we are for this test, that can be troublesome. + +If instead we use the flag, this will force the migration thus causing an error as +named existentials can't be migrated down to 4.12. + +Let's consider the following file: + + $ cat > test.ml << EOF + > [%%named_existentials] + > EOF + +Running the driver will generate a function with a single pattern matching in it: + + $ ./driver.exe test.ml + let f x = match x with | Constructor (type a) _ -> () + +Now if we run it with `--use-compiler-pp`, we should get the migration error: + + $ ./driver.exe --use-compiler-pp test.ml + File "test.ml", line 1, characters 0-22: + 1 | [%%named_existentials] + ^^^^^^^^^^^^^^^^^^^^^^ + Error: migration error: existentials in pattern-matching is not supported before OCaml 4.13 + [1] + +This should also work for correction based code gen: + + $ cat > test_inline.ml << EOF + > type t = int + > [@@deriving_inline named_existentials] + > [@@@end] + > EOF + +If we run the driver without `--use-compiler-pp`: + + $ ./driver.exe test_inline.ml -diff-cmd - + type t = int[@@deriving_inline named_existentials] + [@@@end ] + $ cat test_inline.ml.ppx-corrected + type t = int + [@@deriving_inline named_existentials] + let _ = fun (_ : t) -> () + let f x = match x with | Constructor (type a) _ -> () + let _ = f + [@@@end] + +and with the flag: + + $ ./driver.exe test_inline.ml -diff-cmd - --use-compiler-pp + File "test_inline.ml", lines 1-2, characters 0-38: + 1 | type t = int + 2 | [@@deriving_inline named_existentials] + Error: migration error: existentials in pattern-matching is not supported before OCaml 4.13 + [1]