Use Exe to generate ppx executable

Signed-off-by: Rudi Grinberg <me@rgrinberg.com>

src/dune_rules/compilation_context.ml

@@ -60,7 +60,7 @@ type t =
   ; requires_compile : Lib.t list Or_exn.t
   ; requires_link : Lib.t list Or_exn.t Lazy.t
   ; includes : Includes.t
-  ; preprocessing : Preprocessing.t
+  ; preprocessing : Pp_spec.t
   ; opaque : bool
   ; stdlib : Ocaml_stdlib.t option
   ; js_of_ocaml : Dune_file.Js_of_ocaml.t option
@@ -115,9 +115,9 @@ let bin_annot t = t.bin_annot
 let context t = Super_context.context t.super_context
 
 let create ~super_context ~scope ~expander ~obj_dir ~modules ~flags
-    ~requires_compile ~requires_link ?(preprocessing = Preprocessing.dummy)
-    ~opaque ?stdlib ~js_of_ocaml ~dynlink ~package ?vimpl ?modes
-    ?(bin_annot = true) () =
+    ~requires_compile ~requires_link ?(preprocessing = Pp_spec.dummy) ~opaque
+    ?stdlib ~js_of_ocaml ~dynlink ~package ?vimpl ?modes ?(bin_annot = true) ()
+    =
   let requires_compile =
     if Dune_project.implicit_transitive_deps (Scope.project scope) then
       Lazy.force requires_link

src/dune_rules/compilation_context.mli

@@ -31,7 +31,7 @@ val create :
   -> flags:Ocaml_flags.t
   -> requires_compile:Lib.t list Or_exn.t
   -> requires_link:Lib.t list Or_exn.t Lazy.t
-  -> ?preprocessing:Preprocessing.t
+  -> ?preprocessing:Pp_spec.t
   -> opaque:opaque
   -> ?stdlib:Ocaml_stdlib.t
   -> js_of_ocaml:Dune_file.Js_of_ocaml.t option
@@ -70,7 +70,7 @@ val requires_compile : t -> Lib.t list Or_exn.t
 
 val includes : t -> Command.Args.dynamic Command.Args.t Cm_kind.Dict.t
 
-val preprocessing : t -> Preprocessing.t
+val preprocessing : t -> Pp_spec.t
 
 val opaque : t -> bool
 

src/dune_rules/obj_dir.ml

@@ -266,6 +266,11 @@ let as_local_exn (t : Path.t t) =
 
 let make_exe ~dir ~name = Local (Local.make_exe ~dir ~name)
 
+let for_pp ~dir =
+  Local
+    (Local.make ~dir ~obj_dir:dir ~native_dir:dir ~byte_dir:dir
+       ~public_cmi_dir:None)
+
 let to_local (t : Path.t t) =
   match t with
   | Local _ -> assert false

src/dune_rules/obj_dir.mli

@@ -78,6 +78,8 @@ val to_dyn : _ t -> Dyn.t
 
 val make_exe : dir:Path.Build.t -> name:string -> Path.Build.t t
 
+val for_pp : dir:Path.Build.t -> Path.Build.t t
+
 val as_local_exn : Path.t t -> Path.Build.t t
 
 (** For local libraries with private modules, all public cmi's are symlinked to

src/dune_rules/pp_spec.ml

@@ -0,0 +1,3 @@
+type t = (Module.t -> lint:bool -> Module.t) Module_name.Per_item.t
+
+let dummy : t = Module_name.Per_item.for_all (fun m ~lint:_ -> m)

src/dune_rules/preprocessing.ml

@@ -2,7 +2,6 @@ open! Dune_engine
 open! Stdune
 open Import
 open Build.O
-open Dune_file
 module SC = Super_context
 
 (* Encoded representation of a set of library names + scope *)
@@ -295,15 +294,8 @@ let ppx_exe sctx ~key =
   let build_dir = (Super_context.context sctx).build_dir in
   Path.Build.relative build_dir (".ppx/" ^ key ^ "/ppx.exe")
 
-let build_ppx_driver sctx ~dep_kind ~target ~pps ~pp_names =
+let build_ppx_driver sctx ~scope ~target ~pps ~pp_names =
   let ctx = SC.context sctx in
-  let mode = Context.best_mode ctx in
-  let link_mode : Link_mode.t =
-    match mode with
-    | Byte -> Byte_with_stubs_statically_linked_in
-    | Native -> Native
-  in
-  let compiler = Context.compiler ctx mode in
   let jbuild_driver, pps, pp_names = (None, pps, pp_names) in
   let driver_and_libs =
     let open Result.O in
@@ -322,72 +314,67 @@ let build_ppx_driver sctx ~dep_kind ~target ~pps ~pp_names =
   (* CR-someday diml: what we should do is build the .cmx/.cmo once and for all
      at the point where the driver is defined. *)
   let dir = Path.Build.parent_exn target in
-  let ml = Path.Build.relative dir "_ppx.ml" in
+  let main_module_name =
+    Module_name.of_string_allow_invalid (Loc.none, "_ppx")
+  in
+  let module_ = Module.generated ~src_dir:(Path.build dir) main_module_name in
+  let ml_source =
+    Module.file ~ml_kind:Impl module_
+    |> Option.value_exn |> Path.as_in_build_dir_exn
+  in
   let add_rule ~sandbox = SC.add_rule ~sandbox sctx ~dir in
-  let open Build.With_targets.O in
   add_rule ~sandbox:Sandbox_config.default
     ( Build.of_result_map driver_and_libs ~f:(fun (driver, _) ->
           Build.return (sprintf "let () = %s ()\n" driver.info.main))
-    |> Build.write_file_dyn ml );
-  add_rule ~sandbox:Sandbox_config.no_special_requirements
-    ( Build.with_no_targets
-        (Build.label
-           (Lib_deps_info.Label
-              (Lib_deps.info ~kind:dep_kind (Lib_deps.of_pps pp_names))))
-    >>> Command.run compiler ~dir:(Path.build ctx.build_dir)
-          [ A "-g"
-          ; A "-o"
-          ; Target target
-          ; A "-w"
-          ; A "-24"
-          ; As
-              ( match link_mode with
-              | Byte_with_stubs_statically_linked_in ->
-                [ Ocaml_version.custom_or_output_complete_exe ctx.version ]
-              | Byte
-              | Native ->
-                [] )
-          ; Command.of_result
-              (Result.map driver_and_libs ~f:(fun (_driver, libs) ->
-                   Command.Args.S
-                     [ Lib.L.compile_and_link_flags ~mode:link_mode
-                         ~compile:libs ~link:libs
-                     ; Hidden_deps
-                         (Lib_file_deps.deps libs ~groups:[ Cmi; Cmx ])
-                     ]))
-          ; Dep (Path.build ml)
-          ] )
+    |> Build.write_file_dyn ml_source );
+  let linkages = [ Exe.Linkage.native_or_custom ctx ] in
+  let program : Exe.Program.t =
+    { name = Filename.remove_extension (Path.Build.basename target)
+    ; main_module_name
+    ; loc = Loc.none
+    }
+  in
+  let obj_dir = Obj_dir.for_pp ~dir in
+  let cctx =
+    let expander = Super_context.expander sctx ~dir in
+    let requires_compile = Result.map driver_and_libs ~f:snd in
+    let requires_link = lazy requires_compile in
+    let flags = Ocaml_flags.of_list [ "-g"; "-w"; "-24" ] in
+    let opaque = Compilation_context.Explicit false in
+    let modules = Modules.singleton_exe module_ in
+    Compilation_context.create ~super_context:sctx ~scope ~expander ~obj_dir
+      ~modules ~flags ~requires_compile ~requires_link ~opaque ~js_of_ocaml:None
+      ~dynlink:false ~package:None ~bin_annot:false ()
+  in
+  Exe.build_and_link ~program ~linkages cctx ~promote:None
 
 let get_rules sctx key =
   let exe = ppx_exe sctx ~key in
-  let pps, pp_names =
-    let names, lib_db =
-      match Digest.from_hex key with
-      | None ->
-        User_error.raise
-          [ Pp.textf "invalid ppx key for %s"
-              (Path.Build.to_string_maybe_quoted exe)
-          ]
-      | Some key ->
-        let { Key.Decoded.pps; project_root } = Key.decode key in
-        let lib_db =
+  let pp_names, scope =
+    match Digest.from_hex key with
+    | None ->
+      User_error.raise
+        [ Pp.textf "invalid ppx key for %s"
+            (Path.Build.to_string_maybe_quoted exe)
+        ]
+    | Some key ->
+      let { Key.Decoded.pps; project_root } = Key.decode key in
+      let scope =
+        let dir =
           match project_root with
-          | None -> SC.public_libs sctx
+          | None -> (Super_context.context sctx).build_dir
           | Some dir ->
-            let dir =
-              Path.Build.append_source (Super_context.context sctx).build_dir
-                dir
-            in
-            Scope.libs (SC.find_scope_by_dir sctx dir)
+            Path.Build.append_source (Super_context.context sctx).build_dir dir
         in
-        (pps, lib_db)
-    in
-    let pps =
-      Lib.DB.resolve_pps lib_db (List.map names ~f:(fun x -> (Loc.none, x)))
-    in
-    (pps, names)
+        Super_context.find_scope_by_dir sctx dir
+      in
+      (pps, scope)
+  in
+  let pps =
+    let lib_db = Scope.libs scope in
+    List.map pp_names ~f:(fun x -> (Loc.none, x)) |> Lib.DB.resolve_pps lib_db
   in
-  build_ppx_driver sctx ~pps ~pp_names ~dep_kind:Required ~target:exe
+  build_ppx_driver sctx ~scope ~pps ~pp_names ~target:exe
 
 let gen_rules sctx components =
   match components with
@@ -587,9 +574,9 @@ let lint_module sctx ~dir ~expander ~dep_kind ~lint ~lib_name ~scope =
      fun ~(source : Module.t) ~ast ->
        Module_name.Per_item.get lint (Module.name source) ~source ~ast)
 
-type t = (Module.t -> lint:bool -> Module.t) Module_name.Per_item.t
+type t = Pp_spec.t
 
-let dummy = Module_name.Per_item.for_all (fun m ~lint:_ -> m)
+let dummy = Pp_spec.dummy
 
 let make sctx ~dir ~expander ~dep_kind ~lint ~preprocess ~preprocessor_deps
     ~lib_name ~scope =

src/dune_rules/preprocessing.mli

@@ -5,7 +5,7 @@ open! Stdune
 open! Import
 
 (** Preprocessing object *)
-type t
+type t = Pp_spec.t
 
 val dummy : t
 

test/blackbox-tests/test-cases/github3336.t/run.t

@@ -1,6 +1,10 @@
 Issue #3336 describes a bug where it's not possible to use dune_build_info from
 ppx binaries.
 
-  $ dune exec ./executable/exec.exe 2>&1 | grep -v "^File" | sed -E 's/from .+/from ../'
-  Error: No implementations provided for the following modules:
-           Build_info__Build_info_data referenced from ..
+  $ dune exec ./executable/exec.exe 2>&1
+  File "executable/dune", line 3, characters 13-22:
+  3 |  (preprocess (pps ppx)))
+                   ^^^^^^^^^
+  Error: Rule failed to generate the following targets:
+  - executable/exec.pp.ml
+  [1]

test/blackbox-tests/test-cases/private-public-overlap.t/run.t

@@ -15,6 +15,8 @@ On the other hand, public libraries may have private preprocessors
         ocamlc .ppx_internal.objs/byte/ppx_internal.{cmi,cmo,cmt}
       ocamlopt .ppx_internal.objs/native/ppx_internal.{cmx,o}
       ocamlopt ppx_internal.{a,cmxa}
+        ocamlc .ppx/be26d3600214af2fa78c2c9ef25e9069/dune__exe___ppx.{cmi,cmo}
+      ocamlopt .ppx/be26d3600214af2fa78c2c9ef25e9069/dune__exe___ppx.{cmx,o}
       ocamlopt .ppx/be26d3600214af2fa78c2c9ef25e9069/ppx.exe
            ppx mylib.pp.ml
         ocamlc .mylib.objs/byte/mylib.{cmi,cmo,cmt}