diff --git a/CHANGES.md b/CHANGES.md index 76467b62..921508e8 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 604450db..2b9e0377 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 910902fe..4e7e7e88 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 a9152b2a..675d109a 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 b148d4d2..2be7a783 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 e4c701b9..d1fa61b0 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 b02cc14c..66ff303d 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 88157dcc..4a935911 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 00000000..23af1a56 --- /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 00000000..537d897f --- /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 00000000..f8ed6025 --- /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]