From bdd21ead9c1dc56351c188cb51fba45ee59443fc Mon Sep 17 00:00:00 2001 From: Antonio Nuno Monteiro Date: Fri, 29 Mar 2024 14:59:51 -0700 Subject: [PATCH] feat(describe-pp): print reason files with `refmt` (#10322) * feat(describe-pp): use the dialect printer if available Signed-off-by: Antonio Nuno Monteiro * rename `dump_ast` to `print_ast` Signed-off-by: Antonio Nuno Monteiro --------- Signed-off-by: Antonio Nuno Monteiro --- bin/describe/describe_pp.ml | 87 ++++++++++--------- doc/changes/10322.md | 3 + src/dune_rules/dialect.ml | 49 ++++++++++- src/dune_rules/dialect.mli | 1 + .../describe/describe-pp/describe-pp.t/run.t | 6 +- test/blackbox-tests/utils/refmt.ml | 23 ++--- 6 files changed, 115 insertions(+), 54 deletions(-) create mode 100644 doc/changes/10322.md diff --git a/bin/describe/describe_pp.ml b/bin/describe/describe_pp.ml index 7a465277385..43a3a860d08 100644 --- a/bin/describe/describe_pp.ml +++ b/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.print_ast dialect ml_kind with + | Some print_ast -> print_ast + | None -> + (* fall back to the OCaml print_ast function, known to exist, if one + doesn't exist for this dialect. *) + Dune_rules.Dialect.print_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 = diff --git a/doc/changes/10322.md b/doc/changes/10322.md new file mode 100644 index 00000000000..5d96a75e8eb --- /dev/null +++ b/doc/changes/10322.md @@ -0,0 +1,3 @@ +- Print the result of `dune describe pp` with the respective dialect printer. + (#10322, @anmonteiro) + diff --git a/src/dune_rules/dialect.ml b/src/dune_rules/dialect.ml index e0f398b540d..92c94306faa 100644 --- a/src/dune_rules/dialect.ml +++ b/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 + ; print_ast : (Loc.t * Action.t) option } - let encode { kind; extension; preprocess; format } = + let encode { kind; extension; preprocess; format; print_ast } = let open Dune_lang.Encoder in let kind = string @@ -28,16 +29,21 @@ 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 + "print_ast" + Action.encode + (Option.map ~f:(fun (_, x) -> x) print_ast) ]) ;; - let to_dyn { kind; extension; preprocess; format } = + let to_dyn { kind; extension; preprocess; format; print_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 + ; "print_ast", option (fun (_, x) -> Action.to_dyn x) print_ast ] ;; end @@ -78,13 +84,14 @@ let decode = field_o "format" (map ~f:(fun (loc, x) -> loc, x, []) (located Action.decode_dune_file)) + and+ print_ast = field_o "print_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; print_ast } in fields (let+ name = field "name" string @@ -130,6 +137,12 @@ let format { file_kinds; _ } ml_kind = x.format ;; +let print_ast { file_kinds; _ } ml_kind = + let open Option.O in + let* x = Ml_kind.Dict.get file_kinds ml_kind in + x.print_ast +;; + let ocaml = let format kind = let flag_of_kind = function @@ -145,6 +158,18 @@ let ocaml = ; S.make_pform Loc.none (Var Input_file) ]) in + let print_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 +179,7 @@ let ocaml = ( Loc.none , format kind , [ ".ocamlformat"; ".ocamlformat-ignore"; ".ocamlformat-enable" ] ) + ; print_ast = Some (Loc.none, print_ast kind) } in let intf = Some (file_kind Ml_kind.Intf ".mli") in @@ -175,10 +201,26 @@ let reason = let format = Action.run (S.make_text Loc.none "refmt") [ S.make_pform Loc.none (Var Input_file) ] in + let print_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, []) + ; print_ast = Some (Loc.none, print_ast) } in let intf = Some (file_kind Ml_kind.Intf ".rei") in @@ -207,6 +249,7 @@ let rescript = ; extension ; preprocess = Some (Loc.none, preprocess) ; format = Some (Loc.none, format, []) + ; print_ast = None } in let intf = Some (file_kind Ml_kind.Intf ".resi") in diff --git a/src/dune_rules/dialect.mli b/src/dune_rules/dialect.mli index d8b8469ef6e..b8d79de83b8 100644 --- a/src/dune_rules/dialect.mli +++ b/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 print_ast : t -> Ml_kind.t -> (Loc.t * Dune_lang.Action.t) option val ocaml : t val reason : t val rescript : t diff --git a/test/blackbox-tests/test-cases/describe/describe-pp/describe-pp.t/run.t b/test/blackbox-tests/test-cases/describe/describe-pp/describe-pp.t/run.t index 7c45bd6f017..b9e1e81e019 100644 --- a/test/blackbox-tests/test-cases/describe/describe-pp/describe-pp.t/run.t +++ b/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!") diff --git a/test/blackbox-tests/utils/refmt.ml b/test/blackbox-tests/utils/refmt.ml index 38bc5f433d0..2a4ceea843f 100644 --- a/test/blackbox-tests/utils/refmt.ml +++ b/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 ;;