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

@@ -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)
 -------------------
 

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 () =

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),
       "<version+list> 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

src/dune

@@ -10,7 +10,8 @@
   ppxlib_traverse_builtins
   stdppx
   stdlib-shims
-  sexplib0)
+  sexplib0
+  compiler-libs.common)
  (flags
   (:standard -safe-string))
  (ppx.driver

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 -> "<stdout>" | 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 =

src/reconcile.mli

@@ -34,4 +34,5 @@ val reconcile :
   output:string option ->
   input_name:string ->
   target:target ->
+  use_compiler_pprint:bool ->
   unit

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

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. *)

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 ()

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))

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]