fix(x-compilation): find host ppx dependencies in the host context

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

src/dune_rules/buildable_rules.ml

@@ -56,9 +56,8 @@ let modules_rules ~preprocess ~preprocessor_deps ~lint
         (Preprocess.Per_module.instrumentation_deps preprocess
            ~instrumentation_backend)
     in
-    Preprocessing.make sctx ~dir ~scope
-      ~preprocess:preprocess_with_instrumentation ~expander ~preprocessor_deps
-      ~instrumentation_deps ~lint ~lib_name
+    Preprocessing.make sctx ~dir ~preprocess:preprocess_with_instrumentation
+      ~expander ~preprocessor_deps ~instrumentation_deps ~lint ~lib_name
   in
   let add_empty_intf =
     let default = empty_module_interface_if_absent in

src/dune_rules/cinaps.ml

@@ -114,7 +114,7 @@ let gen_rules sctx t ~dir ~scope =
     Preprocessing.make sctx ~dir ~expander
       ~lint:(Preprocess.Per_module.no_preprocessing ())
       ~preprocess:t.preprocess ~preprocessor_deps:t.preprocessor_deps
-      ~instrumentation_deps:[] ~lib_name:None ~scope
+      ~instrumentation_deps:[] ~lib_name:None
   in
   let* modules =
     Modules.singleton_exe module_

src/dune_rules/expander.ml

@@ -65,6 +65,8 @@ type t =
 
 let scope t = t.scope
 
+let scope_host t = t.scope_host
+
 let artifacts t = t.bin_artifacts_host
 
 let dir t = t.dir

src/dune_rules/expander.mli

@@ -6,6 +6,8 @@ type t
 
 val scope : t -> Scope.t
 
+val scope_host : t -> Scope.t
+
 val dir : t -> Path.Build.t
 
 val context : t -> Context.t

src/dune_rules/jsoo/jsoo_rules.ml

@@ -355,7 +355,7 @@ let setup_separate_compilation_rules sctx components =
     let pkg = Lib_name.parse_string_exn (Loc.none, s_pkg) in
     let ctx = Super_context.context sctx in
     let open Memo.O in
-    let* installed_libs = Lib.DB.installed ctx in
+    let* installed_libs = Lib.DB.installed ~host:None ctx in
     Lib.DB.find installed_libs pkg >>= function
     | None -> Memo.return ()
     | Some pkg ->

src/dune_rules/lib.ml

@@ -372,6 +372,7 @@ end
 
 type db =
   { parent : db option
+  ; db_host : db Lazy.t
   ; resolve : Lib_name.t -> resolve_result Memo.t
   ; all : Lib_name.t list Memo.Lazy.t
   ; lib_config : Lib_config.t
@@ -1287,7 +1288,10 @@ end = struct
       let pps =
         let* pps =
           Resolve.Memo.List.map pps ~f:(fun (loc, name) ->
-              let* lib = resolve_dep db (loc, name) ~private_deps:Allow_all in
+              let* lib =
+                resolve_dep (Lazy.force db.db_host) (loc, name)
+                  ~private_deps:Allow_all
+              in
               match (allow_only_ppx_deps, Lib_info.kind lib.info) with
               | true, Normal -> Error.only_ppx_deps_allowed ~loc lib.info
               | _ -> Resolve.Memo.return lib)
@@ -1729,12 +1733,24 @@ module DB = struct
 
   type t = db
 
-  let create ~parent ~resolve ~all ~lib_config () =
-    { parent; resolve; all = Memo.lazy_ all; lib_config }
+  let create ~parent ~host ~resolve ~all ~lib_config () =
+    let rec t =
+      lazy
+        { parent
+        ; db_host =
+            (match host with
+            | Some host -> Lazy.from_val host
+            | None -> t)
+        ; resolve
+        ; all = Memo.lazy_ all
+        ; lib_config
+        }
+    in
+    Lazy.force t
 
-  let create_from_findlib findlib =
+  let create_from_findlib ~host findlib =
     let lib_config = Findlib.lib_config findlib in
-    create () ~parent:None ~lib_config
+    create () ~parent:None ~host ~lib_config
       ~resolve:(fun name ->
         let open Memo.O in
         Findlib.find findlib name >>| function
@@ -1750,12 +1766,12 @@ module DB = struct
         let open Memo.O in
         Findlib.all_packages findlib >>| List.map ~f:Dune_package.Entry.name)
 
-  let installed (context : Context.t) =
+  let installed (context : Context.t) ~host =
     let open Memo.O in
     let+ findlib =
       Findlib.create ~paths:context.findlib_paths ~lib_config:context.lib_config
     in
-    create_from_findlib findlib
+    create_from_findlib ~host findlib
 
   let find t name =
     let open Memo.O in

src/dune_rules/lib.mli

@@ -99,7 +99,7 @@ module DB : sig
   (** A database allow to resolve library names *)
   type t = db
 
-  val installed : Context.t -> t Memo.t
+  val installed : Context.t -> host:t option -> t Memo.t
 
   module Resolve_result : sig
     type db := t
@@ -124,6 +124,7 @@ module DB : sig
       [all] returns the list of names of libraries available in this database. *)
   val create :
        parent:t option
+    -> host:t option
     -> resolve:(Lib_name.t -> Resolve_result.t Memo.t)
     -> all:(unit -> Lib_name.t list Memo.t)
     -> lib_config:Lib_config.t

src/dune_rules/preprocessing.ml

@@ -720,7 +720,8 @@ let pp_one_module sctx ~lib_name ~scope ~preprocessor_deps
                         >>| Action.Full.add_sandbox sandbox))))
 
 let make sctx ~dir ~expander ~lint ~preprocess ~preprocessor_deps
-    ~instrumentation_deps ~lib_name ~scope =
+    ~instrumentation_deps ~lib_name =
+  let scope = Expander.scope_host expander in
   let preprocessor_deps = preprocessor_deps @ instrumentation_deps in
   let preprocess =
     Module_name.Per_item.map preprocess ~f:(fun pp ->

src/dune_rules/preprocessing.mli

@@ -16,7 +16,6 @@ val make :
   -> preprocessor_deps:Dep_conf.t list
   -> instrumentation_deps:Dep_conf.t list
   -> lib_name:Lib_name.Local.t option
-  -> scope:Scope.t
   -> Pp_spec.t
 
 (** Get a path to a cached ppx driver with some extra flags for cookies. *)

src/dune_rules/scope.ml

@@ -77,7 +77,7 @@ module DB = struct
       | Deprecated_library_name of Dune_file.Deprecated_library_name.t
   end
 
-  let create_db_from_stanzas ~parent ~lib_config stanzas =
+  let create_db_from_stanzas ~parent ~lib_config ~host stanzas =
     let open Memo.O in
     let+ (map : Found_or_redirect.t Lib_name.Map.t) =
       Memo.List.map stanzas ~f:(fun stanza ->
@@ -132,7 +132,7 @@ module DB = struct
                   ; Pp.textf "- %s" (Loc.to_file_colon_line loc2)
                   ])
     in
-    Lib.DB.create () ~parent:(Some parent)
+    Lib.DB.create () ~parent:(Some parent) ~host
       ~resolve:(fun name ->
         Memo.return
           (match Lib_name.Map.find map name with
@@ -165,7 +165,7 @@ module DB = struct
     lazy (public_theories ~find_db coq_stanzas)
 
   (* Create a database from the public libraries defined in the stanzas *)
-  let public_libs t ~installed_libs ~lib_config stanzas =
+  let public_libs t ~installed_libs ~lib_config ~host stanzas =
     let public_libs =
       List.filter_map stanzas ~f:(fun (stanza : Library_related_stanza.t) ->
           match stanza with
@@ -213,7 +213,7 @@ module DB = struct
             ])
     in
     let resolve lib = Memo.return (resolve t public_libs lib) in
-    Lib.DB.create ~parent:(Some installed_libs) ~resolve
+    Lib.DB.create ~parent:(Some installed_libs) ~host ~resolve
       ~all:(fun () -> Lib_name.Map.keys public_libs |> Memo.return)
       ~lib_config ()
 
@@ -246,8 +246,8 @@ module DB = struct
         |> Coq_lib.DB.create_from_coqlib_stanzas ~parent ~find_db
         |> Option.some)
 
-  let scopes_by_dir ~build_dir ~lib_config ~projects ~public_libs
-      ~public_theories stanzas coq_stanzas =
+  let rec scopes_by_dir ~host_context ~build_dir ~lib_config ~projects
+      ~public_libs ~public_theories stanzas coq_stanzas =
     let open Memo.O in
     let projects_by_dir =
       List.map projects ~f:(fun (project : Dune_project.t) ->
@@ -273,10 +273,24 @@ module DB = struct
           Some (project, stanzas))
       |> Path_source_map_traversals.parallel_map
            ~f:(fun _dir (project, stanzas) ->
-             let+ db =
-               create_db_from_stanzas stanzas ~parent:public_libs ~lib_config
-             in
-             (project, db))
+             match host_context with
+             | None ->
+               let+ db =
+                 create_db_from_stanzas stanzas ~parent:public_libs ~host:None
+                   ~lib_config
+               in
+               (project, db)
+             | Some host_context ->
+               let* scopes, public_libs = create_from_stanzas host_context in
+               let host =
+                 let scope = find_by_project scopes project in
+                 scope.db
+               in
+               let+ db =
+                 create_db_from_stanzas stanzas ~parent:public_libs
+                   ~host:(Some host) ~lib_config
+               in
+               (project, db))
     in
 
     let coq_scopes_by_dir =
@@ -298,27 +312,49 @@ module DB = struct
         let coq_db = coq_db_find dir in
         { project; db; coq_db; root })
 
-  let create ~(context : Context.t) ~projects stanzas coq_stanzas =
+  and create ~(context : Context.t) ~projects stanzas coq_stanzas =
     let open Memo.O in
     let t = Fdecl.create Dyn.opaque in
     let build_dir = context.build_dir in
     let lib_config = Context.lib_config context in
-    let* public_libs =
-      let+ installed_libs = Lib.DB.installed context in
-      public_libs t ~lib_config ~installed_libs stanzas
+    let* public_libs, host_context =
+      let host_context =
+        let host_context = Context.host context in
+        match Context.equal host_context context with
+        | true -> None
+        | false -> Some host_context
+      in
+      let+ public_libs =
+        match host_context with
+        | None ->
+          let host = None in
+          let+ installed_libs = Lib.DB.installed ~host context in
+          public_libs t ~lib_config ~installed_libs ~host stanzas
+        | Some host_context ->
+          let* host =
+            let+ host =
+              let+ installed_libs = Lib.DB.installed ~host:None host_context in
+              public_libs t ~lib_config ~installed_libs ~host:None stanzas
+            in
+            Some host
+          in
+          let+ installed_libs = Lib.DB.installed ~host context in
+          public_libs t ~lib_config ~installed_libs ~host stanzas
+      in
+      (public_libs, host_context)
     in
     let public_theories =
       public_theories coq_stanzas ~find_db:(fun _ -> public_libs)
     in
     let+ by_dir =
-      scopes_by_dir ~build_dir ~lib_config ~projects ~public_libs
+      scopes_by_dir ~host_context ~build_dir ~lib_config ~projects ~public_libs
         ~public_theories stanzas coq_stanzas
     in
     let value = { by_dir } in
     Fdecl.set t value;
     (value, public_libs)
 
-  let create_from_stanzas ~projects ~(context : Context.t) stanzas =
+  and from_stanzas ~projects ~(context : Context.t) stanzas =
     let stanzas, coq_stanzas =
       Dune_file.fold_stanzas stanzas ~init:([], [])
         ~f:(fun dune_file stanza (acc, coq_acc) ->
@@ -340,22 +376,23 @@ module DB = struct
     in
     create ~projects ~context stanzas coq_stanzas
 
-  let all =
-    Memo.Lazy.create @@ fun () ->
-    let+ contexts = Context.DB.all () in
-    Context_name.Map.of_list_map_exn contexts ~f:(fun context ->
-        let scopes =
-          Memo.Lazy.create @@ fun () ->
-          let* { Dune_load.dune_files = _; packages = _; projects } =
-            Dune_load.load ()
-          in
-          let* stanzas = Only_packages.filtered_stanzas context in
-          create_from_stanzas ~projects ~context stanzas
-        in
-        (context.name, scopes))
+  and all =
+    lazy
+      ( Memo.Lazy.create @@ fun () ->
+        let+ contexts = Context.DB.all () in
+        Context_name.Map.of_list_map_exn contexts ~f:(fun context ->
+            let scopes =
+              Memo.Lazy.create @@ fun () ->
+              let* { Dune_load.dune_files = _; packages = _; projects } =
+                Dune_load.load ()
+              in
+              let* stanzas = Only_packages.filtered_stanzas context in
+              from_stanzas ~projects ~context stanzas
+            in
+            (context.name, scopes)) )
 
-  let create_from_stanzas (context : Context.t) =
-    let* all = Memo.Lazy.force all in
+  and create_from_stanzas (context : Context.t) =
+    let* all = Memo.Lazy.force (Lazy.force all) in
     Context_name.Map.find_exn all context.name |> Memo.Lazy.force
 
   let with_all context ~f =

src/dune_rules/toplevel.ml

@@ -163,7 +163,7 @@ module Stanza = struct
     in
     let preprocessing =
       let preprocess = Module_name.Per_item.for_all toplevel.pps in
-      Preprocessing.make sctx ~dir ~expander ~scope ~lib_name:None
+      Preprocessing.make sctx ~dir ~expander ~lib_name:None
         ~lint:Dune_file.Lint.no_lint ~preprocess ~preprocessor_deps:[]
         ~instrumentation_deps:[]
     in

src/dune_rules/utop.ml

@@ -143,7 +143,7 @@ let setup sctx ~dir =
   in
   let preprocessing =
     let preprocess = Module_name.Per_item.for_all pps in
-    Preprocessing.make sctx ~dir ~expander ~scope ~lib_name:None
+    Preprocessing.make sctx ~dir ~expander ~lib_name:None
       ~lint:Dune_file.Lint.no_lint ~preprocess ~preprocessor_deps:[]
       ~instrumentation_deps:[]
   in

test/blackbox-tests/test-cases/ppx-cross-context-issue.t/run.t

@@ -1,12 +1,29 @@
-# Using a ppx in a cross-compiled build context makes dune try to build the ppx
-# in the target context instead of the host, then fail.
-  $ dune build --debug-dependency-path
-  File "lib/dune", line 3, characters 18-24:
-  3 |  (preprocess (pps fooppx)))
-                        ^^^^^^
-  Error: Library "fooppx" in _build/cross-environment/ppx is hidden
-  (unsatisfied 'enabled_if').
-  -> required by _build/cross-environment/lib/lib.pp.ml
-  -> required by alias lib/all (context cross-environment)
-  -> required by alias default (context cross-environment)
-  [1]
+Dune uses the host context to look up dependencies and build PPXes
+
+  $ dune build --display=short
+        ocamlc lib/.foolib.objs/byte/foolib.{cmi,cmo,cmt}
+        ocamlc ppx/.fooppx.objs/byte/fooppx.{cmi,cmo,cmt}
+        ocamlc lib/.foolib.objs/byte/foolib.{cmi,cmo,cmt} [cross-environment]
+      ocamlopt lib/.foolib.objs/native/foolib.{cmx,o}
+        ocamlc .ppx/4128e43a9cfb141a37f547484cc9bf46/dune__exe___ppx.{cmi,cmo}
+      ocamlopt ppx/.fooppx.objs/native/fooppx.{cmx,o}
+        ocamlc ppx/fooppx.cma
+      ocamlopt lib/.foolib.objs/native/foolib.{cmx,o} [cross-environment]
+      ocamlopt .ppx/4128e43a9cfb141a37f547484cc9bf46/dune__exe___ppx.{cmx,o}
+      ocamlopt ppx/fooppx.{a,cmxa}
+      ocamlopt .ppx/4128e43a9cfb141a37f547484cc9bf46/ppx.exe
+      ocamlopt ppx/fooppx.cmxs
+           ppx lib/lib.pp.ml
+           ppx lib/lib.pp.ml [cross-environment]
+      ocamldep lib/.foolib.objs/foolib__Lib.impl.d
+      ocamldep lib/.foolib.objs/foolib__Lib.impl.d [cross-environment]
+        ocamlc lib/.foolib.objs/byte/foolib__Lib.{cmi,cmo,cmt}
+        ocamlc lib/.foolib.objs/byte/foolib__Lib.{cmi,cmo,cmt} [cross-environment]
+      ocamlopt lib/.foolib.objs/native/foolib__Lib.{cmx,o}
+        ocamlc lib/foolib.cma
+      ocamlopt lib/.foolib.objs/native/foolib__Lib.{cmx,o} [cross-environment]
+        ocamlc lib/foolib.cma [cross-environment]
+      ocamlopt lib/foolib.{a,cmxa}
+      ocamlopt lib/foolib.{a,cmxa} [cross-environment]
+      ocamlopt lib/foolib.cmxs
+      ocamlopt lib/foolib.cmxs [cross-environment]