fix: allow looking up artifacts everywhere

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

<!-- ps-id: f31ed293-c931-4432-a1a4-258c7f7570cf -->

bin/target.ml

@@ -168,15 +168,18 @@ let resolve_path path ~(setup : Dune_rules.Main.build_system)
 ;;
 
 let expand_path_from_root (root : Workspace_root.t) sctx sv =
-  let ctx = Super_context.context sctx in
-  let dir =
-    Path.Build.relative
-      (Context.build_dir ctx)
-      (String.concat ~sep:Filename.dir_sep root.to_cwd)
+  let+ s =
+    let* expander =
+      let dir =
+        let ctx = Super_context.context sctx in
+        Path.Build.relative
+          (Context.build_dir ctx)
+          (String.concat ~sep:Filename.dir_sep root.to_cwd)
+      in
+      Action_builder.of_memo (Dune_rules.Super_context.expander sctx ~dir)
+    in
+    Dune_rules.Expander.expand_str expander sv
   in
-  let* expander = Action_builder.of_memo (Dune_rules.Super_context.expander sctx ~dir) in
-  let expander = Dune_rules.Dir_contents.add_sources_to_expander sctx expander in
-  let+ s = Dune_rules.Expander.expand_str expander sv in
   root.reach_from_root_prefix ^ s
 ;;
 

doc/changes/10169.md

@@ -0,0 +1,2 @@
+- Allow artifact expansion percent forms (`%{cma:..}`, `%{cmo:..}`, etc.) in
+  more contexts. Previously, they would be randomly forbidden in some fields.

src/dune_rules/dir_contents.ml

@@ -154,13 +154,7 @@ let build_mlds_map stanzas ~dir ~files =
 module rec Load : sig
   val get : Super_context.t -> dir:Path.Build.t -> t Memo.t
   val triage : Super_context.t -> dir:Path.Build.t -> triage Memo.t
-  val add_sources_to_expander : Super_context.t -> Expander.t -> Expander.t
 end = struct
-  let add_sources_to_expander sctx expander =
-    let f ~dir = Load.get sctx ~dir >>= artifacts in
-    Expander.set_lookup_ml_sources expander ~f
-  ;;
-
   let select_deps_files libraries =
     (* Manually add files generated by the (select ...)
        dependencies *)
@@ -179,9 +173,7 @@ end = struct
       (* Interpret a few stanzas in order to determine the list of files generated
          by the user. *)
       let+ generated_files =
-        let* expander =
-          Super_context.expander sctx ~dir >>| add_sources_to_expander sctx
-        in
+        let* expander = Super_context.expander sctx ~dir in
         Memo.parallel_map stanzas ~f:(fun stanza ->
           match Stanza.repr stanza with
           | Coq_stanza.Coqpp.T { modules; _ } ->
@@ -474,3 +466,12 @@ let modules_of_lib sctx lib =
     let+ modules = modules_of_local_lib sctx (Lib.Local.of_lib_exn lib) in
     Some modules
 ;;
+
+let () =
+  Fdecl.set Expander.lookup_artifacts (fun ~dir ->
+    Context.DB.by_dir dir
+    >>| Context.name
+    >>= Super_context.find_exn
+    >>= Load.get ~dir
+    >>= artifacts)
+;;

src/dune_rules/dir_contents.mli

@@ -65,9 +65,3 @@ type triage =
     However, if the directory is part of a group, this function simply returns
     the root of the group. *)
 val triage : Super_context.t -> dir:Path.Build.t -> triage Memo.t
-
-(** Add expansion that depend on OCaml artifacts/sources.
-
-    This function live in super_context.ml or expander.ml because it would
-    introduce a dependency cycle. *)
-val add_sources_to_expander : Super_context.t -> Expander.t -> Expander.t

src/dune_rules/expander.ml

@@ -44,6 +44,8 @@ end
 
 type value = Value.t list Deps.t
 
+let lookup_artifacts = Fdecl.create Dyn.opaque
+
 type t =
   { dir : Path.Build.t
   ; env : Env.t
@@ -55,7 +57,6 @@ type t =
   ; scope : Scope.t
   ; scope_host : Scope.t
   ; context : Context.t
-  ; lookup_artifacts : (dir:Path.Build.t -> Artifacts_obj.t Memo.t) option
   ; expanding_what : Expanding_what.t
   }
 
@@ -70,7 +71,6 @@ let set_local_env_var t ~var ~value =
 let set_dir t ~dir = { t with dir }
 let set_scope t ~scope ~scope_host = { t with scope; scope_host }
 let set_artifacts t ~artifacts_host = { t with artifacts_host }
-let set_lookup_ml_sources t ~f = { t with lookup_artifacts = Some f }
 let set_expanding_what t x = { t with expanding_what = x }
 
 let map_exe t p =
@@ -155,46 +155,41 @@ let expand_version { scope; _ } ~(source : Dune_lang.Template.Pform.t) s =
          ])
 ;;
 
-let expand_artifact ~source t a s =
-  match t.lookup_artifacts with
-  | None -> isn't_allowed_in_this_position ~source
-  | Some lookup ->
-    let path = Path.Build.relative t.dir s in
-    let name = Path.Build.basename path in
-    let dir = Path.Build.parent_exn path in
-    let does_not_exist ~loc ~what name =
-      User_error.raise ~loc [ Pp.textf "%s %s does not exist." what name ]
+let expand_artifact ~source t artifact arg =
+  let path = Path.Build.relative t.dir arg in
+  let loc = Dune_lang.Template.Pform.loc source in
+  let name = Path.Build.basename path in
+  let dir = Path.Build.parent_exn path in
+  if Path.Build.is_root dir
+  then User_error.raise ~loc [ Pp.text "cannot escape the workspace root directory" ];
+  let does_not_exist ~what name =
+    User_error.raise ~loc [ Pp.textf "%s %s does not exist." what name ]
+  in
+  let* artifacts =
+    let lookup = Fdecl.get lookup_artifacts in
+    Action_builder.of_memo (lookup ~dir)
+  in
+  match artifact with
+  | Pform.Artifact.Mod kind ->
+    let name =
+      Module_name.of_string_allow_invalid (Dune_lang.Template.Pform.loc source, name)
     in
-    let* artifacts = Action_builder.of_memo (lookup ~dir) in
-    (match a with
-     | Pform.Artifact.Mod kind ->
-       let name =
-         Module_name.of_string_allow_invalid (Dune_lang.Template.Pform.loc source, name)
-       in
-       (match Artifacts_obj.lookup_module artifacts name with
-        | None ->
-          does_not_exist
-            ~loc:(Dune_lang.Template.Pform.loc source)
-            ~what:"Module"
-            (Module_name.to_string name)
-        | Some (t, m) ->
-          (match Obj_dir.Module.cm_file t m ~kind:(Ocaml kind) with
-           | None -> Action_builder.return [ Value.String "" ]
-           | Some path -> dep (Path.build path)))
-     | Lib mode ->
-       let name = Lib_name.parse_string_exn (Dune_lang.Template.Pform.loc source, name) in
-       (match Artifacts_obj.lookup_library artifacts name with
-        | None ->
-          does_not_exist
-            ~loc:(Dune_lang.Template.Pform.loc source)
-            ~what:"Library"
-            (Lib_name.to_string name)
-        | Some lib ->
-          Mode.Dict.get (Lib_info.archives lib) mode
-          |> Action_builder.List.map ~f:(fun fn ->
-            let fn = Path.build fn in
-            let+ () = Action_builder.path fn in
-            Value.Path fn)))
+    (match Artifacts_obj.lookup_module artifacts name with
+     | None -> does_not_exist ~what:"Module" (Module_name.to_string name)
+     | Some (t, m) ->
+       (match Obj_dir.Module.cm_file t m ~kind:(Ocaml kind) with
+        | None -> Action_builder.return [ Value.String "" ]
+        | Some path -> dep (Path.build path)))
+  | Lib mode ->
+    let name = Lib_name.parse_string_exn (Dune_lang.Template.Pform.loc source, name) in
+    (match Artifacts_obj.lookup_library artifacts name with
+     | None -> does_not_exist ~what:"Library" (Lib_name.to_string name)
+     | Some lib ->
+       Mode.Dict.get (Lib_info.archives lib) mode
+       |> Action_builder.List.map ~f:(fun fn ->
+         let fn = Path.build fn in
+         let+ () = Action_builder.path fn in
+         Value.Path fn))
 ;;
 
 let foreign_flags = Fdecl.create Dyn.opaque
@@ -764,7 +759,6 @@ let make_root
   ; lib_artifacts_host
   ; artifacts_host
   ; context
-  ; lookup_artifacts = None
   ; expanding_what = Nothing_special
   }
 ;;

src/dune_rules/expander.mli

@@ -21,7 +21,6 @@ val set_local_env_var : t -> var:string -> value:string Action_builder.t -> t
 val set_dir : t -> dir:Path.Build.t -> t
 val set_scope : t -> scope:Scope.t -> scope_host:Scope.t -> t
 val set_artifacts : t -> artifacts_host:Artifacts.t -> t
-val set_lookup_ml_sources : t -> f:(dir:Path.Build.t -> Artifacts_obj.t Memo.t) -> t
 
 module Expanding_what : sig
   type t =
@@ -141,3 +140,5 @@ val expand_locks
 val foreign_flags
   : (dir:Path.Build.t -> string list Action_builder.t Foreign_language.Dict.t Memo.t)
       Fdecl.t
+
+val lookup_artifacts : (dir:Path.Build.t -> Artifacts_obj.t Memo.t) Fdecl.t

src/dune_rules/gen_rules.ml

@@ -302,11 +302,9 @@ let gen_format_and_cram_rules sctx ~expander ~dir source_dir =
 let gen_rules_source_only sctx ~dir source_dir =
   Rules.collect_unit (fun () ->
     let* sctx = sctx in
-    let* expander =
-      let+ expander = Super_context.expander sctx ~dir in
-      Dir_contents.add_sources_to_expander sctx expander
-    in
-    let+ () = gen_format_and_cram_rules sctx ~expander ~dir source_dir
+    let+ () =
+      let* expander = Super_context.expander sctx ~dir in
+      gen_format_and_cram_rules sctx ~expander ~dir source_dir
     and+ () =
       define_all_alias ~dir ~js_targets:[] ~project:(Source_tree.Dir.project source_dir)
     in
@@ -316,10 +314,7 @@ let gen_rules_source_only sctx ~dir source_dir =
 let gen_rules_group_part_or_root sctx dir_contents cctxs ~source_dir ~dir
   : (Loc.t * Compilation_context.t) list Memo.t
   =
-  let* expander =
-    let+ expander = Super_context.expander sctx ~dir in
-    Dir_contents.add_sources_to_expander sctx expander
-  in
+  let* expander = Super_context.expander sctx ~dir in
   let* () = gen_format_and_cram_rules sctx ~expander ~dir source_dir
   and+ stanzas =
     (* CR-soon rgrinberg: we shouldn't have to fetch the stanzas yet again *)

test/blackbox-tests/test-cases/variables-for-artifacts.t/run.t

@@ -191,7 +191,11 @@ This test checks error handling.
 
   $ dune build %{cma:../x}
   File "command line", line 1, characters 0-11:
-  Error: Library x does not exist.
+  Error: cannot escape the workspace root directory
+  [1]
+  $ dune build %{cma:../../x}
+  Error: path outside the workspace: ../../x from default
+  -> required by %{cma:../../x} at command line:1
   [1]
 
 This test checks that everything still works if we invoke dune from a