Add a ppx pform to simplify writing tests (#12711)

The pform %{ppx:lib1+lib2+..+libn} is substituted to the path of the ppx
binary that has all the ppx's lib1,lib2,...,libn linked in. This pform
automatically adds a dependnecy on this executable.

Signed-off-by: Rudi Grinberg <[email protected]>

Author: rgrinberg

doc/changes/added/12711.md

@@ -0,0 +1,3 @@
+- Introduce a `%{ppx:lib1+..+libn}` stanza to make it possible to refer to ppx
+  executables built by dune. This is useful for writing tests (#12711,
+  @rgrinberg)

doc/concepts/variables.rst

@@ -131,6 +131,9 @@ In addition, ``(action ...)`` fields support the following special variables:
   file.
 - ``read-strings:<path>`` expands to the list of lines in the given
   file, unescaped using OCaml lexical convention.
+- ``ppx:lib1+..+libn`` expands to the ppx executable with ppx libraries
+  ``lib1`` to ``libn`` linked in. This form also introduces a dependency on
+  this executable.
 
 The ``%{<kind>:...}`` forms are what allows you to write custom rules that work
 transparently, whether things are installed or not.

src/dune_lang/pform.ml

@@ -300,6 +300,7 @@ module Macro = struct
     | Artifact of Artifact.t
     | Pkg
     | Pkg_self
+    | Ppx
 
   let compare x y =
     match x, y with
@@ -357,6 +358,9 @@ module Macro = struct
     | Pkg_self, Pkg_self -> Eq
     | Pkg_self, _ -> Lt
     | _, Pkg_self -> Gt
+    | Ppx, Ppx -> Eq
+    | Ppx, _ -> Lt
+    | _, Ppx -> Gt
     | Artifact x, Artifact y -> Artifact.compare x y
   ;;
 
@@ -384,6 +388,7 @@ module Macro = struct
     | Artifact ext -> variant "Artifact" [ Artifact.to_dyn ext ]
     | Pkg -> variant "Pkg" []
     | Pkg_self -> variant "Pkg_self" []
+    | Ppx -> string "Ppx"
   ;;
 
   let encode = function
@@ -407,6 +412,7 @@ module Macro = struct
     | Env -> Ok "env"
     | Pkg -> Ok "pkg"
     | Pkg_self -> Ok "pkg-self"
+    | Ppx -> Ok "ppx"
     | Artifact a -> Ok (String.drop (Artifact.ext a) 1)
   ;;
 end
@@ -672,6 +678,7 @@ module Env = struct
          ; "path-no-dep", deleted_in ~version:(1, 0) Macro.Path_no_dep
          ; "ocaml-config", macro Ocaml_config
          ; "env", since ~version:(1, 4) Macro.Env
+         ; "ppx", since ~version:(3, 21) Macro.Ppx
          ; "coq", macro Coq_config
          ]
          @ List.map ~f:artifact Artifact.all)

src/dune_lang/pform.mli

@@ -141,6 +141,7 @@ module Macro : sig
     | Artifact of Artifact.t
     | Pkg
     | Pkg_self
+    | Ppx
 
   val compare : t -> t -> Ordering.t
   val to_dyn : t -> Dyn.t

src/dune_rules/expander.ml

@@ -707,6 +707,23 @@ let expand_pform_macro
           (let open Memo.O in
            let* artifacts_host = t.artifacts_host in
            Coq_config.expand source macro_invocation artifacts_host))
+  | Ppx ->
+    Need_full_expander
+      (fun t ->
+        With
+          (let open Action_builder.O in
+           let+ exe =
+             let* scope = Action_builder.of_memo t.scope in
+             Pform.Macro_invocation.Args.whole macro_invocation
+             |> String.split ~on:'+'
+             |> List.map ~f:(fun name ->
+               let loc = Dune_lang.Template.Pform.loc source in
+               let name = Lib_name.parse_string_exn (loc, name) in
+               loc, name)
+             |> Ppx_exe.get_ppx_exe context ~scope
+             |> Resolve.Memo.read
+           in
+           [ Value.Path (Path.build exe) ]))
 ;;
 
 let expand_pform_gen ~(context : Context.t) ~bindings ~dir ~source (pform : Pform.t)

src/dune_rules/ppx_exe.ml

@@ -0,0 +1,96 @@
+open Import
+open Memo.O
+
+(* Encoded representation of a set of library names + scope *)
+module Key : sig
+  type encoded = Digest.t
+
+  module Decoded : sig
+    type t = private
+      { pps : Lib_name.t list
+      ; project_root : Path.Source.t option
+      }
+
+    val of_libs : Lib.t list -> t
+  end
+
+  val encode : Decoded.t -> encoded
+end = struct
+  type encoded = Digest.t
+
+  module Decoded = struct
+    type t =
+      { pps : Lib_name.t list
+      ; project_root : Path.Source.t option
+      }
+
+    let equal x y =
+      List.equal Lib_name.equal x.pps y.pps
+      && Option.equal Path.Source.equal x.project_root y.project_root
+    ;;
+
+    let to_string { pps; project_root } =
+      let s = String.enumerate_and (List.map pps ~f:Lib_name.to_string) in
+      match project_root with
+      | None -> s
+      | Some dir ->
+        sprintf "%s (in project: %s)" s (Path.Source.to_string_maybe_quoted dir)
+    ;;
+
+    let of_libs libs =
+      let pps =
+        (let compare a b = Lib_name.compare (Lib.name a) (Lib.name b) in
+         List.sort libs ~compare)
+        |> List.map ~f:Lib.name
+      in
+      let project =
+        List.fold_left libs ~init:None ~f:(fun acc lib ->
+          let scope_for_key =
+            let info = Lib.info lib in
+            let status = Lib_info.status info in
+            match status with
+            | Private (scope_name, _) -> Some scope_name
+            | Installed_private | Public _ | Installed -> None
+          in
+          Option.merge acc scope_for_key ~f:(fun a b ->
+            assert (Dune_project.equal a b);
+            a))
+      in
+      { pps; project_root = Option.map project ~f:Dune_project.root }
+    ;;
+  end
+
+  let reverse_table : (Digest.t, Decoded.t) Table.t = Table.create (module Digest) 128
+
+  let encode ({ Decoded.pps; project_root } as x) =
+    let y = Digest.generic (pps, project_root) in
+    match Table.find reverse_table y with
+    | None ->
+      Table.set reverse_table y x;
+      y
+    | Some x' ->
+      if Decoded.equal x x'
+      then y
+      else
+        User_error.raise
+          [ Pp.textf "Hash collision between set of ppx drivers:"
+          ; Pp.textf "- cache : %s" (Decoded.to_string x')
+          ; Pp.textf "- fetch : %s" (Decoded.to_string x)
+          ]
+  ;;
+end
+
+let ppx_exe_path (ctx : Build_context.t) ~key =
+  Path.Build.relative ctx.build_dir (".ppx/" ^ key ^ "/ppx.exe")
+;;
+
+let ppx_driver_exe (ctx : Context.t) libs =
+  let key = Digest.to_string (Key.Decoded.of_libs libs |> Key.encode) in
+  Context.host ctx >>| Context.build_context >>| ppx_exe_path ~key
+;;
+
+let get_ppx_exe ctx ~scope pps =
+  let open Resolve.Memo.O in
+  let* libs = Lib.DB.resolve_pps (Scope.libs scope) pps in
+  ppx_driver_exe ctx libs |> Resolve.Memo.lift_memo
+;;

src/dune_rules/ppx_exe.mli

@@ -0,0 +1,13 @@
+open Import
+
+(** Get the path to a ppx driver executable for a list of ppx rewriter libraries.
+    This module provides the core ppx executable resolution logic without depending
+    on the Expander module. *)
+
+(** Get the path to the ppx driver executable for a list of ppx libraries.
+    The libraries must be provided with their locations for error reporting. *)
+val get_ppx_exe
+  :  Context.t
+  -> scope:Scope.t
+  -> (Loc.t * Lib_name.t) list
+  -> Path.Build.t Resolve.Memo.t

test/blackbox-tests/test-cases/ppx/dune

@@ -1,5 +1,5 @@
 (cram
- (applies_to ppx-rewriter 9650-bytecode-rewriter)
+ (applies_to ppx-rewriter 9650-bytecode-rewriter ppx-pform)
  (deps
   (package ppxlib)
   %{bin:ocamlfind}))

test/blackbox-tests/test-cases/ppx/ppx-pform.t

@@ -0,0 +1,70 @@
+Test the %{ppx:...} pform that creates a combined ppx executable
+
+  $ cat >dune-project <<EOF
+  > (lang dune 3.21)
+  > EOF
+
+Create two simple ppx rewriters
+
+  $ mkdir ppx1 ppx2
+
+  $ cat >ppx1/dune <<EOF
+  > (library
+  >  (name ppx1)
+  >  (kind ppx_rewriter))
+  > EOF
+
+  $ cat >ppx1/ppx1.ml <<EOF
+  > let () = Ppxlib.Driver.register_transformation "ppx1"
+  >   ~impl:(fun structure -> structure)
+  > EOF
+
+  $ cat >ppx2/dune <<EOF
+  > (library
+  >  (name ppx2)
+  >  (kind ppx_rewriter))
+  > EOF
+
+  $ cat >ppx2/ppx2.ml <<EOF
+  > let () = Ppxlib.Driver.register_transformation "ppx2"
+  >   ~impl:(fun structure -> structure)
+  > EOF
+
+Create a rule that uses the ppx pform
+
+  $ cat >dune <<EOF
+  > (rule
+  >  (alias test-ppx)
+  >  (action (system "echo %{ppx:ppx1+ppx2}")))
+  > EOF
+
+Run the test
+
+  $ dune build @test-ppx
+  .ppx/1b1fa3a921019504476f74bb87685798/ppx.exe
+
+Test that the order of libraries doesn't matter
+
+  $ cat >dune <<EOF
+  > (rule
+  >  (alias test-ppx)
+  >  (action (system "echo %{ppx:ppx2+ppx1}")))
+  > EOF
+
+  $ dune build @test-ppx
+
+
+Invalid ppx form
+
+  $ cat >dune <<EOF
+  > (rule
+  >  (alias test-ppx)
+  >  (action (system "echo %{ppx:.faz+bar}")))
+  > EOF
+
+  $ dune build @test-ppx
+  File "dune", line 3, characters 23-38:
+  3 |  (action (system "echo %{ppx:.faz+bar}")))
+                             ^^^^^^^^^^^^^^^
+  Error: ".faz" is an invalid library name.
+  [1]