feat(describe-pp): use the dialect printer if available

Signed-off-by: Antonio Nuno Monteiro <[email protected]>

bin/describe/describe_pp.ml

@@ -1,22 +1,48 @@
 open Import
 
-let pp_with_ocamlc env ~ocamlc pp_file dump_file =
-  let open Dune_engine in
-  let open Fiber.O in
-  let+ () =
-    Process.run
-      ~display:!Clflags.display
-      ~env
-      Strict
-      ocamlc
-      [ "-stop-after"; "parsing"; "-dsource"; Path.to_string pp_file; "-dump-into-file" ]
+let print_pped_file sctx file pp_file =
+  let open Memo.O in
+  let* loc, action =
+    let+ dialect, ml_kind =
+      let _base, ext =
+        let file = Path.of_string file in
+        Path.split_extension file
+      in
+      let+ project = Source_tree.root () >>| Source_tree.Dir.project in
+      let dialects = Dune_project.dialects project in
+      match Dune_rules.Dialect.DB.find_by_extension dialects ext with
+      | None -> User_error.raise [ Pp.textf "unsupported extension: %s" ext ]
+      | Some x -> x
+    in
+    match Dune_rules.Dialect.dump_ast dialect ml_kind with
+    | Some dump_ast -> dump_ast
+    | None ->
+      (* fallback to the OCaml dump_ast function, known to exist, if one
+         doesn't exist for this dialect. *)
+      Dune_rules.Dialect.dump_ast Dune_rules.Dialect.ocaml ml_kind |> Option.value_exn
+  in
+  let dir = pp_file |> Path.parent_exn |> Path.as_in_build_dir_exn in
+  let* action, observing_facts =
+    let* build =
+      let+ expander =
+        let bindings =
+          Dune_lang.Pform.Map.singleton
+            (Var Input_file)
+            [ Dune_lang.Value.Path (Path.build (pp_file |> Path.as_in_build_dir_exn)) ]
+        in
+        Super_context.expander sctx ~dir >>| Dune_rules.Expander.add_bindings ~bindings
+      in
+      Dune_rules.For_tests.Action_unexpanded.expand_no_targets
+        action
+        ~chdir:(Dune_rules.Expander.context expander |> Context_name.build_dir)
+        ~loc
+        ~expander
+        ~deps:[]
+        ~what:"describe pp"
+    in
+    Action_builder.evaluate_and_collect_facts build
   in
-  match Path.stat dump_file with
-  | Ok { st_kind = S_REG; _ } ->
-    Io.cat dump_file;
-    Path.unlink_no_err dump_file
-  | _ ->
-    User_error.raise [ Pp.textf "cannot find a dump file: %s" (Path.to_string dump_file) ]
+  Build_system.execute_action ~observing_facts { action; loc; dir; alias = None }
 ;;
 
 let files_for_source file dialects =
@@ -27,20 +53,9 @@ let files_for_source file dialects =
     | Some x -> x
   in
   let pp_file_base = Path.extend_basename base ~suffix:ext in
-  let pp_file =
-    match Dune_rules.Dialect.ml_suffix dialect kind with
-    | None -> pp_file_base
-    | Some suffix -> Path.extend_basename pp_file_base ~suffix
-  in
-  let dump_file =
-    Path.set_extension
-      pp_file
-      ~ext:
-        (match kind with
-         | Intf -> ".cmi.dump"
-         | Impl -> ".cmo.dump")
-  in
-  pp_file, dump_file
+  match Dune_rules.Dialect.ml_suffix dialect kind with
+  | None -> pp_file_base
+  | Some suffix -> Path.extend_basename pp_file_base ~suffix
 ;;
 
 let get_pped_file super_context file =
@@ -60,9 +75,9 @@ let get_pped_file super_context file =
   | true ->
     let* project = Source_tree.root () >>| Source_tree.Dir.project in
     let dialects = Dune_project.dialects project in
-    let pp_file, dump_file = files_for_source pp_file dialects in
+    let pp_file = files_for_source pp_file dialects in
     let+ () = Build_system.build_file pp_file in
-    Ok (pp_file, dump_file)
+    Ok pp_file
   | false ->
     Build_system.file_exists file_in_build_dir
     >>= (function
@@ -116,13 +131,7 @@ let term =
   let* result = get_pped_file super_context file in
   match result with
   | Error file -> Io.cat file |> Memo.return
-  | Ok (pp_file, dump_file) ->
-    let* ocamlc =
-      let+ ocaml = Context.ocaml (Super_context.context super_context) in
-      ocaml.ocamlc
-    in
-    let* env = Super_context.context_env super_context in
-    pp_with_ocamlc env ~ocamlc pp_file dump_file |> Memo.of_non_reproducible_fiber
+  | Ok pp_file -> print_pped_file super_context file pp_file
 ;;
 
 let command =

doc/changes/10322.md

@@ -0,0 +1,3 @@
+- Print the result of `dune describe pp` with the respective dialect printer.
+  (#10322, @anmonteiro)
+

src/dune_rules/dialect.ml

@@ -10,9 +10,10 @@ module File_kind = struct
     ; extension : string
     ; preprocess : (Loc.t * Action.t) option
     ; format : (Loc.t * Action.t * string list) option
+    ; dump_ast : (Loc.t * Action.t) option
     }
 
-  let encode { kind; extension; preprocess; format } =
+  let encode { kind; extension; preprocess; format; dump_ast } =
     let open Dune_lang.Encoder in
     let kind =
       string
@@ -28,16 +29,18 @@ module File_kind = struct
             [ field "extension" string extension
             ; field_o "preprocess" Action.encode (Option.map ~f:snd preprocess)
             ; field_o "format" Action.encode (Option.map ~f:(fun (_, x, _) -> x) format)
+            ; field_o "dump_ast" Action.encode (Option.map ~f:(fun (_, x) -> x) dump_ast)
             ])
   ;;
 
-  let to_dyn { kind; extension; preprocess; format } =
+  let to_dyn { kind; extension; preprocess; format; dump_ast } =
     let open Dyn in
     record
       [ "kind", Ml_kind.to_dyn kind
       ; "extension", string extension
       ; "preprocess", option (fun (_, x) -> Action.to_dyn x) preprocess
       ; "format", option (fun (_, x, y) -> pair Action.to_dyn (list string) (x, y)) format
+      ; "dump_ast", option (fun (_, x) -> Action.to_dyn x) dump_ast
       ]
   ;;
 end
@@ -78,13 +81,14 @@ let decode =
       field_o
         "format"
         (map ~f:(fun (loc, x) -> loc, x, []) (located Action.decode_dune_file))
+    and+ dump_ast = field_o "dump_ast" (located Action.decode_dune_file)
     and+ syntax_ver = Syntax.get_exn Stanza.syntax in
     let ver = 3, 9 in
     if syntax_ver < ver && Option.is_some (String.index_from extension 1 '.')
     then (
       let what = "the possibility of defining extensions containing periods" in
       Syntax.Error.since loc Stanza.syntax ver ~what);
-    { File_kind.kind; extension; preprocess; format }
+    { File_kind.kind; extension; preprocess; format; dump_ast }
   in
   fields
     (let+ name = field "name" string
@@ -130,6 +134,12 @@ let format { file_kinds; _ } ml_kind =
   x.format
 ;;
 
+let dump_ast { file_kinds; _ } ml_kind =
+  let open Option.O in
+  let* x = Ml_kind.Dict.get file_kinds ml_kind in
+  x.dump_ast
+;;
+
 let ocaml =
   let format kind =
     let flag_of_kind = function
@@ -145,6 +155,18 @@ let ocaml =
          ; S.make_pform Loc.none (Var Input_file)
          ])
   in
+  let dump_ast _kind =
+    let module S = String_with_vars in
+    Action.chdir
+      (S.make_pform Loc.none (Var Workspace_root))
+      (Action.run
+         (S.make_text Loc.none "ocamlc")
+         [ S.make_text Loc.none "-stop-after"
+         ; S.make_text Loc.none "parsing"
+         ; S.make_text Loc.none "-dsource"
+         ; S.make_pform Loc.none (Var Input_file)
+         ])
+  in
   let file_kind kind extension =
     { File_kind.kind
     ; extension
@@ -154,6 +176,7 @@ let ocaml =
           ( Loc.none
           , format kind
           , [ ".ocamlformat"; ".ocamlformat-ignore"; ".ocamlformat-enable" ] )
+    ; dump_ast = Some (Loc.none, dump_ast kind)
     }
   in
   let intf = Some (file_kind Ml_kind.Intf ".mli") in
@@ -175,10 +198,26 @@ let reason =
     let format =
       Action.run (S.make_text Loc.none "refmt") [ S.make_pform Loc.none (Var Input_file) ]
     in
+    let dump_ast =
+      let flag_of_kind = function
+        | Ml_kind.Impl -> "-i=false"
+        | Intf -> "-i=true"
+      in
+      let module S = String_with_vars in
+      Action.chdir
+        (S.make_pform Loc.none (Var Workspace_root))
+        (Action.run
+           (S.make_text Loc.none "refmt")
+           [ S.make_text Loc.none "--parse=binary"
+           ; S.make_text Loc.none (flag_of_kind kind)
+           ; S.make_pform Loc.none (Var Input_file)
+           ])
+    in
     { File_kind.kind
     ; extension
     ; preprocess = Some (Loc.none, preprocess)
     ; format = Some (Loc.none, format, [])
+    ; dump_ast = Some (Loc.none, dump_ast)
     }
   in
   let intf = Some (file_kind Ml_kind.Intf ".rei") in
@@ -207,6 +246,7 @@ let rescript =
     ; extension
     ; preprocess = Some (Loc.none, preprocess)
     ; format = Some (Loc.none, format, [])
+    ; dump_ast = None
     }
   in
   let intf = Some (file_kind Ml_kind.Intf ".resi") in

src/dune_rules/dialect.mli

@@ -28,6 +28,7 @@ val decode : t Dune_lang.Decoder.t
 val extension : t -> Ml_kind.t -> string option
 val preprocess : t -> Ml_kind.t -> (Loc.t * Dune_lang.Action.t) option
 val format : t -> Ml_kind.t -> (Loc.t * Dune_lang.Action.t * string list) option
+val dump_ast : t -> Ml_kind.t -> (Loc.t * Dune_lang.Action.t) option
 val ocaml : t
 val reason : t
 val rescript : t

test/blackbox-tests/test-cases/describe/describe-pp/describe-pp.t/run.t

@@ -11,9 +11,11 @@ We can also show the original source if it is not preprocessed
 We also make sure that the dump file is not present
 
   $ dune_cmd exists profile.dump
-  true
+  false
 
 This also works for reason code
 
   $ dune describe pp src/main_re.re
-  ;;Util.log "Hello, world!"
+  # 1 "src/main_re.pp.re.ml"
+  # 1 "src/main_re.pp.re"
+  Util.log ("Hello, world!")

test/blackbox-tests/utils/refmt.ml

@@ -5,13 +5,7 @@ type ('impl, 'intf) intf_or_impl =
   | Intf of 'intf
 
 module File = struct
-  let of_filename s =
-    if Filename.check_suffix s ".re"
-    then Impl s
-    else if Filename.check_suffix s ".rei"
-    then Intf s
-    else failwith (sprintf "unknown filename %S" s)
-  ;;
+  let of_filename s = if Filename.check_suffix s ".rei" then Intf s else Impl s
 
   let output_fn = function
     | Impl fn -> fn ^ ".ml"
@@ -22,9 +16,14 @@ end
 let () =
   let set_binary = function
     | "binary" -> ()
-    | _ -> failwith "Only the value 'binary' is allowed for --print"
+    | _ -> failwith "Only the value 'binary' is allowed for --parse / --print"
+  in
+  let args =
+    [ "--print", Arg.String set_binary, ""
+    ; "--parse", Arg.String set_binary, ""
+    ; "-i=false", Arg.Unit ignore, ""
+    ]
   in
-  let args = [ "--print", Arg.String set_binary, "" ] in
   let source = ref None in
   let anon s =
     match !source with
@@ -50,5 +49,9 @@ let () =
       loop ()
   in
   loop ();
-  close_out_noerr out
+  close_out_noerr out;
+  let inch = open_in_bin out_fn in
+  let contents = really_input_string inch (in_channel_length inch) in
+  close_in inch;
+  Printf.printf "%s" contents
 ;;