Fix root_module and preprocessing bug

do not try to preprocess root_module. Do this by excluding it from the
set of "user written" modules.

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

Author: rgrinberg

CHANGES.md

@@ -154,6 +154,9 @@ Unreleased
 - Fix `root_module` when used in public libraries (#4685, fixes #4684,
   @rgrinberg, @CraigFe)
 
+- Fix `root_module` when used with preprocessing (#4683, fixes #4682,
+  @rgrinberg, @CraigFe)
+
 2.9.0 (unreleased)
 ------------------
 

src/dune_rules/ml_sources.ml

@@ -46,7 +46,7 @@ module Modules = struct
     let rev_map =
       let rev_modules =
         let by_name buildable =
-          Modules.fold_user_written ~init:[] ~f:(fun m acc ->
+          Modules.fold_user_available ~init:[] ~f:(fun m acc ->
               (Module.name m, buildable) :: acc)
         in
         List.rev_append
@@ -104,7 +104,7 @@ module Artifacts = struct
     in
     let modules =
       let by_name modules obj_dir =
-        Modules_group.fold_user_written ~init:modules ~f:(fun m modules ->
+        Modules_group.fold_user_available ~init:modules ~f:(fun m modules ->
             Module_name.Map.add_exn modules (Module.name m) (obj_dir, m))
       in
       let init =

src/dune_rules/modules.ml

@@ -656,7 +656,34 @@ let wrapped_compat = function
     Module_name.Map.empty
   | Wrapped w -> w.wrapped_compat
 
+let rec fold_user_available t ~f ~init =
+  match t with
+  | Stdlib w -> Stdlib.fold w ~init ~f
+  | Singleton m -> f m init
+  | Wrapped { modules; _ }
+  | Unwrapped modules ->
+    Module_name.Map.fold modules ~init ~f
+  | Impl { impl; vlib = _ } ->
+    (* XXX shouldn't we folding over [vlib] as well? *)
+    fold_user_available impl ~f ~init
+
+let is_user_written m =
+  match Module.kind m with
+  | Root -> false
+  | Wrapped_compat
+  | Alias ->
+    (* Logically, this shold be [acc]. But this is unreachable these are stored
+       separately *)
+    assert false
+  | _ -> true
+
 let rec fold_user_written t ~f ~init =
+  let f m acc =
+    if is_user_written m then
+      f m acc
+    else
+      acc
+  in
   match t with
   | Stdlib w -> Stdlib.fold w ~init ~f
   | Singleton m -> f m init
@@ -666,6 +693,12 @@ let rec fold_user_written t ~f ~init =
   | Impl { impl; vlib = _ } -> fold_user_written impl ~f ~init
 
 let rec map_user_written t ~f =
+  let f m =
+    if is_user_written m then
+      f m
+    else
+      Memo.Build.return m
+  in
   let open Memo.Build.O in
   match t with
   | Singleton m ->

src/dune_rules/modules.mli

@@ -55,6 +55,8 @@ val fold_user_written : t -> f:(Module.t -> 'acc -> 'acc) -> init:'acc -> 'acc
 val map_user_written :
   t -> f:(Module.t -> Module.t Memo.Build.t) -> t Memo.Build.t
 
+val fold_user_available : t -> f:(Module.t -> 'acc -> 'acc) -> init:'acc -> 'acc
+
 (** Returns all the compatibility modules. *)
 val wrapped_compat : t -> Module.Name_map.t
 

test/blackbox-tests/test-cases/github4682.t/ppx/dune

@@ -1,5 +1,4 @@
 (library
  (name ppx)
  (kind ppx_rewriter)
- (libraries lib)
  (ppx.driver (main Ppx.main)))

test/blackbox-tests/test-cases/github4682.t/ppx/ppx.ml

@@ -1 +1,12 @@
-let main () = ()
+let main () =
+  let out = ref "" in
+  let args =
+    [ ("-o", Arg.Set_string out, "")
+    ; ("--impl", Arg.Set_string (ref ""), "")
+    ; ("--as-ppx", Arg.Set (ref false), "")
+    ]
+  in
+  let anon _ = () in
+  Arg.parse (Arg.align args) anon "";
+  let out = open_out !out in
+  close_out out;

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

@@ -2,7 +2,3 @@ Attempting to use `(root_module ...)` with an executable that uses PPX results
 in an unexpected build failure:
 
   $ dune build
-  Error: Multiple rules generated for _build/default/root.pp.ml-gen:
-  - dune:5
-  - <none>:1
-  [1]