unikernel/duniverse/dune_/bin/describe/describe_pp.ml

@@ -0,0 +1,183 @@
+open Import
+module Dialect = Dune_lang.Dialect
+
+let dialect_and_ml_kind file =
+  let open Memo.O in
+  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 Dialect.DB.find_by_extension dialects ext with
+  | None -> User_error.raise [ Pp.textf "unsupported extension: %s" ext ]
+  | Some x -> x
+;;
+
+let execute_pp_action ~sctx file pp_file dump_file =
+  let open Memo.O in
+  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
+    let dir = pp_file |> Path.parent_exn |> Path.as_in_build_dir_exn in
+    Super_context.expander sctx ~dir >>| Dune_rules.Expander.add_bindings ~bindings
+  in
+  let context = Dune_rules.Expander.context expander in
+  let build_dir = Context_name.build_dir context in
+  let* input =
+    let* action, _observing_facts =
+      let* loc, action =
+        let+ dialect, ml_kind = dialect_and_ml_kind file in
+        match 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. *)
+          Dialect.print_ast Dialect.ocaml ml_kind |> Option.value_exn
+      in
+      let build =
+        let open Action_builder.O in
+        let+ build =
+          Dune_rules.For_tests.Action_unexpanded.expand_no_targets
+            action
+            ~chdir:build_dir
+            ~loc
+            ~expander
+            ~deps:[]
+            ~what:"describe pp"
+        in
+        Action.with_outputs_to dump_file build.action
+      in
+      Action_builder.evaluate_and_collect_facts build
+    in
+    let+ env = Dune_rules.Super_context.context_env sctx
+    and+ execution_parameters = Dune_engine.Execution_parameters.default in
+    let targets =
+      let unvalidated = Targets.File.create dump_file in
+      match Targets.validate unvalidated with
+      | Valid targets -> targets
+      | No_targets
+      | Inconsistent_parent_dir
+      | File_and_directory_target_with_the_same_name _ -> assert false
+    in
+    { Dune_engine.Action_exec.targets = Some targets
+    ; root = Path.build build_dir
+    ; context = Some (Dune_engine.Build_context.create ~name:context)
+    ; env
+    ; rule_loc = Loc.none
+    ; execution_parameters
+    ; action
+    }
+  in
+  let ok =
+    let open Fiber.O in
+    let build_deps deps = Build_system.build_deps deps |> Memo.run in
+    let* result = Dune_engine.Action_exec.exec input ~build_deps in
+    Dune_engine.Action_exec.Exec_result.ok_exn result >>| ignore
+  in
+  Memo.of_non_reproducible_fiber ok
+;;
+
+let print_pped_file =
+  let dump_file pp_file ~ml_kind =
+    Path.set_extension
+      pp_file
+      ~ext:
+        (match (ml_kind : Ocaml.Ml_kind.t) with
+         | Intf -> ".cmi.dump"
+         | Impl -> ".cmo.dump")
+    |> Path.as_in_build_dir_exn
+  in
+  fun ~sctx file pp_file ~ml_kind ->
+    let open Memo.O in
+    let dump_file = dump_file pp_file ~ml_kind in
+    let+ () = execute_pp_action ~sctx file pp_file dump_file in
+    let dump_file = Path.build dump_file 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) ]
+;;
+
+let find_module ~sctx file =
+  let open Memo.O in
+  let src = Path.drop_optional_build_context_src_exn (Path.build file) in
+  Dune_rules.Top_module.find_module sctx src
+  >>| function
+  | None -> None
+  | Some (m, _, _, origin) ->
+    (match
+       Dune_rules.Ml_sources.Origin.preprocess origin
+       |> Dune_lang.Preprocess.Per_module.find (Dune_rules.Module.name m)
+     with
+     | Pps { staged = true; loc; _ } -> Some (`Staged_pps loc)
+     | _ -> Some (`Module m))
+;;
+
+let get_pped_file super_context file =
+  let open Memo.O in
+  let context = Super_context.context super_context in
+  let in_build_dir file =
+    file |> Path.to_string |> Path.Build.relative (Context.build_dir context)
+  in
+  let file_in_build_dir =
+    if String.is_empty file
+    then User_error.raise [ Pp.textf "No file given." ]
+    else Path.of_string file |> in_build_dir
+  in
+  let* ml_kind =
+    let+ _, ml_kind = dialect_and_ml_kind file in
+    ml_kind
+  in
+  let file_not_found () =
+    User_error.raise
+      [ Pp.textf "%s does not exist" (Path.Build.to_string_maybe_quoted file_in_build_dir)
+      ]
+  in
+  find_module ~sctx:super_context file_in_build_dir
+  >>= function
+  | None -> file_not_found ()
+  | Some (`Module m) ->
+    (match
+       Dune_rules.Module.source m ~ml_kind |> Option.map ~f:Dune_rules.Module.File.path
+     with
+     | None -> file_not_found ()
+     | Some pp_file ->
+       let+ () = Build_system.build_file pp_file in
+       Ok (pp_file, ml_kind))
+  | Some (`Staged_pps loc) ->
+    User_error.raise ~loc [ Pp.text "staged_pps are not supported." ]
+;;
+
+let term =
+  let+ builder = Common.Builder.term
+  and+ context_name = Common.context_arg ~doc:"Build context to use."
+  and+ _ = Describe_lang_compat.arg
+  and+ file = Arg.(required & pos 0 (some string) None (Arg.info [] ~docv:"FILE")) in
+  let common, config = Common.init builder in
+  Scheduler.go_with_rpc_server ~common ~config
+  @@ fun () ->
+  let open Fiber.O in
+  let* setup = Import.Main.setup () in
+  let* setup = Memo.run setup in
+  let sctx = Import.Main.find_scontext_exn setup ~name:context_name in
+  build_exn
+  @@ fun () ->
+  let open Memo.O in
+  let* result = get_pped_file sctx file in
+  match result with
+  | Error file -> Io.cat file |> Memo.return
+  | Ok (pp_file, ml_kind) -> print_pped_file ~sctx file pp_file ~ml_kind
+;;
+
+let command =
+  let doc = "Build a given FILE and print the preprocessed output." in
+  let info = Cmd.info ~doc "pp" in
+  Cmd.v info term
+;;